+2016-08-31 Paul Thomas <pault@gcc.gnu.org>
+ Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ PR fortran/48298
+
+ * decl.c (access_attr_decl): Include case INTERFACE_DTIO as
+ appropriate.
+ * gfortran.h : Add INTRINSIC_FORMATTED and
+ INTRINSIC_UNFORMATTED to gfc_intrinsic_op. Add INTERFACE_DTIO
+ to interface type. Add new enum 'dtio_codes'. Add bitfield
+ 'has_dtio_procs' to symbol_attr. Add prototypes
+ 'gfc_check_dtio_interfaces' and 'gfc_find_specific_dtio_proc'.
+ * interface.c (dtio_op): New function.
+ (gfc_match_generic_spec): Match generic DTIO interfaces.
+ (gfc_match_interface): Treat DTIO interfaces in the same way as
+ (gfc_current_interface_head): Add INTERFACE_DTIO appropriately.
+ (check_dtio_arg_TKR_intent): New function.
+ (check_dtio_interface1): New function.
+ (gfc_check_dtio_interfaces): New function.
+ (gfc_find_specific_dtio_proc): New function.
+ * io.c : Add FMT_DT to format_token.
+ (format_lex): Handle DTIO formatting.
+ * match.c (gfc_op2string): Add DTIO operators.
+ * resolve.c (derived_inaccessible): Ignore pointer components
+ to enclosing derived type.
+ (resolve_transfer): Resolve transfers that involve DTIO.
+ procedures. Find the specific subroutine for the transfer and
+ use its existence to over-ride some of the constraints on
+ derived types. If the transfer is recursive, require that the
+ subroutine be so qualified.
+ (dtio_procs_present): New function.
+ (resolve_fl_namelist): Remove inhibition of polymorphic objects
+ in namelists if DTIO read and write subroutines exist. Likewise
+ for derived types.
+ (resolve_types): Invoke 'gfc_verify_dtio_procedures'.
+ * symbol.c : Set 'dtio_procs' using 'minit'.
+ * trans-decl.c (gfc_finish_var_decl): If a derived-type/class
+ object is associated with DTIO procedures, make it TREE_STATIC.
+ * trans-expr.c (gfc_get_vptr_from_expr): If the expression
+ drills down to a PARM_DECL, extract the vptr correctly.
+ (gfc_conv_derived_to_class): Check 'info' in the test for
+ 'useflags'. If the se expression exists and is a pointer, use
+ it as the class _data.
+ * trans-io.c : Add IOCALL_X_DERIVED to iocall and the function
+ prototype. Likewise for IOCALL_SET_NML_DTIO_VAL.
+ (set_parameter_tree): Renamed from 'set_parameter_const', now
+ returns void and has new tree argument. Calls modified to match
+ new interface.
+ (transfer_namelist_element): Transfer DTIO procedure pointer
+ and vpointer using the new function IOCALL_SET_NML_DTIO_VAL.
+ (get_dtio_proc): New function.
+ (transfer_expr): Add new argument for the vptr field of class
+ objects. Add the code to call the specific DTIO proc, convert
+ derived types to class and call IOCALL_X_DERIVED.
+ (trans_transfer): Add BT_CLASS to structures for treatment by
+ the scalarizer. Obtain the vptr for the dynamic type, both for
+ scalar and array transfer.
+
2016-08-30 Fritz Reese <fritzoreese@gmail.com>
* gfortran.texi: Fix typo in STRUCTURE documentation.
goto syntax;
case INTERFACE_GENERIC:
+ case INTERFACE_DTIO:
if (gfc_get_symbol (name, NULL, &sym))
goto done;
switch (op_type)
{
case INTERFACE_GENERIC:
+ case INTERFACE_DTIO:
snprintf (bind_name, sizeof (bind_name), "%s", name);
break;
switch (op_type)
{
+ case INTERFACE_DTIO:
case INTERFACE_USER_OP:
case INTERFACE_GENERIC:
{
switch (op_type)
{
+ case INTERFACE_DTIO:
case INTERFACE_GENERIC:
case INTERFACE_USER_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.
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.
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. */
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. */
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. */
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;
}
+/* 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. */
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);
switch (type)
{
+ case INTERFACE_DTIO:
case INTERFACE_GENERIC:
if (gfc_get_symbol (name, NULL, &sym))
return MATCH_ERROR;
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);
}
break;
+ case INTERFACE_DTIO:
case INTERFACE_GENERIC:
if (type != current_interface.type
|| strcmp (current_interface.sym->name, name) != 0)
else
return MATCH_YES;
}
-
+
if (i == INTRINSIC_USER)
{
for (ns = gfc_current_ns; ns; ns = ns->parent)
{
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;
}
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;
}
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;
break;
case INTERFACE_GENERIC:
+ case INTERFACE_DTIO:
return current_interface.sym->generic;
break;
break;
case INTERFACE_GENERIC:
+ case INTERFACE_DTIO:
current_interface.sym->generic = i;
break;
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;
+ break;
+ }
+ }
+
+ 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;
+ break;
+ }
+ }
+ }
+ }
+
+finish:
+ if (dtio_sub && derived != CLASS_DATA (dtio_sub->formal->sym)->ts.u.derived)
+ gfc_find_derived_vtab (derived);
+
+ return dtio_sub;
+}
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
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;
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:
case INTRINSIC_NONE:
return "none";
+ /* DTIO */
+ case INTRINSIC_FORMATTED:
+ return "formatted";
+ case INTRINSIC_UNFORMATTED:
+ return "unformatted";
+
default:
break;
}
for (c = sym->components; c; c = c->next)
{
+ /* Prevent an infinite loop through this function. */
+ 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;
}
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;
/* 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;
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);
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 "
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 "
"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;
}
}
}
+/* 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. */
}
+/* 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)
{
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 "
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;
+ }
}
}
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))
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);
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. */
&& 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;
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;
}
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. */
cond_optional, tmp,
fold_convert (TREE_TYPE (tmp), null_pointer_node));
gfc_add_modify (&parmse->pre, ctree, tmp);
-
}
else
{
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 */
{
IOCALL_X_COMPLEX128_WRITE,
IOCALL_X_ARRAY,
IOCALL_X_ARRAY_WRITE,
+ IOCALL_X_DERIVED,
IOCALL_OPEN,
IOCALL_CLOSE,
IOCALL_INQUIRE,
IOCALL_ENDFILE,
IOCALL_FLUSH,
IOCALL_SET_NML_VAL,
+ IOCALL_SET_NML_DTIO_VAL,
IOCALL_SET_NML_VAL_DIM,
IOCALL_WAIT,
IOCALL_NUM
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 (
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);
+ iocall[IOCALL_SET_NML_DTIO_VAL] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("st_set_nml_dtio_var")), ".w.R",
+ 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",
void_type_node, 5, dt_parm_type, gfc_int4_type_node,
}
-/* 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];
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;
}
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);
}
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;
}
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;
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,
- dt_parm_addr, addr_expr, string,
- build_int_cst (gfc_int4_type_node, ts->kind),
- tmp, dtype);
+
+ if (dtio_proc == NULL_TREE)
+ tmp = build_call_expr_loc (input_location,
+ iocall[IOCALL_SET_NML_VAL], 6,
+ dt_parm_addr, addr_expr, string,
+ build_int_cst (gfc_int4_type_node, ts->kind),
+ tmp, dtype);
+ else
+ tmp = build_call_expr_loc (input_location,
+ iocall[IOCALL_SET_NML_DTIO_VAL], 8,
+ dt_parm_addr, addr_expr, string,
+ build_int_cst (gfc_int4_type_node, ts->kind),
+ tmp, dtype, dtio_proc, vtable);
gfc_add_expr_to_block (block, tmp);
/* If the object is an array, transfer rank times:
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;
}
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
/* 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. */
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;
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);
}
gfc_ss *ss;
gfc_se se;
tree tmp;
+ tree vptr;
int n;
gfc_start_block (&block);
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
{
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))
{
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:
+2016-08-31 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+ Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/48298
+ * gfortran.dg/dtio_1.f90: New test.
+ * gfortran.dg/dtio_2.f90: New test.
+ * gfortran.dg/dtio_3.f90: New test.
+ * gfortran.dg/dtio_4.f90: New test.
+ * gfortran.dg/dtio_5.f90: New test.
+ * gfortran.dg/dtio_6.f90: New test.
+ * gfortran.dg/dtio_7.f90: New test.
+ * gfortran.dg/dtio_8.f90: New test.
+ * gfortran.dg/dtio_9.f90: New test.
+ * gfortran.dg/dtio_10.f90: New test.
+
2016-08-30 David Malcolm <dmalcolm@redhat.com>
* gcc.dg/plugin/diagnostic-test-show-locus-bw.c
--- /dev/null
+! { 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") call abort
+ 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { dg-do run }\r
+!\r
+! Functional test of User Defined Derived Type IO.\r
+!\r
+! This tests recursive calls where a derived type has a member that is\r
+! itself.\r
+!\r
+MODULE p\r
+ USE ISO_FORTRAN_ENV\r
+ TYPE :: person\r
+ CHARACTER (LEN=20) :: name\r
+ INTEGER(4) :: age\r
+ type(person), pointer :: next => NULL()\r
+ CONTAINS\r
+ procedure :: pwf\r
+ procedure :: prf\r
+ GENERIC :: WRITE(FORMATTED) => pwf\r
+ GENERIC :: READ(FORMATTED) => prf\r
+ END TYPE person\r
+CONTAINS\r
+ RECURSIVE SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg)\r
+ CLASS(person), INTENT(IN) :: dtv\r
+ INTEGER, INTENT(IN) :: unit\r
+ CHARACTER (LEN=*), INTENT(IN) :: iotype\r
+ INTEGER, INTENT(IN) :: vlist(:)\r
+ INTEGER, INTENT(OUT) :: iostat\r
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg\r
+ CHARACTER (LEN=30) :: udfmt\r
+ INTEGER :: myios\r
+\r
+ udfmt='(*(g0))'\r
+ iomsg = "SUCCESS"\r
+ iostat=0\r
+ if (iotype.eq."DT") then\r
+ if (size(vlist).ne.0) print *, 36\r
+ if (associated(dtv%next)) then\r
+ WRITE(unit, FMT = '(a20,i2, DT)', IOSTAT=iostat, advance='no') dtv%name, dtv%age, dtv%next\r
+ else\r
+ WRITE(unit, FMT = '(a20,i2)', IOSTAT=iostat, advance='no') dtv%name, dtv%age\r
+ endif\r
+ if (iostat.ne.0) iomsg = "Fail PWF DT"\r
+ endif\r
+ if (iotype.eq."DTzeroth") then\r
+ if (size(vlist).ne.0) print *, 40\r
+ WRITE(unit, FMT = '(g0,g0)', advance='no') dtv%name, dtv%age\r
+ if (iostat.ne.0) iomsg = "Fail PWF DTzeroth"\r
+ endif\r
+ if (iotype.eq."DTtwo") then\r
+ if (size(vlist).ne.2) call abort\r
+ WRITE(udfmt,'(A,A,I1,A,I1,A)') '(', 'A', vlist(1),',I', vlist(2), ')'\r
+ WRITE(unit, FMT='(A8,I2)') dtv%name, dtv%age\r
+ if (iostat.ne.0) iomsg = "Fail PWF DTtwo"\r
+ endif\r
+ if (iotype.eq."DTthree") then\r
+ WRITE(udfmt,'(2A,I2,A,I1,A,I2,A)',iostat=myios) '(', 'A', vlist(1),',I', vlist(2), ',F', vlist(3), '.2)'\r
+ WRITE(unit, FMT=udfmt, IOSTAT=iostat, advance='no') trim(dtv%name), dtv%age, 3.14\r
+ if (iostat.ne.0) iomsg = "Fail PWF DTthree"\r
+ endif\r
+ if (iotype.eq."LISTDIRECTED") then\r
+ if (size(vlist).ne.0) print *, 55\r
+ if (associated(dtv%next)) then\r
+ WRITE(unit, FMT = *) dtv%name, dtv%age, dtv%next\r
+ else\r
+ WRITE(unit, FMT = *) dtv%name, dtv%age\r
+ endif\r
+ if (iostat.ne.0) iomsg = "Fail PWF LISTDIRECTED"\r
+ endif\r
+ if (iotype.eq."NAMELIST") then\r
+ if (size(vlist).ne.0) print *, 59\r
+ iostat=6000\r
+ endif\r
+ if (associated (dtv%next) .and. (iotype.eq."LISTDIRECTED")) write(unit, fmt = *) dtv%next\r
+ END SUBROUTINE pwf\r
+\r
+ RECURSIVE SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg)\r
+ CLASS(person), INTENT(INOUT) :: dtv\r
+ INTEGER, INTENT(IN) :: unit\r
+ CHARACTER (LEN=*), INTENT(IN) :: iotype\r
+ INTEGER, INTENT(IN) :: vlist(:)\r
+ INTEGER, INTENT(OUT) :: iostat\r
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg\r
+ CHARACTER (LEN=30) :: udfmt\r
+ INTEGER :: myios\r
+ real :: areal\r
+ udfmt='(*(g0))'\r
+ iomsg = "SUCCESS"\r
+ iostat=0\r
+ if (iotype.eq."DT") then\r
+ if (size(vlist).ne.0) print *, 36\r
+ if (associated(dtv%next)) then\r
+ READ(unit, FMT = '(a20,i2, DT)', IOSTAT=iostat, advance='no') dtv%name, dtv%age, dtv%next\r
+ else\r
+ READ(unit, FMT = '(a20,i2)', IOSTAT=iostat, advance='no') dtv%name, dtv%age\r
+ endif\r
+ if (iostat.ne.0) iomsg = "Fail PWF DT"\r
+ endif\r
+ if (iotype.eq."DTzeroth") then\r
+ if (size(vlist).ne.0) print *, 40\r
+ READ(unit, FMT = '(a,I2)', advance='no') dtv%name, dtv%age\r
+ if (iostat.ne.0) iomsg = "Fail PWF DTzeroth"\r
+ endif\r
+ if (iotype.eq."DTtwo") then\r
+ if (size(vlist).ne.2) call abort\r
+ WRITE(udfmt,'(A,A,I1,A,I1,A)') '(', 'A', vlist(1),',I', vlist(2), ')'\r
+ READ(unit, FMT='(A8,I2)') dtv%name, dtv%age\r
+ if (iostat.ne.0) iomsg = "Fail PWF DTtwo"\r
+ endif\r
+ if (iotype.eq."DTthree") then\r
+ WRITE(udfmt,'(2A,I2,A,I1,A,I2,A)',iostat=myios) '(', 'A', vlist(1),',I', vlist(2), ',F', vlist(3), '.2)'\r
+ READ(unit, FMT=udfmt, IOSTAT=iostat, advance='no') dtv%name, dtv%age, areal\r
+ if (iostat.ne.0) iomsg = "Fail PWF DTthree"\r
+ endif\r
+ if (iotype.eq."LISTDIRECTED") then\r
+ if (size(vlist).ne.0) print *, 55\r
+ READ(unit, FMT = *) dtv%name, dtv%age\r
+ if (iostat.ne.0) iomsg = "Fail PWF LISTDIRECTED"\r
+ endif\r
+ if (iotype.eq."NAMELIST") then\r
+ if (size(vlist).ne.0) print *, 59\r
+ iostat=6000\r
+ endif\r
+ !READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age\r
+ END SUBROUTINE prf\r
+\r
+END MODULE p\r
+\r
+PROGRAM test\r
+ USE p\r
+ TYPE (person) :: chairman\r
+ TYPE (person), target :: member\r
+ character(80) :: astring\r
+ integer :: thelength\r
+\r
+ chairman%name="Charlie"\r
+ chairman%age=62\r
+ member%name="George"\r
+ member%age=42\r
+ astring = "FAILURE"\r
+ ! At this point, next is NULL as defined up in the type block.\r
+ open(10, status = "scratch")\r
+ write (10, *, iostat=myiostat, iomsg=astring) member, chairman\r
+ write(10,*)\r
+ rewind(10)\r
+ chairman%name="bogus1"\r
+ chairman%age=99\r
+ member%name="bogus2"\r
+ member%age=66\r
+ read (10, *, iostat=myiostat, iomsg=astring) member, chairman\r
+ if (astring.ne."SUCCESS") print *, astring\r
+ if (member%name.ne."George") call abort\r
+ if (chairman%name.ne."Charlie") call abort\r
+ if (member%age.ne.42) call abort\r
+ if (chairman%age.ne.62) call abort\r
+ close(10, status='delete')\r
+ ! Now we set next to point to member. This changes the code path\r
+ ! in the pwf and prf procedures.\r
+ chairman%next => member\r
+ open(10, status = "scratch")\r
+ write (10,"(DT)") chairman\r
+ rewind(10)\r
+ chairman%name="bogus1"\r
+ chairman%age=99\r
+ member%name="bogus2"\r
+ member%age=66\r
+ read (10,"(DT)", iomsg=astring) chairman\r
+ !print *, trim(astring)\r
+ if (member%name.ne."George") call abort\r
+ if (chairman%name.ne."Charlie") call abort\r
+ if (member%age.ne.42) call abort\r
+ if (chairman%age.ne.62) call abort\r
+ close(10)\r
+END PROGRAM test\r
--- /dev/null
+! { dg-do run }\r
+!\r
+! Functional test of User Defined Derived Type IO.\r
+!\r
+! This tests a combination of module procedure and generic procedure\r
+! and performs reading and writing an array with a pseudo user defined\r
+! tag at the beginning of the file.\r
+!\r
+module usertypes\r
+ type udt\r
+ integer :: myarray(15)\r
+ contains\r
+ procedure :: user_defined_read\r
+ generic :: read (formatted) => user_defined_read\r
+ end type udt\r
+ type, extends(udt) :: more\r
+ integer :: someinteger = -25\r
+ end type\r
+\r
+ interface write(formatted)\r
+ module procedure user_defined_write\r
+ end interface\r
+\r
+ integer :: result_array(15)\r
+contains\r
+ subroutine user_defined_read (dtv, unit, iotype, v_list, iostat, iomsg)\r
+ class(udt), intent(inout) :: dtv\r
+ integer, intent(in) :: unit\r
+ character(*), intent(in) :: iotype\r
+ integer, intent(in) :: v_list (:)\r
+ integer, intent(out) :: iostat\r
+ character(*), intent(inout) :: iomsg\r
+ character(10) :: typestring\r
+\r
+ iomsg = 'SUCCESS'\r
+ read (unit, '(a6)', iostat=iostat, iomsg=iomsg) typestring\r
+ typestring = trim(typestring)\r
+ select type (dtv)\r
+ type is (udt)\r
+ if (typestring.eq.' UDT: ') then\r
+ read (unit, fmt=*, iostat=iostat, iomsg=iomsg) dtv%myarray\r
+ else\r
+ iostat = 6000\r
+ iomsg = 'FAILURE'\r
+ end if\r
+ type is (more)\r
+ if (typestring.eq.' MORE: ') then\r
+ read (unit, fmt=*, iostat=iostat, iomsg=iomsg) dtv%myarray\r
+ else\r
+ iostat = 6000\r
+ iomsg = 'FAILUREwhat'\r
+ end if\r
+ end select\r
+ end subroutine user_defined_read\r
+\r
+ subroutine user_defined_write (dtv, unit, iotype, v_list, iostat, iomsg)\r
+ class(udt), intent(in) :: dtv\r
+ integer, intent(in) :: unit\r
+ character(*), intent(in) :: iotype\r
+ integer, intent(in) :: v_list (:)\r
+ integer, intent(out) :: iostat\r
+ character(*), intent(inout) :: iomsg\r
+ character(10) :: typestring\r
+ select type (dtv)\r
+ type is (udt)\r
+ write (unit, fmt=*, iostat=iostat, iomsg=iomsg) "UDT: "\r
+ write (unit, fmt=*, iostat=iostat, iomsg=iomsg) dtv%myarray\r
+ type is (more)\r
+ write (unit, fmt=*, iostat=iostat, iomsg=iomsg) "MORE: "\r
+ write (unit, fmt=*, iostat=iostat, iomsg=iomsg) dtv%myarray\r
+ end select\r
+ write (unit,*)\r
+ end subroutine user_defined_write\r
+end module usertypes\r
+\r
+program test1\r
+ use usertypes\r
+ type (udt) :: udt1\r
+ type (more) :: more1\r
+ class (more), allocatable :: somemore\r
+ integer :: thesize, i, ios\r
+ character(25):: iomsg\r
+\r
+! Create a file that contains some data for testing.\r
+ open (10, form='formatted', status='scratch')\r
+ write(10, '(a)') ' UDT: '\r
+ do i = 1, 15\r
+ write(10,'(i5)', advance='no') i\r
+ end do\r
+ write(10,*)\r
+ rewind(10)\r
+ udt1%myarray = 99\r
+ result_array = (/ (i, i = 1, 15) /)\r
+ more1%myarray = result_array\r
+ read (10, fmt='(dt)', advance='no', iomsg=iomsg) udt1\r
+ if (iomsg.ne.'SUCCESS') call abort\r
+ if (any(udt1%myarray.ne.result_array)) call abort\r
+ close(10)\r
+ open (10, form='formatted')\r
+ write (10, '(dt)') more1\r
+ rewind(10)\r
+ more1%myarray = 99\r
+ read (10, '(dt)', iostat=ios, iomsg=iomsg) more1\r
+ if (iomsg.ne.'SUCCESS') call abort\r
+ if (any(more1%myarray.ne.result_array)) call abort\r
+ close (10)\r
+end program test1\r
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
+2016-08-31 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+ Paul Thomas <pault@gcc.gnu.org>
+
+ PR libgfortran/48298
+ * gfortran.map : Flag _st_set_nml_dtio_var and
+ _gfortran_transfer_derived.
+ * io/format.c (format_lex): Detect DTIO formatting.
+ (parse_format_list): Parse the DTIO format.
+ (next_format): Include FMT_DT.
+ * io/format.h : Likewise. Add structure 'udf' to structure
+ 'fnode' to carry the IOTYPE string and the 'vlist'.
+ * io/io.h : Add prototypes for the two types of DTIO subroutine
+ and a typedef for gfc_class. Also, add to 'namelist_type'
+ fields for the pointer to the DTIO procedure and the vtable.
+ Add fields to struct st_parameter_dt for pointers to the two
+ types of DTIO subroutine. Add to gfc_unit DTIO specific fields.
+ (internal_proto): Add prototype for 'read_user_defined' and
+ 'write_user_defined'.
+ * io/list_read.c (check_buffers): Use the 'current_unit' field.
+ (unget_char): Likewise.
+ (eat_spaces): Likewise.
+ (list_formatted_read_scalar): For case BT_CLASS, call the DTIO
+ procedure.
+ (nml_get_obj_data): Likewise when DTIO procedure is present,.
+ * io/transfer.c : Export prototypes for 'transfer_derived' and
+ 'transfer_derived_write'.
+ (unformatted_read): For case BT_CLASS, call the DTIO procedure.
+ (unformatted_write): Likewise.
+ (formatted_transfer_scalar_read): Likewise.
+ (formatted_transfer_scalar_write: Likewise.
+ (transfer_derived): New function.
+ (data_transfer_init): Set last_char if no child_dtio.
+ (finalize_transfer): Return if child_dtio set.
+ (st_write_done): Add condition for child_dtio not set.
+ Add extra arguments for st_set_nml_var prototype.
+ (set_nml_var): New function that contains the contents of the
+ old version of st_set_nml_var. Also sets the 'dtio_sub' and
+ 'vtable' fields of the 'nml' structure.
+ (st_set_nml_var): Now just calls set_nml_var with 'dtio_sub'
+ and 'vtable' NULL.
+ (st_set_nml_dtio_var): New function that calls set_nml_var.
+ * io/unit.c (get_external_unit): If the found unit child_dtio
+ is non zero, don't do any mutex locking/unlocking. Just
+ return the unit.
+ * io/unix.c (tempfile_open): Revert to C style comment.
+ * io/write.c (list_formatted_write_scalar): Do the DTIO call.
+ (nml_write_obj): Add BT_CLASS and do the DTIO call.
+
2016-08-29 Nathan Sidwell <nathan@acm.org>
* configure.ac (nvptx-*): Hardwire newlib.
(read_character): Remove condition testing c = '!' which is now inside
the is_separator macro. (parse_real): Reject '!' unless in namelist mode.
(read_complex): Reject '!' unless in namelist mode. (read_real): Likewise
- reject '!'.
+ reject '!'.
2016-02-12 Jerry DeLisle <jvdelisle@gcc.gnu.org>
_gfortran_transpose_char4;
_gfortran_unpack0_char4;
_gfortran_unpack1_char4;
-} GFORTRAN_1.0;
+} GFORTRAN_1.0;
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:
_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:
__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:
_gfortran_mvbits_i16;
_gfortran_shape_1;
_gfortran_shape_2;
-} GFORTRAN_1.6;
+} GFORTRAN_1.6;
+
+GFORTRAN_1.8 {
+ global:
+ _gfortran_st_set_nml_dtio_var;
+ _gfortran_transfer_derived;
+} GFORTRAN_1.7;
F2C_1.0 {
global:
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;
}
}
fn->count = 0;
fn->current = NULL;
-
+
if (fn->format != FMT_LPAREN)
return;
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;
case 'C':
token = FMT_DC;
break;
+ case 'T':
+ token = FMT_DT;
+ break;
default:
token = FMT_D;
unget_char (fmt);
tail->u.string.length = fmt->value;
tail->repeat = 1;
goto optional_comma;
-
+
case FMT_RC:
case FMT_RD:
case FMT_RN:
case FMT_EN:
case FMT_ES:
case FMT_D:
+ case FMT_DT:
case FMT_L:
case FMT_A:
case FMT_F:
/* 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:
}
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)
{
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)
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;
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;
}
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;
}
integer;
+ struct
+ {
+ char *string;
+ int string_len;
+ gfc_array_i4 *vlist;
+ }
+ udf; /* User Defined Format. */
+
int w;
int k;
int r;
}
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
/* 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;
/* 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;
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
/* 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;
extern void read_decimal (st_parameter_dt *, const fnode *, char *, int);
internal_proto(read_decimal);
+extern void read_user_defined (st_parameter_dt *, void *);
+internal_proto(read_user_defined);
+
+extern void read_user_defined (st_parameter_dt *, void *);
+internal_proto(read_user_defined);
+
/* list_read.c */
extern void list_formatted_read (st_parameter_dt *, bt, void *, int, size_t,
extern void write_z (st_parameter_dt *, const fnode *, const char *, int);
internal_proto(write_z);
+extern void write_user_defined (st_parameter_dt *, void *);
+internal_proto(write_user_defined);
+
+extern void write_user_defined (st_parameter_dt *, void *);
+internal_proto(write_user_defined);
+
extern void list_formatted_write (st_parameter_dt *, bt, void *, int, size_t,
size_t);
internal_proto(list_formatted_write);
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;
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;
}
static void
unget_char (st_parameter_dt *dtp, int c)
{
- dtp->u.p.last_char = c;
+ dtp->u.p.current_unit->last_char = c;
}
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;
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");
}
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. */
transfer_complex
transfer_real128
transfer_complex128
-
+
and for WRITE
transfer_integer_write
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);
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 */
{
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))
{
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))
{
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. */
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))
{
return NULL;
}
}
-
+
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
dtp->u.p.size_used += (GFC_IO_INT) length;
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;
}
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);
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))
{
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;
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)
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);
/* 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 ?
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. */
case BT_COMPLEX:
p = "COMPLEX";
break;
+ case BT_CLASS:
+ p = "CLASS or DERIVED";
+ break;
default:
internal_error (NULL, "type_name(): Bad type");
}
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)
p = write_block (dtp, length);
if (p == NULL)
return;
-
+
q = f->u.string.p;
delimiter = q[-1];
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));
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));
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;
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;
}
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);
/* 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)
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);
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;
write_d (dtp, f, p, kind);
break;
+ case FMT_DT:
+ if (n == 0)
+ goto need_data;
+ 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;
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
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);
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;
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;
"EOF marker, possibly use REWIND or BACKSPACE");
return;
}
-
}
/* Process the ADVANCE option. */
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,
= !(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;
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;
/* 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
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);
return;
}
}
-
+
/* Sanity checks on the record number. */
if ((cf & IOPARM_DT_HAS_REC) != 0)
/* 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 */
dtp->u.p.max_pos = dtp->u.p.current_unit->saved_pos;
pre_position (dtp);
-
+
/* Set up the subroutine that will handle the transfers. */
{
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;
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;
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)
/* 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;
/* 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;
/* 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;
}
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);
}
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);
}
break;
}
-
+
if (is_stream_io (dtp))
dtp->u.p.current_unit->strm_pos++;
-
+
p = (char) cc;
}
while (p != '\n');
/* 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;
return trans;
bytes_left -= trans;
}
-
+
return nbyte - bytes_left;
}
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;
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.
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);
&finished);
if (finished)
dtp->u.p.current_unit->endfile = AT_ENDFILE;
-
+
/* Now seek to this record */
record = record * dtp->u.p.current_unit->recl;
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);
{
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;
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;
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;
}
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;
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)
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);
unlock_unit (dtp->u.p.current_unit);
free_internal_unit (dtp);
-
+
library_end ();
}
/* 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. */
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;
if (dtp->u.p.current_unit != NULL)
unlock_unit (dtp->u.p.current_unit);
-
+
free_internal_unit (dtp);
library_end ();
/* Receives the scalar information for namelist objects and stores it
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);
-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)
+static void
+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, void *dtio_sub, void *vtable)
{
namelist_info *t1 = NULL;
namelist_info *nml;
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);
}
}
+extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
+ GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
+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)
+{
+ set_nml_var (dtp, var_addr, var_name, len, string_length,
+ dtype, NULL, NULL);
+}
+
+
+/* Essentially the same as previous but carrying the dtio procedure
+ and the vtable as additional arguments. */
+extern void st_set_nml_dtio_var (st_parameter_dt *dtp, void *, char *,
+ GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4,
+ void *, void *);
+export_proto(st_set_nml_dtio_var);
+
+
+void
+st_set_nml_dtio_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
+ GFC_INTEGER_4 len, gfc_charlen_type string_length,
+ GFC_INTEGER_4 dtype, void *dtio_sub, void *vtable)
+{
+ set_nml_var (dtp, var_addr, var_name, len, string_length,
+ dtype, dtio_sub, vtable);
+}
+
/* Store the dimensional information for the namelist object. */
extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
index_type, index_type,
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;
}
found:
- if (p != NULL)
+ if (p != NULL && (p->child_dtio == 0))
{
/* Fast path. */
if (! __gthread_mutex_trylock (&p->lock))
__gthread_mutex_unlock (&unit_lock);
- if (p != NULL)
+ if (p != NULL && (p->child_dtio == 0))
{
__gthread_mutex_lock (&p->lock);
if (p->closed)
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;
}
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;
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
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);
}
u->recl = options.default_recl;
u->endfile = AT_ENDFILE;
-
+
u->filename = strdup (stdout_name);
-
+
fbuf_init (u, 0);
__gthread_mutex_unlock (&u->lock);
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. */
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)
free (u->filename);
u->filename = NULL;
- free_format_hash_table (u);
+ free_format_hash_table (u);
fbuf_destroy (u);
if (!locked)
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);
void
finish_last_advance_record (gfc_unit *u)
{
-
+
if (u->saved_pos > 0)
fbuf_seek (u, u->saved_pos, SEEK_CUR);
)
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
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++;
int j, k = 0;
gfc_char4_t c;
uchar d;
-
+
/* Take care of preceding blanks. */
if (w_len > src_len)
{
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)
bytes = 0;
}
- /* Write out the CR_LF sequence. */
+ /* Write out the CR_LF sequence. */
q++;
p = write_block (dtp, 2);
if (p == NULL)
bytes = 0;
}
- /* Write out the CR_LF sequence. */
+ /* Write out the CR_LF sequence. */
write_default_char4 (dtp, crlf, 2, 0);
}
else
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;
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
{
char *q;
int i, j;
-
+
q = buffer;
if (big_endian)
{
if (*n == 0)
return "0";
- /* Move past any leading zeros. */
+ /* Move past any leading zeros. */
while (*buffer == '0')
buffer++;
if (*n == 0)
return "0";
- /* Move past any leading zeros. */
+ /* Move past any leading zeros. */
while (*q == '0')
q++;
char *q;
uint8_t h, l;
int i;
-
+
q = buffer;
-
+
if (big_endian)
{
const char *p = s;
}
*q = '\0';
-
+
if (*n == 0)
return "0";
-
- /* Move past any leading zeros. */
+
+ /* Move past any leading zeros. */
while (*buffer == '0')
buffer++;
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);
/* 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);
/* 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);
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)
/* 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);
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)
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");
}
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. */
break;
default:
- obj_size = len;
+ obj_size = len;
}
if (obj->var_rank)
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
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;
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) ? ')' : ',';
projects / gcc.git / commitdiff