Ping : [Patch, fortran] PR48298 - [F03] User-Defined Derived-Type IO (DTIO)
Paul Richard Thomas
paul.richard.thomas@gmail.com
Sat Aug 27 18:50:00 GMT 2016
Dear All,
Please find attached the complete patch for DTIO, including the fix
for the mutex_lock problem and all the testcases.
Although we have said that we would commit on Monday if no review is
forthcoming, we would very much prefer that somebody takes a look. We
understand perfectly that a 4052 line patch is rather daunting.
However, even a cursory scan of the patch would be helpful.
Many thanks to Dominique for giving the patch a whirl. This almost
certainly helped keep our blood pressure more or less level :-)
Best regards
Paul and Jerry
On 22 August 2016 at 14:32, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
> Dear All,
>
> The attached patch implements the above DTIO feature. This is the
> penultimate F2003 feature to be implemented in gfortran. (The last is
> Parameterized Derived-Types, which look to be difficult to judge by
> the remarks coming from other vendors).
>
> Although fairly long, the patch is straightforward. It includes some
> whitespace corrections, which are not remarked upon in the ChangeLogs.
>
> There are four known issues, for which PRs will be raised:
> 1) DTIO to internal units is not implemented;
> 2) Inquire length is not implemented;
> 3) Size = in READ statements is not implemented; and
> 4) There is a mystery optimization bug, at all levels of optimization,
> which causes IF statements to disappear in some of the testcases. This
> has been masked by the chunk in trans-decl.c that forces derived-type
> and class objects with associated DTIO procedures to be TREE_STATIC.
>
> The testcases dtio_[3,4].f90 are on their way. We had set ourselves
> the target of today to submit but the issue #4 derailed the
> preparation of these testcases. These will be posted as soon as
> possible.
>
> Bootstrapped and regtested on FC21/x86_64 - OK for trunk?
>
> Given that DTIO is only triggered by the specific typebound or generic
> interfaces, we intend to commit the patch in one week from today if no
> review is forthcoming.
>
> Paul and Jerry
>
> 2016-08-22 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.
> (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_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. Add two new arguments to IOCALL_SET_NML_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 the table to the vpointer, using the two new arguments of
> IOCALL_SET_NML_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-22 Jerry DeLisle <jvdelisle@gcc.gnu.org>
> Paul Thomas <pault@gcc.gnu.org>
>
> PR libgfortran/48298
> * gfortran.map : Flag _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.
> (st_set_nml_var): Set the 'dtio_sub' and 'vtable' fields of the
> 'nml' structure.
> * 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-22 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_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.
--
The difference between genius and stupidity is; genius has its limits.
Albert Einstein
-------------- next part --------------
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c (revision 239769)
--- gcc/fortran/decl.c (working copy)
*************** access_attr_decl (gfc_statement st)
*** 7469,7474 ****
--- 7469,7475 ----
goto syntax;
case INTERFACE_GENERIC:
+ case INTERFACE_DTIO:
if (gfc_get_symbol (name, NULL, &sym))
goto done;
*************** gfc_match_generic (void)
*** 9378,9383 ****
--- 9379,9385 ----
switch (op_type)
{
case INTERFACE_GENERIC:
+ case INTERFACE_DTIO:
snprintf (bind_name, sizeof (bind_name), "%s", name);
break;
*************** gfc_match_generic (void)
*** 9413,9418 ****
--- 9415,9421 ----
switch (op_type)
{
+ case INTERFACE_DTIO:
case INTERFACE_USER_OP:
case INTERFACE_GENERIC:
{
*************** gfc_match_generic (void)
*** 9467,9472 ****
--- 9470,9476 ----
switch (op_type)
{
+ case INTERFACE_DTIO:
case INTERFACE_GENERIC:
case INTERFACE_USER_OP:
{
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 239769)
--- gcc/fortran/gfortran.h (working copy)
*************** enum gfc_intrinsic_op
*** 177,184 ****
/* .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 */
};
/* This macro is the number of intrinsic operators that exist.
--- 177,186 ----
/* .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,
! /* 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 gfc_statement
*** 261,267 ****
enum interface_type
{
INTERFACE_NAMELESS = 1, INTERFACE_GENERIC,
! INTERFACE_INTRINSIC_OP, INTERFACE_USER_OP, INTERFACE_ABSTRACT
};
/* Symbol flavors: these are all mutually exclusive.
--- 263,270 ----
enum interface_type
{
INTERFACE_NAMELESS = 1, INTERFACE_GENERIC,
! INTERFACE_INTRINSIC_OP, INTERFACE_USER_OP, INTERFACE_ABSTRACT,
! INTERFACE_DTIO
};
/* Symbol flavors: these are all mutually exclusive.
*************** extern const mstring access_types[];
*** 313,318 ****
--- 316,327 ----
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. */
*************** typedef struct
*** 841,847 ****
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;
/* This is a temporary selector for SELECT TYPE or an associate
variable for SELECT_TYPE or ASSOCIATE. */
--- 850,857 ----
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,
! has_dtio_procs:1;
/* This is a temporary selector for SELECT TYPE or an associate
variable for SELECT_TYPE or ASSOCIATE. */
*************** bool gfc_check_operator_interface (gfc_s
*** 3170,3175 ****
--- 3180,3188 ----
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;
Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c (revision 239769)
--- gcc/fortran/interface.c (working copy)
*************** fold_unary_intrinsic (gfc_intrinsic_op o
*** 115,120 ****
--- 115,133 ----
}
+ /* 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. */
*************** gfc_match_generic_spec (interface_type *
*** 162,167 ****
--- 175,214 ----
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);
*************** gfc_match_interface (void)
*** 209,214 ****
--- 256,262 ----
switch (type)
{
+ case INTERFACE_DTIO:
case INTERFACE_GENERIC:
if (gfc_get_symbol (name, NULL, &sym))
return MATCH_ERROR;
*************** gfc_match_end_interface (void)
*** 371,376 ****
--- 419,425 ----
break;
+ case INTERFACE_DTIO:
case INTERFACE_GENERIC:
if (type != current_interface.type
|| strcmp (current_interface.sym->name, name) != 0)
*************** gfc_add_interface (gfc_symbol *new_sym)
*** 4198,4203 ****
--- 4247,4253 ----
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);
*************** gfc_current_interface_head (void)
*** 4245,4250 ****
--- 4295,4301 ----
break;
case INTERFACE_GENERIC:
+ case INTERFACE_DTIO:
return current_interface.sym->generic;
break;
*************** gfc_set_current_interface_head (gfc_inte
*** 4268,4273 ****
--- 4319,4325 ----
break;
case INTERFACE_GENERIC:
+ case INTERFACE_DTIO:
current_interface.sym->generic = i;
break;
*************** gfc_check_typebound_override (gfc_symtre
*** 4484,4486 ****
--- 4536,4839 ----
return true;
}
+
+
+ /* The following three functions check that the formal arguments
+ of user defined derived type IO procedures are compliant with
+ the requirements of the standard. */
+
+ static void
+ check_dtio_arg_TKR_intent (gfc_symbol *fsym, bool typebound, bt type,
+ int kind, int rank, sym_intent intent)
+ {
+ if (fsym->ts.type != type)
+ gfc_error ("DTIO dummy argument at %L must be of type %s",
+ &fsym->declared_at, gfc_basic_typename (type));
+
+ if (fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED
+ && fsym->ts.kind != kind)
+ gfc_error ("DTIO dummy argument at %L must be of KIND = %d",
+ &fsym->declared_at, kind);
+
+ if (!typebound
+ && rank == 0
+ && (((type == BT_CLASS) && CLASS_DATA (fsym)->attr.dimension)
+ || ((type != BT_CLASS) && fsym->attr.dimension)))
+ gfc_error ("DTIO dummy argument at %L be a scalar",
+ &fsym->declared_at);
+ else if (rank == 1
+ && (fsym->as == NULL || fsym->as->type != AS_ASSUMED_SHAPE))
+ gfc_error ("DTIO dummy argument at %L must be an "
+ "ASSUMED SHAPE ARRAY", &fsym->declared_at);
+
+ if (fsym->attr.intent != intent)
+ gfc_error ("DTIO dummy argument at %L must have intent %s",
+ &fsym->declared_at, gfc_code2string (intents, (int)intent));
+ return;
+ }
+
+
+ static void
+ check_dtio_interface1 (gfc_symbol *derived, gfc_symtree *tb_io_st,
+ bool typebound, bool formatted, int code)
+ {
+ gfc_symbol *dtio_sub, *generic_proc, *fsym;
+ gfc_typebound_proc *tb_io_proc, *specific_proc;
+ gfc_interface *intr;
+ gfc_formal_arglist *formal;
+ int arg_num;
+
+ bool read = ((dtio_codes)code == DTIO_RF)
+ || ((dtio_codes)code == DTIO_RUF);
+ bt type;
+ sym_intent intent;
+ int kind;
+
+ dtio_sub = NULL;
+ if (typebound)
+ {
+ /* Typebound DTIO binding. */
+ tb_io_proc = tb_io_st->n.tb;
+ gcc_assert (tb_io_proc != NULL);
+ gcc_assert (tb_io_proc->is_generic);
+ gcc_assert (tb_io_proc->u.generic->next == NULL);
+
+ specific_proc = tb_io_proc->u.generic->specific;
+ gcc_assert (!specific_proc->is_generic);
+
+ dtio_sub = specific_proc->u.specific->n.sym;
+ }
+ else
+ {
+ generic_proc = tb_io_st->n.sym;
+ gcc_assert (generic_proc);
+ gcc_assert (generic_proc->generic);
+
+ for (intr = tb_io_st->n.sym->generic; intr; intr = intr->next)
+ {
+ if (intr->sym && intr->sym->formal
+ && ((intr->sym->formal->sym->ts.type == BT_CLASS
+ && CLASS_DATA (intr->sym->formal->sym)->ts.u.derived
+ == derived)
+ || (intr->sym->formal->sym->ts.type == BT_DERIVED
+ && intr->sym->formal->sym->ts.u.derived == derived)))
+ dtio_sub = intr->sym;
+ }
+
+ if (dtio_sub == NULL)
+ return;
+ }
+
+ gcc_assert (dtio_sub);
+ if (!dtio_sub->attr.subroutine)
+ gfc_error ("DTIO procedure %s at %L must be a subroutine",
+ dtio_sub->name, &dtio_sub->declared_at);
+
+ /* Now go through the formal arglist. */
+ arg_num = 1;
+ for (formal = dtio_sub->formal; formal; formal = formal->next, arg_num++)
+ {
+ if (!formatted && arg_num == 3)
+ arg_num = 5;
+ fsym = formal->sym;
+ switch (arg_num)
+ {
+ case(1): /* DTV */
+ type = derived->attr.sequence || derived->attr.is_bind_c ?
+ BT_DERIVED : BT_CLASS;
+ kind = 0;
+ intent = read ? INTENT_INOUT : INTENT_IN;
+ check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+ 0, intent);
+ break;
+
+ case(2): /* UNIT */
+ type = BT_INTEGER;
+ kind = gfc_default_integer_kind;
+ intent = INTENT_IN;
+ check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+ 0, intent);
+ break;
+ case(3): /* IOTYPE */
+ type = BT_CHARACTER;
+ kind = gfc_default_character_kind;
+ intent = INTENT_IN;
+ check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+ 0, intent);
+ break;
+ case(4): /* VLIST */
+ type = BT_INTEGER;
+ kind = gfc_default_integer_kind;
+ intent = INTENT_IN;
+ check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+ 1, intent);
+ break;
+ case(5): /* IOSTAT */
+ type = BT_INTEGER;
+ kind = gfc_default_integer_kind;
+ intent = INTENT_OUT;
+ check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+ 0, intent);
+ break;
+ case(6): /* IOMSG */
+ type = BT_CHARACTER;
+ kind = gfc_default_character_kind;
+ intent = INTENT_INOUT;
+ check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+ 0, intent);
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ }
+ derived->attr.has_dtio_procs = 1;
+ return;
+ }
+
+ void
+ gfc_check_dtio_interfaces (gfc_symbol *derived)
+ {
+ gfc_symtree *tb_io_st;
+ bool t = false;
+ int code;
+ bool formatted;
+
+ if (derived->attr.is_class == 1 || derived->attr.vtype == 1)
+ return;
+
+ /* Check typebound DTIO bindings. */
+ for (code = 0; code < 4; code++)
+ {
+ formatted = ((dtio_codes)code == DTIO_RF)
+ || ((dtio_codes)code == DTIO_WF);
+
+ tb_io_st = gfc_find_typebound_proc (derived, &t,
+ gfc_code2string (dtio_procs, code),
+ true, &derived->declared_at);
+ if (tb_io_st != NULL)
+ check_dtio_interface1 (derived, tb_io_st, true, formatted, code);
+ }
+
+ /* Check generic DTIO interfaces. */
+ for (code = 0; code < 4; code++)
+ {
+ formatted = ((dtio_codes)code == DTIO_RF)
+ || ((dtio_codes)code == DTIO_WF);
+
+ tb_io_st = gfc_find_symtree (derived->ns->sym_root,
+ gfc_code2string (dtio_procs, code));
+ if (tb_io_st != NULL)
+ check_dtio_interface1 (derived, tb_io_st, false, formatted, code);
+ }
+ }
+
+
+ gfc_symbol *
+ gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted)
+ {
+ gfc_symtree *tb_io_st = NULL;
+ gfc_symbol *dtio_sub = NULL;
+ gfc_symbol *extended;
+ gfc_typebound_proc *tb_io_proc, *specific_proc;
+ bool t = false;
+
+ /* Try to find a typebound DTIO binding. */
+ if (formatted == true)
+ {
+ if (write == true)
+ tb_io_st = gfc_find_typebound_proc (derived, &t,
+ gfc_code2string (dtio_procs,
+ DTIO_WF),
+ true,
+ &derived->declared_at);
+ else
+ tb_io_st = gfc_find_typebound_proc (derived, &t,
+ gfc_code2string (dtio_procs,
+ DTIO_RF),
+ true,
+ &derived->declared_at);
+ }
+ else
+ {
+ if (write == true)
+ tb_io_st = gfc_find_typebound_proc (derived, &t,
+ gfc_code2string (dtio_procs,
+ DTIO_WUF),
+ true,
+ &derived->declared_at);
+ else
+ tb_io_st = gfc_find_typebound_proc (derived, &t,
+ gfc_code2string (dtio_procs,
+ DTIO_RUF),
+ true,
+ &derived->declared_at);
+ }
+
+ if (tb_io_st != NULL)
+ {
+ tb_io_proc = tb_io_st->n.tb;
+ gcc_assert (tb_io_proc != NULL);
+ gcc_assert (tb_io_proc->is_generic);
+ gcc_assert (tb_io_proc->u.generic->next == NULL);
+
+ specific_proc = tb_io_proc->u.generic->specific;
+ gcc_assert (!specific_proc->is_generic);
+
+ dtio_sub = specific_proc->u.specific->n.sym;
+ }
+
+ if (tb_io_st != NULL)
+ goto finish;
+
+ /* If there is not a typebound binding, look for a generic
+ DTIO interface. */
+ for (extended = derived; extended;
+ extended = gfc_get_derived_super_type (extended))
+ {
+ if (formatted == true)
+ {
+ if (write == true)
+ tb_io_st = gfc_find_symtree (extended->ns->sym_root,
+ gfc_code2string (dtio_procs,
+ DTIO_WF));
+ else
+ tb_io_st = gfc_find_symtree (extended->ns->sym_root,
+ gfc_code2string (dtio_procs,
+ DTIO_RF));
+ }
+ else
+ {
+ if (write == true)
+ tb_io_st = gfc_find_symtree (extended->ns->sym_root,
+ gfc_code2string (dtio_procs,
+ DTIO_WUF));
+ else
+ tb_io_st = gfc_find_symtree (extended->ns->sym_root,
+ gfc_code2string (dtio_procs,
+ DTIO_RUF));
+ }
+
+ if (tb_io_st != NULL
+ && tb_io_st->n.sym
+ && tb_io_st->n.sym->generic)
+ {
+ gfc_interface *intr;
+ for (intr = tb_io_st->n.sym->generic; intr; intr = intr->next)
+ {
+ gfc_symbol *fsym = intr->sym->formal->sym;
+ if (intr->sym && intr->sym->formal
+ && ((fsym->ts.type == BT_CLASS
+ && CLASS_DATA (fsym)->ts.u.derived == extended)
+ || (fsym->ts.type == BT_DERIVED
+ && fsym->ts.u.derived == extended)))
+ dtio_sub = intr->sym;
+ }
+ }
+ }
+
+ finish:
+ if (dtio_sub && derived != CLASS_DATA (dtio_sub->formal->sym)->ts.u.derived)
+ gfc_find_derived_vtab (derived);
+
+ return dtio_sub;
+ }
Index: gcc/fortran/io.c
===================================================================
*** gcc/fortran/io.c (revision 239769)
--- gcc/fortran/io.c (working copy)
*************** enum format_token
*** 113,119 ****
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
};
/* Local variables for checking format strings. The saved_token is
--- 113,119 ----
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_DT
};
/* Local variables for checking format strings. The saved_token is
*************** format_lex (void)
*** 463,468 ****
--- 463,506 ----
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;
*************** format_item_1:
*** 652,657 ****
--- 690,743 ----
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:
Index: gcc/fortran/match.c
===================================================================
*** gcc/fortran/match.c (revision 239769)
--- gcc/fortran/match.c (working copy)
*************** gfc_op2string (gfc_intrinsic_op op)
*** 102,107 ****
--- 102,113 ----
case INTRINSIC_NONE:
return "none";
+ /* DTIO */
+ case INTRINSIC_FORMATTED:
+ return "formatted";
+ case INTRINSIC_UNFORMATTED:
+ return "unformatted";
+
default:
break;
}
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 239769)
--- gcc/fortran/resolve.c (working copy)
*************** derived_inaccessible (gfc_symbol *sym)
*** 6689,6694 ****
--- 6689,6698 ----
for (c = sym->components; c; c = c->next)
{
+ if (c->ts.type == BT_DERIVED && c->attr.pointer
+ && sym == c->ts.u.derived)
+ continue;
+
if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
return 1;
}
*************** static void
*** 8642,8650 ****
resolve_transfer (gfc_code *code)
{
gfc_typespec *ts;
! gfc_symbol *sym;
gfc_ref *ref;
gfc_expr *exp;
exp = code->expr1;
--- 8646,8658 ----
resolve_transfer (gfc_code *code)
{
gfc_typespec *ts;
! 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;
*************** resolve_transfer (gfc_code *code)
*** 8668,8674 ****
/* 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
&& !gfc_check_vardef_context (exp, false, false, false,
_("item in READ")))
return;
--- 8676,8682 ----
/* 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 (dt && dt->dt_io_kind->value.iokind == M_READ
&& !gfc_check_vardef_context (exp, false, false, false,
_("item in READ")))
return;
*************** resolve_transfer (gfc_code *code)
*** 8680,8688 ****
if (ref->type == REF_COMPONENT)
ts = &ref->u.c.component->ts;
! if (ts->type == BT_CLASS)
{
- /* 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);
--- 8688,8740 ----
if (ref->type == REF_COMPONENT)
ts = &ref->u.c.component->ts;
! 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)
{
gfc_error ("Data transfer element at %L cannot be polymorphic unless "
"it is processed by a defined input/output procedure",
&code->loc);
*************** resolve_transfer (gfc_code *code)
*** 8692,8699 ****
if (ts->type == BT_DERIVED)
{
/* Check that transferred derived type doesn't contain POINTER
! components. */
! if (ts->u.derived->attr.pointer_comp)
{
gfc_error ("Data transfer element at %L cannot have POINTER "
"components unless it is processed by a defined "
--- 8744,8752 ----
if (ts->type == BT_DERIVED)
{
/* Check that transferred derived type doesn't contain POINTER
! 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 "
*************** resolve_transfer (gfc_code *code)
*** 8709,8715 ****
return;
}
! if (ts->u.derived->attr.alloc_comp)
{
gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
"components unless it is processed by a defined "
--- 8762,8768 ----
return;
}
! 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 "
*************** resolve_transfer (gfc_code *code)
*** 8726,8735 ****
"cannot have PRIVATE components", &code->loc))
return;
}
! else if (derived_inaccessible (ts->u.derived))
{
gfc_error ("Data transfer element at %L cannot have "
! "PRIVATE components",&code->loc);
return;
}
}
--- 8779,8789 ----
"cannot have PRIVATE components", &code->loc))
return;
}
! else if (derived_inaccessible (ts->u.derived) && dtio_sub == NULL)
{
gfc_error ("Data transfer element at %L cannot have "
! "PRIVATE components unless it is processed by "
! "a defined input/output procedure", &code->loc);
return;
}
}
*************** resolve_bind_c_derived_types (gfc_symbol
*** 10901,10906 ****
--- 10955,10975 ----
}
+ /* 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. */
*************** resolve_fl_derived (gfc_symbol *sym)
*** 13421,13431 ****
--- 13490,13520 ----
}
+ /* 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)
{
*************** resolve_fl_namelist (gfc_symbol *sym)
*** 13459,13467 ****
sym->name, &sym->declared_at))
return false;
! /* FIXME: Once UDDTIO is implemented, the following can be
! removed. */
! if (nl->sym->ts.type == BT_CLASS)
{
gfc_error ("NAMELIST object %qs in namelist %qs at %L is "
"polymorphic and requires a defined input/output "
--- 13548,13556 ----
sym->name, &sym->declared_at))
return false;
! 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 "
*************** resolve_fl_namelist (gfc_symbol *sym)
*** 13479,13486 ****
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,
--- 13568,13575 ----
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,
*************** resolve_fl_namelist (gfc_symbol *sym)
*** 13488,13493 ****
--- 13577,13583 ----
return false;
}
}
+ }
/* Reject PRIVATE objects in a PUBLIC namelist. */
if (gfc_check_symbol_access (sym))
*************** resolve_fl_namelist (gfc_symbol *sym)
*** 13504,13509 ****
--- 13594,13604 ----
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))
*************** resolve_types (gfc_namespace *ns)
*** 15527,15532 ****
--- 15622,15629 ----
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);
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c (revision 239769)
--- gcc/fortran/symbol.c (working copy)
*************** const mstring save_status[] =
*** 87,92 ****
--- 87,101 ----
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. */
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 239769)
--- gcc/fortran/trans-decl.c (working copy)
*************** gfc_finish_var_decl (tree decl, gfc_symb
*** 638,643 ****
--- 638,653 ----
&& 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;
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 239769)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_get_vptr_from_expr (tree expr)
*** 430,438 ****
else
type = NULL_TREE;
}
! if (TREE_CODE (tmp) == VAR_DECL)
break;
}
return NULL_TREE;
}
--- 430,446 ----
else
type = NULL_TREE;
}
! 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;
}
*************** gfc_conv_derived_to_class (gfc_se *parms
*** 511,517 ****
if (optional)
cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
! if (parmse->ss && 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. */
--- 519,532 ----
if (optional)
cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
! 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. */
*************** gfc_conv_derived_to_class (gfc_se *parms
*** 522,528 ****
cond_optional, tmp,
fold_convert (TREE_TYPE (tmp), null_pointer_node));
gfc_add_modify (&parmse->pre, ctree, tmp);
-
}
else
{
--- 537,542 ----
Index: gcc/fortran/trans-io.c
===================================================================
*** gcc/fortran/trans-io.c (revision 239769)
--- gcc/fortran/trans-io.c (working copy)
*************** enum iocall
*** 132,137 ****
--- 132,138 ----
IOCALL_X_COMPLEX128_WRITE,
IOCALL_X_ARRAY,
IOCALL_X_ARRAY_WRITE,
+ IOCALL_X_DERIVED,
IOCALL_OPEN,
IOCALL_CLOSE,
IOCALL_INQUIRE,
*************** gfc_build_io_library_fndecls (void)
*** 397,402 ****
--- 398,407 ----
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 (
*************** gfc_build_io_library_fndecls (void)
*** 465,472 ****
iocall[IOCALL_SET_NML_VAL] = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("st_set_nml_var")), ".w.R",
! void_type_node, 6, dt_parm_type, pvoid_type_node, pvoid_type_node,
! gfc_int4_type_node, gfc_charlen_type_node, gfc_int4_type_node);
iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("st_set_nml_var_dim")), ".w",
--- 470,478 ----
iocall[IOCALL_SET_NML_VAL] = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("st_set_nml_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",
*************** gfc_build_io_library_fndecls (void)
*** 475,486 ****
}
! /* 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)
{
tree tmp;
gfc_st_parameter_field *p = &st_parameter_field[type];
--- 481,488 ----
}
! 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];
*************** set_parameter_const (stmtblock_t *block,
*** 491,497 ****
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));
return p->mask;
}
--- 493,513 ----
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, 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;
}
*************** set_parameter_ref (stmtblock_t *block, s
*** 697,709 ****
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);
return p->mask;
}
--- 713,719 ----
gfc_add_modify (postblock, se.expr, tmp);
}
! set_parameter_tree (block, var, type, addr);
return p->mask;
}
*************** transfer_namelist_element (stmtblock_t *
*** 1618,1623 ****
--- 1628,1635 ----
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;
*************** transfer_namelist_element (stmtblock_t *
*** 1659,1673 ****
dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
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);
gfc_add_expr_to_block (block, tmp);
/* If the object is an array, transfer rank times:
--- 1671,1707 ----
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], 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:
*************** transfer_namelist_element (stmtblock_t *
*** 1685,1691 ****
gfc_add_expr_to_block (block, tmp);
}
! if (gfc_bt_struct (ts->type) && ts->u.derived->components)
{
gfc_component *cmp;
--- 1719,1726 ----
gfc_add_expr_to_block (block, tmp);
}
! if (gfc_bt_struct (ts->type) && ts->u.derived->components
! && dtio_proc == null_pointer_node)
{
gfc_component *cmp;
*************** gfc_trans_dt_end (gfc_code * code)
*** 1995,2001 ****
}
static void
! transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code);
/* Given an array field in a derived type variable, generate the code
for the loop that iterates over array elements, and the code that
--- 2030,2037 ----
}
static void
! 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
*************** transfer_array_component (tree expr, gfc
*** 2061,2067 ****
/* 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);
/* We are done now with the loop body. Wrap up the scalarizer and
return. */
--- 2097,2103 ----
/* 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, NULL_TREE);
/* We are done now with the loop body. Wrap up the scalarizer and
return. */
*************** transfer_array_component (tree expr, gfc
*** 2081,2090 ****
return gfc_finish_block (&block);
}
/* Generate the call for a scalar transfer node. */
static void
! transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
{
tree tmp, function, arg2, arg3, field, expr;
gfc_component *c;
--- 2117,2169 ----
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, tree vptr)
{
tree tmp, function, arg2, arg3, field, expr;
gfc_component *c;
*************** transfer_expr (gfc_se * se, gfc_typespec
*** 2212,2220 ****
break;
case_bt_struct:
if (ts->u.derived->components == NULL)
return;
!
/* Recurse into the elements of the derived type. */
expr = gfc_evaluate_now (addr_expr, &se->pre);
expr = build_fold_indirect_ref_loc (input_location,
--- 2291,2335 ----
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;
!
! if (derived->attr.has_dtio_procs)
! arg2 = get_dtio_proc (ts, code, &dtio_sub);
!
! 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,
*************** transfer_expr (gfc_se * se, gfc_typespec
*** 2244,2254 ****
{
if (!c->attr.pointer)
tmp = gfc_build_addr_expr (NULL_TREE, tmp);
! transfer_expr (se, &c->ts, tmp, code);
}
}
return;
!
default:
gfc_internal_error ("Bad IO basetype (%d)", ts->type);
}
--- 2359,2371 ----
{
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. */
! }
default:
gfc_internal_error ("Bad IO basetype (%d)", ts->type);
}
*************** gfc_trans_transfer (gfc_code * code)
*** 2303,2308 ****
--- 2420,2426 ----
gfc_ss *ss;
gfc_se se;
tree tmp;
+ tree vptr;
int n;
gfc_start_block (&block);
*************** gfc_trans_transfer (gfc_code * code)
*** 2315,2322 ****
if (expr->rank == 0)
{
/* Transfer a scalar value. */
gfc_conv_expr_reference (&se, expr);
! transfer_expr (&se, &expr->ts, se.expr, code);
}
else
{
--- 2433,2450 ----
if (expr->rank == 0)
{
/* Transfer a scalar value. */
+ 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
{
*************** gfc_trans_transfer (gfc_code * code)
*** 2330,2336 ****
gcc_assert (ref && ref->type == REF_ARRAY);
}
! if (!gfc_bt_struct (expr->ts.type)
&& ref && ref->next == NULL
&& !is_subref_array (expr))
{
--- 2458,2465 ----
gcc_assert (ref && ref->type == REF_ARRAY);
}
! if (!(gfc_bt_struct (expr->ts.type)
! || expr->ts.type == BT_CLASS)
&& ref && ref->next == NULL
&& !is_subref_array (expr))
{
*************** gfc_trans_transfer (gfc_code * code)
*** 2378,2386 ****
gfc_copy_loopinfo_to_se (&se, &loop);
se.ss = ss;
-
gfc_conv_expr_reference (&se, expr);
! transfer_expr (&se, &expr->ts, se.expr, code);
}
finish_block_label:
--- 2507,2518 ----
gfc_copy_loopinfo_to_se (&se, &loop);
se.ss = ss;
gfc_conv_expr_reference (&se, expr);
! 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:
Index: gcc/testsuite/gfortran.dg/dtio_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/dtio_1.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/dtio_1.f90 (working copy)
***************
*** 0 ****
--- 1,164 ----
+ ! { dg-do run }
+ !
+ ! Functional test of User Defined Derived Type IO, Formatted WRITE/READ
+ !
+ ! 1) Tests passing of iostat out of the user procedure.
+ ! 2) Tests parsing of the DT optional string and passing in and using
+ ! to control execution.
+ ! 3) Tests parsing of the optional vlist, passing in and using it to
+ ! generate a user defined format string.
+ ! 4) Tests passing an iostat or iomsg out of libgfortranthe child procedure back to
+ ! the parent.
+ !
+ MODULE p
+ USE ISO_FORTRAN_ENV
+ TYPE :: person
+ CHARACTER (LEN=20) :: name
+ INTEGER(4) :: age
+ CONTAINS
+ procedure :: pwf
+ procedure :: prf
+ GENERIC :: WRITE(FORMATTED) => pwf
+ GENERIC :: READ(FORMATTED) => prf
+ END TYPE person
+ CONTAINS
+ SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg)
+ CLASS(person), INTENT(IN) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ CHARACTER (LEN=*), INTENT(IN) :: iotype
+ INTEGER, INTENT(IN) :: vlist(:)
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ CHARACTER (LEN=30) :: udfmt
+ INTEGER :: myios
+
+ udfmt='(*(g0))'
+ iomsg = "SUCCESS"
+ iostat=0
+ if (iotype.eq."DT") then
+ if (size(vlist).ne.0) print *, 36
+ WRITE(unit, FMT = '(a,5x,i2)', IOSTAT=iostat, advance='no') trim(dtv%name), dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF DT"
+ endif
+ if (iotype.eq."DTzeroth") then
+ if (size(vlist).ne.0) print *, 40
+ WRITE(unit, FMT = '(g0,g0)', advance='no') dtv%name, dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF DTzeroth"
+ endif
+ if (iotype.eq."DTtwo") then
+ if (size(vlist).ne.2) call abort
+ WRITE(udfmt,'(A,A,I1,A,I1,A)') '(', 'A', vlist(1),',I', vlist(2), ')'
+ WRITE(unit, FMT='(A8,I2)') dtv%name, dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF DTtwo"
+ endif
+ if (iotype.eq."DTthree") then
+ WRITE(udfmt,'(2A,I2,A,I1,A,I2,A)',iostat=myios) '(', 'A', vlist(1),',I', vlist(2), ',F', vlist(3), '.2)'
+ WRITE(unit, FMT=udfmt, IOSTAT=iostat, advance='no') trim(dtv%name), dtv%age, 3.14
+ if (iostat.ne.0) iomsg = "Fail PWF DTthree"
+ endif
+ if (iotype.eq."LISTDIRECTED") then
+ if (size(vlist).ne.0) print *, 55
+ WRITE(unit, FMT = *) dtv%name, dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF LISTDIRECTED"
+ endif
+ if (iotype.eq."NAMELIST") then
+ if (size(vlist).ne.0) print *, 59
+ iostat=6000
+ endif
+ END SUBROUTINE pwf
+
+ SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg)
+ CLASS(person), INTENT(INOUT) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ CHARACTER (LEN=*), INTENT(IN) :: iotype
+ INTEGER, INTENT(IN) :: vlist(:)
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ CHARACTER (LEN=30) :: udfmt
+ INTEGER :: myios
+ real :: areal
+ udfmt='(*(g0))'
+ iomsg = "SUCCESS"
+ iostat=0
+ if (iotype.eq."DT") then
+ if (size(vlist).ne.0) print *, 36
+ READ(unit, FMT = '(a,5x,i2)', IOSTAT=iostat, advance='no') dtv%name, dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF DT"
+ endif
+ if (iotype.eq."DTzeroth") then
+ if (size(vlist).ne.0) print *, 40
+ READ(unit, FMT = '(a,I2)', advance='no') dtv%name, dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF DTzeroth"
+ endif
+ if (iotype.eq."DTtwo") then
+ if (size(vlist).ne.2) call abort
+ WRITE(udfmt,'(A,A,I1,A,I1,A)') '(', 'A', vlist(1),',I', vlist(2), ')'
+ READ(unit, FMT='(A8,I2)') dtv%name, dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF DTtwo"
+ endif
+ if (iotype.eq."DTthree") then
+ WRITE(udfmt,'(2A,I2,A,I1,A,I2,A)',iostat=myios) '(', 'A', vlist(1),',I', vlist(2), ',F', vlist(3), '.2)'
+ READ(unit, FMT=udfmt, IOSTAT=iostat, advance='no') dtv%name, dtv%age, areal
+ if (iostat.ne.0) iomsg = "Fail PWF DTthree"
+ endif
+ if (iotype.eq."LISTDIRECTED") then
+ if (size(vlist).ne.0) print *, 55
+ READ(unit, FMT = *) dtv%name, dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF LISTDIRECTED"
+ endif
+ if (iotype.eq."NAMELIST") then
+ if (size(vlist).ne.0) print *, 59
+ iostat=6000
+ endif
+ !READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age
+ END SUBROUTINE prf
+
+ END MODULE p
+
+ PROGRAM test
+ USE p
+ TYPE (person), SAVE :: chairman
+ TYPE (person), SAVE :: member
+ character(80) :: astring
+ integer :: thelength
+
+ chairman%name="Charlie"
+ chairman%age=62
+ member%name="George"
+ member%age=42
+ astring = "FAILURE"
+ write (10, "(DT'zeroth',3x, DT'three'(11,4,10),11x,DT'two'(8,2))", &
+ & iostat=myiostat, iomsg=astring) member, chairman, member
+ if (myiostat.ne.0) call abort
+ if (astring.ne."SUCCESS") call abort
+ astring = "FAILURE"
+ write (10, *, iostat=myiostat, iomsg=astring) member, chairman, member
+ if (myiostat.ne.0) call abort
+ if (astring.ne."SUCCESS") call abort
+ write(10,*) ! See note below
+ rewind(10)
+ chairman%name="bogus1"
+ chairman%age=99
+ member%name="bogus2"
+ member%age=66
+ astring = "FAILURE"
+ read(10,"(DT'zeroth',3x, DT'three'(11,4,10),11x,DT'two'(8,2))") member, chairman, member
+ if (member%name.ne."George") call abort
+ if (chairman%name.ne." Charlie") call abort
+ if (member%age.ne.42) call abort
+ if (chairman%age.ne.62) call abort
+ chairman%name="bogus1"
+ chairman%age=99
+ member%name="bogus2"
+ member%age=66
+ astring = "FAILURE"
+ read (10, *, iostat=myiostat, iomsg=astring) member, chairman, member
+ ! The user defined procedure reads to the end of the line/file, then finalizing the parent
+ ! reads past, so we wrote a blank line above. User needs to address these nuances in their
+ ! procedures. (subject to interpretation)
+ if (astring.ne."SUCCESS") 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
Index: gcc/testsuite/gfortran.dg/dtio_10.f90
===================================================================
*** gcc/testsuite/gfortran.dg/dtio_10.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/dtio_10.f90 (working copy)
***************
*** 0 ****
--- 1,27 ----
+ ! { dg-do run }
+ !
+ ! Tests runtime check of the required type in dtio formatted read.
+ !
+ module usertypes
+ type udt
+ integer :: myarray(15)
+ end type udt
+ type, extends(udt) :: more
+ integer :: itest = -25
+ end type
+
+ end module usertypes
+
+ program test1
+ use usertypes
+ type (udt) :: udt1
+ type (more) :: more1
+ class (more), allocatable :: somemore
+ integer :: thesize, i, ios
+ character(100) :: errormsg
+
+ read (10, fmt='(dt)', advance='no', size=thesize, iostat=ios, &
+ & iomsg=errormsg) i, udt1
+ if (ios.ne.5006) call abort
+ if (errormsg(1:25).ne."Expected CLASS or DERIVED") call abort
+ end program test1
Index: gcc/testsuite/gfortran.dg/dtio_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/dtio_2.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/dtio_2.f90 (working copy)
***************
*** 0 ****
--- 1,71 ----
+ ! { dg-do run }
+ !
+ ! Functional test of User Defined DT IO, unformatted WRITE/READ
+ !
+ ! 1) Tests unformatted DTV write with other variables in the record
+ ! 2) Tests reading back the recods written.
+ !
+ module p
+ type :: person
+ character (len=20) :: name
+ integer(4) :: age
+ contains
+ procedure :: pwuf
+ procedure :: pruf
+ generic :: write(unformatted) => pwuf
+ generic :: read(unformatted) => pruf
+ end type person
+ contains
+ subroutine pwuf (dtv,unit,iostat,iomsg)
+ class(person), intent(in) :: dtv
+ integer, intent(in) :: unit
+ integer, intent(out) :: iostat
+ character (len=*), intent(inout) :: iomsg
+ write (unit=unit, iostat=iostat, iomsg=iomsg) dtv%name, dtv%age
+ end subroutine pwuf
+
+ subroutine pruf (dtv,unit,iostat,iomsg)
+ class(person), intent(inout) :: dtv
+ integer, intent(in) :: unit
+ integer, intent(out) :: iostat
+ character (len=*), intent(inout) :: iomsg
+ read (unit = unit) dtv%name, dtv%age
+ end subroutine pruf
+
+ end module p
+
+ program test
+ use p
+ type (person), save :: chairman
+ character(3) :: tmpstr1, tmpstr2
+ chairman%name="charlie"
+ chairman%age=62
+
+ open (unit=71, file='myunformatted_data.dat', form='unformatted')
+ write (71) "abc", chairman, "efg"
+ write (71) "hij", chairman, "klm"
+ write (71) "nop", chairman, "qrs"
+ rewind (unit = 71)
+ chairman%name="boggle"
+ chairman%age=1234
+ read (71) tmpstr1, chairman, tmpstr2
+ if (tmpstr1.ne."abc") call abort
+ if (tmpstr2.ne."efg") call abort
+ if (chairman%name.ne."charlie") call abort
+ if (chairman%age.ne.62) call abort
+ chairman%name="boggle"
+ chairman%age=1234
+ read (71) tmpstr1, chairman, tmpstr2
+ if (tmpstr1.ne."hij") call abort
+ if (tmpstr2.ne."klm") call abort
+ if (chairman%name.ne."charlie") call abort
+ if (chairman%age.ne.62) call abort
+ chairman%name="boggle"
+ chairman%age=1234
+ read (71) tmpstr1, chairman, tmpstr2
+ if (tmpstr1.ne."nop") call abort
+ if (tmpstr2.ne."qrs") call abort
+ if (chairman%name.ne."charlie") call abort
+ if (chairman%age.ne.62) call abort
+ close (unit = 71, status='delete')
+ end program test
Index: gcc/testsuite/gfortran.dg/dtio_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/dtio_3.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/dtio_3.f90 (working copy)
***************
*** 0 ****
--- 1,172 ----
+ ! { dg-do run }
+ !
+ ! Functional test of User Defined Derived Type IO.
+ !
+ ! This tests recursive calls where a derived type has a member that is
+ ! itself.
+ !
+ MODULE p
+ USE ISO_FORTRAN_ENV
+ TYPE :: person
+ CHARACTER (LEN=20) :: name
+ INTEGER(4) :: age
+ type(person), pointer :: next => NULL()
+ CONTAINS
+ procedure :: pwf
+ procedure :: prf
+ GENERIC :: WRITE(FORMATTED) => pwf
+ GENERIC :: READ(FORMATTED) => prf
+ END TYPE person
+ CONTAINS
+ RECURSIVE 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
+ if (associated(dtv%next)) then
+ WRITE(unit, FMT = '(a20,i2, DT)', IOSTAT=iostat, advance='no') dtv%name, dtv%age, dtv%next
+ else
+ WRITE(unit, FMT = '(a20,i2)', IOSTAT=iostat, advance='no') dtv%name, dtv%age
+ endif
+ 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
+ if (associated(dtv%next)) then
+ WRITE(unit, FMT = *) dtv%name, dtv%age, dtv%next
+ else
+ WRITE(unit, FMT = *) dtv%name, dtv%age
+ endif
+ if (iostat.ne.0) iomsg = "Fail PWF LISTDIRECTED"
+ endif
+ if (iotype.eq."NAMELIST") then
+ if (size(vlist).ne.0) print *, 59
+ iostat=6000
+ endif
+ if (associated (dtv%next) .and. (iotype.eq."LISTDIRECTED")) write(unit, fmt = *) dtv%next
+ END SUBROUTINE pwf
+
+ RECURSIVE 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
+ if (associated(dtv%next)) then
+ READ(unit, FMT = '(a20,i2, DT)', IOSTAT=iostat, advance='no') dtv%name, dtv%age, dtv%next
+ else
+ READ(unit, FMT = '(a20,i2)', IOSTAT=iostat, advance='no') dtv%name, dtv%age
+ endif
+ 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) :: chairman
+ TYPE (person), target :: member
+ character(80) :: astring
+ integer :: thelength
+
+ chairman%name="Charlie"
+ chairman%age=62
+ member%name="George"
+ member%age=42
+ astring = "FAILURE"
+ ! At this point, next is NULL as defined up in the type block.
+ open(10, status = "scratch")
+ write (10, *, iostat=myiostat, iomsg=astring) member, chairman
+ write(10,*)
+ rewind(10)
+ chairman%name="bogus1"
+ chairman%age=99
+ member%name="bogus2"
+ member%age=66
+ read (10, *, iostat=myiostat, iomsg=astring) member, chairman
+ if (astring.ne."SUCCESS") print *, astring
+ if (member%name.ne."George") call abort
+ if (chairman%name.ne."Charlie") call abort
+ if (member%age.ne.42) call abort
+ if (chairman%age.ne.62) call abort
+ close(10, status='delete')
+ ! Now we set next to point to member. This changes the code path
+ ! in the pwf and prf procedures.
+ chairman%next => member
+ open(10, status = "scratch")
+ write (10,"(DT)") chairman
+ rewind(10)
+ chairman%name="bogus1"
+ chairman%age=99
+ member%name="bogus2"
+ member%age=66
+ read (10,"(DT)", iomsg=astring) chairman
+ !print *, trim(astring)
+ if (member%name.ne."George") call abort
+ if (chairman%name.ne."Charlie") call abort
+ if (member%age.ne.42) call abort
+ if (chairman%age.ne.62) call abort
+ close(10)
+ END PROGRAM test
Index: gcc/testsuite/gfortran.dg/dtio_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/dtio_4.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/dtio_4.f90 (working copy)
***************
*** 0 ****
--- 1,107 ----
+ ! { dg-do run }
+ !
+ ! Functional test of User Defined Derived Type IO.
+ !
+ ! This tests a combination of module procedure and generic procedure
+ ! and performs reading and writing an array with a pseudo user defined
+ ! tag at the beginning of the file.
+ !
+ module usertypes
+ type udt
+ integer :: myarray(15)
+ contains
+ procedure :: user_defined_read
+ generic :: read (formatted) => user_defined_read
+ end type udt
+ type, extends(udt) :: more
+ integer :: someinteger = -25
+ end type
+
+ interface write(formatted)
+ module procedure user_defined_write
+ end interface
+
+ integer :: result_array(15)
+ contains
+ subroutine user_defined_read (dtv, unit, iotype, v_list, iostat, iomsg)
+ class(udt), intent(inout) :: dtv
+ integer, intent(in) :: unit
+ character(*), intent(in) :: iotype
+ integer, intent(in) :: v_list (:)
+ integer, intent(out) :: iostat
+ character(*), intent(inout) :: iomsg
+ character(10) :: typestring
+
+ iomsg = 'SUCCESS'
+ read (unit, '(a6)', iostat=iostat, iomsg=iomsg) typestring
+ typestring = trim(typestring)
+ select type (dtv)
+ type is (udt)
+ if (typestring.eq.' UDT: ') then
+ read (unit, fmt=*, iostat=iostat, iomsg=iomsg) dtv%myarray
+ else
+ iostat = 6000
+ iomsg = 'FAILURE'
+ end if
+ type is (more)
+ if (typestring.eq.' MORE: ') then
+ read (unit, fmt=*, iostat=iostat, iomsg=iomsg) dtv%myarray
+ else
+ iostat = 6000
+ iomsg = 'FAILUREwhat'
+ end if
+ end select
+ end subroutine user_defined_read
+
+ subroutine user_defined_write (dtv, unit, iotype, v_list, iostat, iomsg)
+ class(udt), intent(in) :: dtv
+ integer, intent(in) :: unit
+ character(*), intent(in) :: iotype
+ integer, intent(in) :: v_list (:)
+ integer, intent(out) :: iostat
+ character(*), intent(inout) :: iomsg
+ character(10) :: typestring
+ select type (dtv)
+ type is (udt)
+ write (unit, fmt=*, iostat=iostat, iomsg=iomsg) "UDT: "
+ write (unit, fmt=*, iostat=iostat, iomsg=iomsg) dtv%myarray
+ type is (more)
+ write (unit, fmt=*, iostat=iostat, iomsg=iomsg) "MORE: "
+ write (unit, fmt=*, iostat=iostat, iomsg=iomsg) dtv%myarray
+ end select
+ write (unit,*)
+ end subroutine user_defined_write
+ end module usertypes
+
+ program test1
+ use usertypes
+ type (udt) :: udt1
+ type (more) :: more1
+ class (more), allocatable :: somemore
+ integer :: thesize, i, ios
+ character(25):: iomsg
+
+ ! Create a file that contains some data for testing.
+ open (10, form='formatted', status='scratch')
+ write(10, '(a)') ' UDT: '
+ do i = 1, 15
+ write(10,'(i5)', advance='no') i
+ end do
+ write(10,*)
+ rewind(10)
+ udt1%myarray = 99
+ result_array = (/ (i, i = 1, 15) /)
+ more1%myarray = result_array
+ read (10, fmt='(dt)', advance='no', iomsg=iomsg) udt1
+ if (iomsg.ne.'SUCCESS') call abort
+ if (any(udt1%myarray.ne.result_array)) call abort
+ close(10)
+ open (10, form='formatted')
+ write (10, '(dt)') more1
+ rewind(10)
+ more1%myarray = 99
+ read (10, '(dt)', iostat=ios, iomsg=iomsg) more1
+ if (iomsg.ne.'SUCCESS') call abort
+ if (any(more1%myarray.ne.result_array)) call abort
+ close (10)
+ end program test1
Index: gcc/testsuite/gfortran.dg/dtio_5.f90
===================================================================
*** gcc/testsuite/gfortran.dg/dtio_5.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/dtio_5.f90 (working copy)
***************
*** 0 ****
--- 1,278 ----
+ ! { dg-do run }
+ !
+ ! This test is based on the second case in the PGInsider article at
+ ! https://www.pgroup.com/lit/articles/insider/v6n2a3.htm
+ !
+ ! The complete original code is at:
+ ! https://www.pgroup.com/lit/samples/pginsider/stack.f90
+ !
+ ! Thanks to Mark LeAir.
+ !
+ ! Copyright (c) 2015, NVIDIA CORPORATION. All rights reserved.
+ !
+ ! NVIDIA CORPORATION and its licensors retain all intellectual property
+ ! and proprietary rights in and to this software, related documentation
+ ! and any modifications thereto. Any use, reproduction, disclosure or
+ ! distribution of this software and related documentation without an express
+ ! license agreement from NVIDIA CORPORATION is strictly prohibited.
+ !
+
+ ! THIS CODE AND INFORMATION ARE PROVIDED "AS IS" WITHOUT
+ ! WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING BUT
+ ! NOT LIMITED TO THE IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR
+ ! FITNESS FOR A PARTICULAR PURPOSE.
+ !
+
+ module stack_mod
+
+ type, abstract :: stack
+ private
+ class(*), allocatable :: item ! an item on the stack
+ class(stack), pointer :: next=>null() ! next item on the stack
+ contains
+ procedure :: empty ! returns true if stack is empty
+ procedure :: delete ! empties the stack
+ end type stack
+
+ type, extends(stack) :: integer_stack
+ contains
+ procedure :: push => push_integer ! add integer item to stack
+ procedure :: pop => pop_integer ! remove integer item from stack
+ procedure :: compare => compare_integer ! compare with an integer array
+ end type integer_stack
+
+ type, extends(integer_stack) :: io_stack
+ contains
+ procedure,private :: wio_stack
+ procedure,private :: rio_stack
+ procedure,private :: dump_stack
+ generic :: write(unformatted) => wio_stack ! write stack item to file
+ generic :: read(unformatted) => rio_stack ! push item from file
+ generic :: write(formatted) => dump_stack ! print all items from stack
+ end type io_stack
+
+ contains
+
+ subroutine rio_stack (dtv, unit, iostat, iomsg)
+
+ ! read item from file and add it to stack
+
+ class(io_stack), intent(inout) :: dtv
+ integer, intent(in) :: unit
+ integer, intent(out) :: iostat
+ character(len=*), intent(inout) :: iomsg
+
+ integer :: item
+
+ read(unit,IOSTAT=iostat,IOMSG=iomsg) item
+
+ if (iostat .ne. 0) then
+ call dtv%push(item)
+ endif
+
+ end subroutine rio_stack
+
+ subroutine wio_stack(dtv, unit, iostat, iomsg)
+
+ ! pop an item from stack and write it to file
+
+ class(io_stack), intent(in) :: dtv
+ integer, intent(in) :: unit
+ integer, intent(out) :: iostat
+ character(len=*), intent(inout) :: iomsg
+ integer :: item
+
+ item = dtv%pop()
+ write(unit,IOSTAT=iostat,IOMSG=iomsg) item
+
+ end subroutine wio_stack
+
+ subroutine dump_stack(dtv, unit, iotype, v_list, iostat, iomsg)
+
+ ! Pop all items off stack and write them out to unit
+ ! Assumes default LISTDIRECTED output
+
+ class(io_stack), intent(in) :: dtv
+ integer, intent(in) :: unit
+ character(len=*), intent(in) :: iotype
+ integer, intent(in) :: v_list(:)
+ integer, intent(out) :: iostat
+ character(len=*), intent(inout) :: iomsg
+ character(len=80) :: buffer
+ integer :: item
+
+ if (iotype .ne. 'LISTDIRECTED') then
+ ! Error
+ iomsg = 'dump_stack: unsupported iotype'
+ iostat = 1
+ else
+ iostat = 0
+ do while( (.not. dtv%empty()) .and. (iostat .eq. 0) )
+ item = dtv%pop()
+ write(unit, '(I6/)',IOSTAT=iostat,IOMSG=iomsg) item
+ enddo
+ endif
+ end subroutine dump_stack
+
+ logical function empty(this)
+ class(stack) :: this
+ if (.not.associated(this%next)) then
+ empty = .true.
+ else
+ empty = .false.
+ end if
+ end function empty
+
+ subroutine push_integer(this,item)
+ class(integer_stack) :: this
+ integer :: item
+ type(integer_stack), allocatable :: new_item
+
+ allocate(new_item)
+ allocate(new_item%item, source=item)
+ new_item%next => this%next
+ allocate(this%next, source=new_item)
+ end subroutine push_integer
+
+ function pop_integer(this) result(item)
+ class(integer_stack) :: this
+ integer item
+
+ if (this%empty()) then
+ stop 'Error! pop_integer invoked on empty stack'
+ endif
+ select type(top=>this%next)
+ type is (integer_stack)
+ select type(i => top%item)
+ type is(integer)
+ item = i
+ class default
+ stop 'Error #1! pop_integer encountered non-integer stack item'
+ end select
+ this%next => top%next
+ deallocate(top)
+ class default
+ stop 'Error #2! pop_integer encountered non-integer_stack item'
+ end select
+ end function pop_integer
+
+ ! gfortran addition to check read/write
+ logical function compare_integer (this, array, error)
+ class(integer_stack), target :: this
+ class(stack), pointer :: ptr, next
+ integer :: array(:), i, j, error
+ compare_integer = .true.
+ ptr => this
+ do j = 0, size (array, 1)
+ if (compare_integer .eqv. .false.) return
+ select type (ptr)
+ type is (integer_stack)
+ select type(k => ptr%item)
+ type is(integer)
+ if (k .ne. array(j)) error = 1
+ class default
+ error = 2
+ compare_integer = .false.
+ end select
+ class default
+ if (j .ne. 0) then
+ error = 3
+ compare_integer = .false.
+ end if
+ end select
+ next => ptr%next
+ if (associated (next)) then
+ ptr => next
+ else if (j .ne. size (array, 1)) then
+ error = 4
+ compare_integer = .false.
+ end if
+ end do
+ end function
+
+ subroutine delete (this)
+ class(stack), target :: this
+ class(stack), pointer :: ptr1, ptr2
+ ptr1 => this%next
+ ptr2 => ptr1%next
+ do while (associated (ptr1))
+ deallocate (ptr1)
+ ptr1 => ptr2
+ if (associated (ptr1)) ptr2 => ptr1%next
+ end do
+ end subroutine
+
+ end module stack_mod
+
+ program stack_demo
+
+ use stack_mod
+ implicit none
+
+ integer i, k(10), error
+ class(io_stack), allocatable :: stk
+ allocate(stk)
+
+ k = [3,1,7,0,2,9,4,8,5,6]
+
+ ! step 1: set up an 'output' file > changed to 'scratch'
+
+ open(10, status='scratch', form='unformatted')
+
+ ! step 2: add values to stack
+
+ do i=1,10
+ ! write(*,*) 'Adding ',i,' to the stack'
+ call stk%push(k(i))
+ enddo
+
+ ! step 3: pop values from stack and write them to file
+
+ ! write(*,*)
+ ! write(*,*) 'Removing each item from stack and writing it to file.'
+ ! write(*,*)
+ do while(.not.stk%empty())
+ write(10) stk
+ enddo
+
+ ! step 4: close file and reopen it for read > changed to rewind.
+
+ rewind(10)
+
+ ! step 5: read values back into stack
+ ! write(*,*) 'Reading each value from file and adding it to stack:'
+ do while(.true.)
+ read(10,END=9999) i
+ ! write(*,*), 'Reading ',i,' from file. Adding it to stack'
+ call stk%push(i)
+ enddo
+
+ 9999 continue
+
+ ! step 6: Dump stack to standard out
+
+ ! write(*,*)
+ ! write(*,*), 'Removing every element from stack and writing it to screen:'
+ ! write(*,*) stk
+
+ ! gfortran addition to check read/write
+ if (.not. stk%compare (k, error)) then
+ select case (error)
+ case(1)
+ print *, "values do not match"
+ case(2)
+ print *, "non integer found in stack"
+ case(3)
+ print *, "type mismatch in stack"
+ case(4)
+ print *, "too few values in stack"
+ end select
+ call abort
+ end if
+
+ close(10)
+
+ ! Clean up - valgrind indicates no leaks.
+ call stk%delete
+ deallocate (stk)
+ end program stack_demo
Index: gcc/testsuite/gfortran.dg/dtio_6.f90
===================================================================
*** gcc/testsuite/gfortran.dg/dtio_6.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/dtio_6.f90 (working copy)
***************
*** 0 ****
--- 1,98 ----
+ ! { dg-do compile }
+ !
+ ! Tests the checks for interface compliance.
+ !
+ !
+ MODULE p
+ USE ISO_C_BINDING
+
+ TYPE :: person
+ CHARACTER (LEN=20) :: name
+ INTEGER(4) :: age
+ CONTAINS
+ procedure :: pwf ! { dg-error "Non-polymorphic passed-object" }
+ procedure :: pwuf
+ GENERIC :: WRITE(FORMATTED) => pwf
+ GENERIC :: WRITE(UNFORMATTED) => pwuf
+ END TYPE person
+ INTERFACE READ(FORMATTED)
+ MODULE PROCEDURE prf
+ END INTERFACE
+ INTERFACE READ(UNFORMATTED)
+ MODULE PROCEDURE pruf
+ END INTERFACE
+
+ TYPE :: seq_type
+ sequence
+ INTEGER(4) :: i
+ END TYPE seq_type
+ INTERFACE WRITE(FORMATTED)
+ MODULE PROCEDURE pwf_seq
+ END INTERFACE
+
+ TYPE, BIND(C) :: bindc_type
+ INTEGER(C_INT) :: i
+ END TYPE bindc_type
+
+ INTERFACE WRITE(FORMATTED)
+ MODULE PROCEDURE pwf_bindc
+ END INTERFACE
+
+ CONTAINS
+ SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg) ! { dg-error "must be of type CLASS" }
+ type(person), INTENT(IN) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ CHARACTER (LEN=*), INTENT(IN) :: iotype
+ INTEGER, INTENT(IN) :: vlist(:)
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ WRITE(unit, FMT = *, IOSTAT=iostat) dtv%name, dtv%age
+ END SUBROUTINE pwf
+
+ SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg) ! { dg-error "must be an ASSUMED SHAPE ARRAY" }
+ CLASS(person), INTENT(INOUT) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ CHARACTER (LEN=*), INTENT(IN) :: iotype
+ INTEGER, INTENT(IN) :: vlist
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age
+ END SUBROUTINE prf
+
+ SUBROUTINE pwuf (dtv,unit,iostat,iomsg) ! { dg-error "must have intent IN" }
+ CLASS(person), INTENT(INOUT) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ WRITE (UNIT=UNIT, FMT = *) DTV%name, DTV%age
+ END SUBROUTINE pwuf
+
+ SUBROUTINE pruf (dtv,unit,iostat,iomsg) ! { dg-error "must be of KIND = 4" }
+ CLASS(person), INTENT(INOUT) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ INTEGER(8), INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age
+ END SUBROUTINE pruf
+
+ SUBROUTINE pwf_seq (dtv,unit,iotype,vlist,iostat,iomsg) ! { dg-error "not extensible|DERIVED" }
+ class(seq_type), INTENT(IN) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ CHARACTER (LEN=*), INTENT(IN) :: iotype
+ INTEGER, INTENT(IN) :: vlist(:)
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ WRITE(unit, FMT = *, IOSTAT=iostat) dtv%i
+ END SUBROUTINE pwf_seq
+
+ SUBROUTINE pwf_bindc (dtv,unit,iotype,vlist,iostat,iomsg) ! { dg-error "not extensible|DERIVED" }
+ class(bindc_type), INTENT(IN) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ CHARACTER (LEN=*), INTENT(IN) :: iotype
+ INTEGER, INTENT(IN) :: vlist(:)
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ WRITE(unit, FMT = *, IOSTAT=iostat) dtv%i
+ END SUBROUTINE pwf_bindc
+
+ END MODULE p
Index: gcc/testsuite/gfortran.dg/dtio_7.f90
===================================================================
*** gcc/testsuite/gfortran.dg/dtio_7.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/dtio_7.f90 (working copy)
***************
*** 0 ****
--- 1,139 ----
+ ! { dg-do run }
+ !
+ ! Tests dtio transfer of arrays of derived types and classes
+ !
+ MODULE p
+ TYPE :: person
+ CHARACTER (LEN=20) :: name
+ INTEGER(4) :: age
+ CONTAINS
+ procedure :: pwf
+ procedure :: prf
+ GENERIC :: WRITE(FORMATTED) => pwf
+ GENERIC :: READ(FORMATTED) => prf
+ END TYPE person
+ type, extends(person) :: employee
+ character(20) :: job_title
+ end type
+ type, extends(person) :: officer
+ character(20) :: position
+ end type
+ type, extends(person) :: member
+ integer :: membership_number
+ end type
+ type :: club
+ type(employee), allocatable :: staff(:)
+ class(person), allocatable :: committee(:)
+ class(person), allocatable :: membership(:)
+ end type
+ CONTAINS
+ SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg)
+ CLASS(person), INTENT(IN) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ CHARACTER (LEN=*), INTENT(IN) :: iotype
+ INTEGER, INTENT(IN) :: vlist(:)
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ select type (dtv)
+ type is (employee)
+ WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Employee"
+ WRITE(unit, FMT = "(A20,I4,A20/)", IOSTAT=iostat) dtv%name, dtv%age, dtv%job_title
+ type is (officer)
+ WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Officer"
+ WRITE(unit, FMT = "(A20,I4,A20/)", IOSTAT=iostat) dtv%name, dtv%age, dtv%position
+ type is (member)
+ WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Member"
+ WRITE(unit, FMT = "(A20,I4,I4/)", IOSTAT=iostat) dtv%name, dtv%age, dtv%membership_number
+ class default
+ WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Ugggh!"
+ WRITE(unit, FMT = "(A20,I4,' '/)", IOSTAT=iostat) dtv%name, dtv%age
+ end select
+ END SUBROUTINE pwf
+
+ SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg)
+ CLASS(person), INTENT(INOUT) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ CHARACTER (LEN=*), INTENT(IN) :: iotype
+ INTEGER, INTENT(IN) :: vlist(:)
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ character (20) :: header, rname, jtitle, oposition
+ integer :: i
+ integer :: no
+ integer :: age
+ iostat = 0
+ select type (dtv)
+
+ type is (employee)
+ read (unit = unit, fmt = *) header
+ READ (UNIT = UNIT, FMT = "(A20,I4,A20)") rname, age, jtitle
+ if (trim (rname) .ne. dtv%name) iostat = 1
+ if (age .ne. dtv%age) iostat = 2
+ if (trim (jtitle) .ne. dtv%job_title) iostat = 3
+ if (iotype .ne. "DTstaff") iostat = 4
+
+ type is (officer)
+ read (unit = unit, fmt = *) header
+ READ (UNIT = UNIT, FMT = "(A20,I4,A20)") rname, age, oposition
+ if (trim (rname) .ne. dtv%name) iostat = 1
+ if (age .ne. dtv%age) iostat = 2
+ if (trim (oposition) .ne. dtv%position) iostat = 3
+ if (iotype .ne. "DTofficers") iostat = 4
+
+ type is (member)
+ read (unit = unit, fmt = *) header
+ READ (UNIT = UNIT, FMT = "(A20,I4,I4)") rname, age, no
+ if (trim (rname) .ne. dtv%name) iostat = 1
+ if (age .ne. dtv%age) iostat = 2
+ if (no .ne. dtv%membership_number) iostat = 3
+ if (iotype .ne. "DTmembers") iostat = 4
+
+ class default
+ call abort
+ end select
+ end subroutine
+ END MODULE p
+
+ PROGRAM test
+ USE p
+
+ type (club) :: social_club
+ TYPE (person) :: chairman
+ CLASS (person), allocatable :: president(:)
+ character (40) :: line
+ integer :: i, j
+
+ allocate (social_club%staff, source = [employee ("Bert",25,"Barman"), &
+ employee ("Joy",16,"Auditor")])
+
+ allocate (social_club%committee, source = [officer ("Hank",32, "Chair"), &
+ officer ("Ann", 29, "Secretary")])
+
+ allocate (social_club%membership, source = [member ("Dan",52,1), &
+ member ("Sue",39,2)])
+
+ chairman%name="Charlie"
+ chairman%age=62
+
+ open (7, status = "scratch")
+ write (7,*) social_club%staff ! Tests array of derived types
+ write (7,*) social_club%committee ! Tests class array
+ do i = 1, size (social_club%membership, 1)
+ write (7,*) social_club%membership(i) ! Tests class array elements
+ end do
+
+ rewind (7)
+ read (7, "(DT'staff')", iostat = i) social_club%staff
+ if (i .ne. 0) call abort
+
+ social_club%committee(2)%age = 33 ! Introduce an error
+
+ read (7, "(DT'officers')", iostat = i) social_club%committee
+ if (i .ne. 2) call abort ! Pick up error
+
+ do j = 1, size (social_club%membership, 1)
+ read (7, "(DT'members')", iostat = i) social_club%membership(j)
+ if (i .ne. 0) call abort
+ end do
+ close (7)
+ END PROGRAM test
Index: gcc/testsuite/gfortran.dg/dtio_8.f90
===================================================================
*** gcc/testsuite/gfortran.dg/dtio_8.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/dtio_8.f90 (working copy)
***************
*** 0 ****
--- 1,65 ----
+ ! { dg-do run }
+ !
+ ! Tests dtio transfer sequence types.
+ !
+ ! Note difficulty at end with comparisons at any level of optimization.
+ !
+ MODULE p
+ TYPE :: person
+ sequence
+ CHARACTER (LEN=20) :: name
+ INTEGER(4) :: age
+ END TYPE person
+ INTERFACE WRITE(UNFORMATTED)
+ MODULE PROCEDURE pwuf
+ END INTERFACE
+ INTERFACE READ(UNFORMATTED)
+ MODULE PROCEDURE pruf
+ END INTERFACE
+
+ CONTAINS
+
+ SUBROUTINE pwuf (dtv,unit,iostat,iomsg)
+ type(person), INTENT(IN) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ WRITE (UNIT=UNIT) DTV%name, DTV%age
+ END SUBROUTINE pwuf
+
+ SUBROUTINE pruf (dtv,unit,iostat,iomsg)
+ type(person), INTENT(INOUT) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ READ (UNIT = UNIT) dtv%name, dtv%age
+ END SUBROUTINE pruf
+
+ END MODULE p
+
+ PROGRAM test
+ USE p
+ TYPE (person) :: chairman
+ character(10) :: line
+
+ chairman%name="Charlie"
+ chairman%age=62
+
+ OPEN (UNIT=71, status = 'scratch', FORM='UNFORMATTED')
+ write (71) chairman
+ rewind (71)
+
+ chairman%name = "Charles"
+ chairman%age = 0
+
+ read (71) chairman
+ close (unit = 71)
+
+ ! Straight comparisons fail at any level of optimization.
+
+ write(line, "(A7)") chairman%name
+ if (trim (line) .ne. "Charlie") call abort
+ line = " "
+ write(line, "(I4)") chairman%age
+ if (trim (line) .eq. " 62") print *, trim(line)
+ END PROGRAM test
Index: gcc/testsuite/gfortran.dg/dtio_9.f90
===================================================================
*** gcc/testsuite/gfortran.dg/dtio_9.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/dtio_9.f90 (working copy)
***************
*** 0 ****
--- 1,66 ----
+ ! { dg-do run }
+ !
+ ! Tests dtio of transfer bind-C types.
+ !
+ ! Note difficulties with c_char at -O1. This is why no character field is used.
+ !
+ MODULE p
+ USE ISO_C_BINDING
+ TYPE, BIND(C) :: person
+ integer(c_int) :: id_no
+ INTEGER(c_int) :: age
+ END TYPE person
+ INTERFACE WRITE(UNFORMATTED)
+ MODULE PROCEDURE pwuf
+ END INTERFACE
+ INTERFACE READ(UNFORMATTED)
+ MODULE PROCEDURE pruf
+ END INTERFACE
+
+ CONTAINS
+
+ SUBROUTINE pwuf (dtv,unit,iostat,iomsg)
+ type(person), INTENT(IN) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ WRITE (UNIT=UNIT) DTV%id_no, DTV%age
+ END SUBROUTINE pwuf
+
+ SUBROUTINE pruf (dtv,unit,iostat,iomsg)
+ type(person), INTENT(INOUT) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ READ (UNIT = UNIT) dtv%id_no, dtv%age
+ END SUBROUTINE pruf
+
+ END MODULE p
+
+ PROGRAM test
+ USE p
+ TYPE (person) :: chairman
+ CHARACTER (kind=c_char) :: cname(20)
+ integer (c_int) :: cage, cid_no
+ character(10) :: line
+
+ cid_no = 1
+ cage = 62
+ chairman%id_no = cid_no
+ chairman%age = cage
+
+ OPEN (UNIT=71, status = 'scratch', FORM='UNFORMATTED')
+ write (71) chairman
+ rewind (71)
+
+ chairman%id_no = 0
+ chairman%age = 0
+
+ read (71) chairman
+ close (unit = 71)
+
+ write(line, "(I4)") chairman%id_no
+ if (trim (line) .ne. " 1") call abort
+ write(line, "(I4)") chairman%age
+ if (trim (line) .ne. " 62") call abort
+ end program
Index: libgfortran/gfortran.map
===================================================================
*** libgfortran/gfortran.map (revision 239769)
--- libgfortran/gfortran.map (working copy)
*************** GFORTRAN_1.7 {
*** 1289,1294 ****
--- 1289,1299 ----
_gfortran_shape_2;
} GFORTRAN_1.6;
+ GFORTRAN_1.8 {
+ global:
+ _gfortran_transfer_derived;
+ } GFORTRAN_1.7;
+
F2C_1.0 {
global:
_gfortran_f2c_specific__abs_c4;
Index: libgfortran/io/format.c
===================================================================
*** libgfortran/io/format.c (revision 239769)
--- libgfortran/io/format.c (working copy)
*************** void
*** 261,271 ****
free_format_data (format_data *fmt)
{
fnode_array *fa, *fa_next;
!
if (fmt == NULL)
return;
for (fa = fmt->array.next; fa; fa = fa_next)
{
fa_next = fa->next;
--- 261,280 ----
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;
*************** format_lex (format_data *fmt)
*** 545,550 ****
--- 554,562 ----
case 'C':
token = FMT_DC;
break;
+ case 'T':
+ token = FMT_DT;
+ break;
default:
token = FMT_D;
unget_char (fmt);
*************** parse_format_list (st_parameter_dt *dtp,
*** 806,811 ****
--- 818,824 ----
case FMT_EN:
case FMT_ES:
case FMT_D:
+ case FMT_DT:
case FMT_L:
case FMT_A:
case FMT_F:
*************** parse_format_list (st_parameter_dt *dtp,
*** 849,854 ****
--- 862,868 ----
/* 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:
*************** parse_format_list (st_parameter_dt *dtp,
*** 997,1003 ****
--- 1011,1067 ----
}
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)
{
*************** parse_format (st_parameter_dt *dtp)
*** 1219,1227 ****
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);
/* Lookup format string to see if it has already been parsed. */
if (format_cache_ok)
--- 1283,1294 ----
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.)
! 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)
*************** parse_format (st_parameter_dt *dtp)
*** 1257,1262 ****
--- 1324,1333 ----
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;
*************** next_format (st_parameter_dt *dtp)
*** 1392,1398 ****
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))
fmt->reversion_ok = 1;
return f;
}
--- 1463,1469 ----
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_DT))
fmt->reversion_ok = 1;
return f;
}
Index: libgfortran/io/format.h
===================================================================
*** libgfortran/io/format.h (revision 239769)
--- libgfortran/io/format.h (working copy)
*************** typedef enum
*** 38,44 ****
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
}
format_token;
--- 38,44 ----
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_DT
}
format_token;
*************** struct fnode
*** 74,79 ****
--- 74,87 ----
}
integer;
+ struct
+ {
+ char *string;
+ int string_len;
+ gfc_array_i4 *vlist;
+ }
+ udf; /* User Defined Format. */
+
int w;
int k;
int r;
Index: libgfortran/io/io.h
===================================================================
*** libgfortran/io/io.h (revision 239769)
--- libgfortran/io/io.h (working copy)
*************** typedef struct array_loop_spec
*** 94,99 ****
--- 94,123 ----
}
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
*************** typedef struct namelist_type
*** 136,141 ****
--- 160,171 ----
/* 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;
*************** typedef struct st_parameter_dt
*** 462,468 ****
/* 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;
char nml_delim;
int repeat_count;
--- 492,498 ----
/* 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; /* No longer used, moved to gfc_unit. */
char nml_delim;
int repeat_count;
*************** typedef struct st_parameter_dt
*** 484,489 ****
--- 514,521 ----
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
*************** typedef struct gfc_unit
*** 607,612 ****
--- 639,648 ----
/* 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;
*************** internal_proto(read_radix);
*** 728,733 ****
--- 764,775 ----
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,
*************** internal_proto(write_x);
*** 790,795 ****
--- 832,843 ----
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);
Index: libgfortran/io/list_read.c
===================================================================
*** libgfortran/io/list_read.c (revision 239769)
--- libgfortran/io/list_read.c (working copy)
*************** push_char_default (st_parameter_dt *dtp,
*** 84,90 ****
if (dtp->u.p.saved_string == NULL)
{
! // 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;
--- 84,90 ----
if (dtp->u.p.saved_string == NULL)
{
! /* 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;
*************** check_buffers (st_parameter_dt *dtp)
*** 170,180 ****
int c;
c = '\0';
! if (dtp->u.p.last_char != EOF - 1)
{
dtp->u.p.at_eol = 0;
! c = dtp->u.p.last_char;
! dtp->u.p.last_char = EOF - 1;
goto done;
}
--- 170,180 ----
int c;
c = '\0';
! if (dtp->u.p.current_unit->last_char != EOF - 1)
{
dtp->u.p.at_eol = 0;
! c = dtp->u.p.current_unit->last_char;
! dtp->u.p.current_unit->last_char = EOF - 1;
goto done;
}
*************** utf_done:
*** 369,375 ****
static void
unget_char (st_parameter_dt *dtp, int c)
{
! dtp->u.p.last_char = c;
}
--- 369,375 ----
static void
unget_char (st_parameter_dt *dtp, int c)
{
! dtp->u.p.current_unit->last_char = c;
}
*************** eat_spaces (st_parameter_dt *dtp)
*** 385,391 ****
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))
{
gfc_offset offset = stell (dtp->u.p.current_unit->s);
gfc_offset i;
--- 385,391 ----
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.current_unit->last_char == EOF - 1))
{
gfc_offset offset = stell (dtp->u.p.current_unit->s);
gfc_offset i;
*************** list_formatted_read_scalar (st_parameter
*** 2167,2172 ****
--- 2167,2212 ----
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");
}
*************** get_name:
*** 3206,3211 ****
--- 3246,3298 ----
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. */
Index: libgfortran/io/transfer.c
===================================================================
*** libgfortran/io/transfer.c (revision 239769)
--- libgfortran/io/transfer.c (working copy)
*************** extern void transfer_array_write (st_par
*** 122,127 ****
--- 122,136 ----
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);
*************** static void
*** 988,993 ****
--- 997,1036 ----
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);
*************** unformatted_read (st_parameter_dt *dtp,
*** 1016,1027 ****
/* 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. */
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)
|| kind == 1)
{
--- 1059,1104 ----
/* 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. 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 (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)
{
*************** type_name (bt type)
*** 1099,1104 ****
--- 1176,1184 ----
case BT_COMPLEX:
p = "COMPLEX";
break;
+ case BT_CLASS:
+ p = "CLASS or DERIVED";
+ break;
default:
internal_error (NULL, "type_name(): Bad type");
}
*************** formatted_transfer_scalar_read (st_param
*** 1322,1327 ****
--- 1402,1466 ----
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;
*************** formatted_transfer_scalar_write (st_para
*** 1630,1636 ****
&& ((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_STRING))
{
if (dtp->u.p.skips > 0)
--- 1769,1776 ----
&& ((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_DT))
|| t == FMT_STRING))
{
if (dtp->u.p.skips > 0)
*************** formatted_transfer_scalar_write (st_para
*** 1733,1738 ****
--- 1873,1935 ----
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_write (st_parameter_dt *d
*** 2198,2203 ****
--- 2395,2419 ----
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
*************** data_transfer_init (st_parameter_dt *dtp
*** 2384,2389 ****
--- 2600,2606 ----
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;
*************** data_transfer_init (st_parameter_dt *dtp
*** 2542,2548 ****
"EOF marker, possibly use REWIND or BACKSPACE");
return;
}
-
}
/* Process the ADVANCE option. */
--- 2759,2764 ----
*************** data_transfer_init (st_parameter_dt *dtp
*** 2834,2840 ****
{
if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
{
! dtp->u.p.last_char = EOF - 1;
dtp->u.p.transfer = list_formatted_read;
}
else
--- 3050,3057 ----
{
if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
{
! 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
*************** finalize_transfer (st_parameter_dt *dtp)
*** 3540,3545 ****
--- 3757,3774 ----
{
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;
*************** finalize_transfer (st_parameter_dt *dtp)
*** 3556,3570 ****
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;
--- 3785,3790 ----
*************** st_write_done (st_parameter_dt *dtp)
*** 3760,3766 ****
/* Deal with endfile conditions associated with sequential files. */
if (dtp->u.p.current_unit != NULL
! && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
switch (dtp->u.p.current_unit->endfile)
{
case AT_ENDFILE: /* Remain at the endfile record. */
--- 3980,3987 ----
/* Deal with endfile conditions associated with sequential files. */
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. */
*************** st_wait (st_parameter_wait *wtp __attrib
*** 3808,3821 ****
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)
{
namelist_info *t1 = NULL;
namelist_info *nml;
--- 4029,4043 ----
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,
! void *, void *);
export_proto(st_set_nml_var);
void
st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
GFC_INTEGER_4 len, gfc_charlen_type string_length,
! GFC_INTEGER_4 dtype, void *dtio_sub, void *vtable)
{
namelist_info *t1 = NULL;
namelist_info *nml;
*************** st_set_nml_var (st_parameter_dt *dtp, vo
*** 3824,3829 ****
--- 4046,4053 ----
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);
Index: libgfortran/io/unit.c
===================================================================
*** libgfortran/io/unit.c (revision 239769)
--- libgfortran/io/unit.c (working copy)
*************** retry:
*** 348,354 ****
}
found:
! if (p != NULL)
{
/* Fast path. */
if (! __gthread_mutex_trylock (&p->lock))
--- 348,354 ----
}
found:
! if (p != NULL && (p->child_dtio == 0))
{
/* Fast path. */
if (! __gthread_mutex_trylock (&p->lock))
*************** found:
*** 363,369 ****
__gthread_mutex_unlock (&unit_lock);
! if (p != NULL)
{
__gthread_mutex_lock (&p->lock);
if (p->closed)
--- 363,369 ----
__gthread_mutex_unlock (&unit_lock);
! if (p != NULL && (p->child_dtio == 0))
{
__gthread_mutex_lock (&p->lock);
if (p->closed)
Index: libgfortran/io/unix.c
===================================================================
*** libgfortran/io/unix.c (revision 239769)
--- libgfortran/io/unix.c (working copy)
*************** tempfile_open (const char *tempdir, char
*** 1121,1127 ****
)
slash = "";
! // Take care that the template is longer in the mktemp() branch.
char * template = xmalloc (tempdirlen + 23);
#ifdef HAVE_MKSTEMP
--- 1121,1127 ----
)
slash = "";
! /* Take care that the template is longer in the mktemp() branch. */
char * template = xmalloc (tempdirlen + 23);
#ifdef HAVE_MKSTEMP
Index: libgfortran/io/write.c
===================================================================
*** libgfortran/io/write.c (revision 239769)
--- libgfortran/io/write.c (working copy)
*************** list_formatted_write_scalar (st_paramete
*** 1710,1715 ****
--- 1710,1755 ----
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");
}
*************** nml_write_obj (st_parameter_dt *dtp, nam
*** 1985,1991 ****
break;
case BT_DERIVED:
!
/* 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
--- 2025,2031 ----
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
*************** nml_write_obj (st_parameter_dt *dtp, nam
*** 1995,2000 ****
--- 2035,2086 ----
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;
More information about the Fortran
mailing list