[Patch, fortran] PR48298 - [F03] User-Defined Derived-Type IO (DTIO)
Paul Richard Thomas
paul.richard.thomas@gmail.com
Mon Aug 22 12:33:00 GMT 2016
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.
-------------- next part --------------
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c (revision 239525)
--- 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 239525)
--- 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
*** 784,790 ****
unsigned implicit_pure:1;
/* This is set for a procedure that contains expressions referencing
! arrays coming from outside its namespace.
This is used to force the creation of a temporary when the LHS of
an array assignment may be used by an elemental procedure appearing
on the RHS. */
--- 793,799 ----
unsigned implicit_pure:1;
/* This is set for a procedure that contains expressions referencing
! arrays coming from outside its namespace.
This is used to force the creation of a temporary when the LHS of
an array assignment may be used by an elemental procedure appearing
on the RHS. */
*************** 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 239525)
--- 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)
*** 349,355 ****
if (strcmp(s2, "none") == 0)
gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> "
"at %C, ", s1);
! else
gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> at %C, "
"but got %s", s1, s2);
}
--- 397,403 ----
if (strcmp(s2, "none") == 0)
gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> "
"at %C, ", s1);
! else
gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> at %C, "
"but got %s", s1, s2);
}
*************** 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_extend_expr (gfc_expr *e)
*** 3945,3951 ****
else
return MATCH_YES;
}
!
if (i == INTRINSIC_USER)
{
for (ns = gfc_current_ns; ns; ns = ns->parent)
--- 3994,4000 ----
else
return MATCH_YES;
}
!
if (i == INTRINSIC_USER)
{
for (ns = gfc_current_ns; ns; ns = ns->parent)
*************** gfc_add_interface (gfc_symbol *new_sym)
*** 4136,4195 ****
{
case INTRINSIC_EQ:
case INTRINSIC_EQ_OS:
! if (!gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym,
gfc_current_locus)
! || !gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
! if (!gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym,
gfc_current_locus)
! || !gfc_check_new_interface (ns->op[INTRINSIC_NE_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_GT:
case INTRINSIC_GT_OS:
! if (!gfc_check_new_interface (ns->op[INTRINSIC_GT],
new_sym, gfc_current_locus)
! || !gfc_check_new_interface (ns->op[INTRINSIC_GT_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_GE:
case INTRINSIC_GE_OS:
! if (!gfc_check_new_interface (ns->op[INTRINSIC_GE],
new_sym, gfc_current_locus)
! || !gfc_check_new_interface (ns->op[INTRINSIC_GE_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_LT:
case INTRINSIC_LT_OS:
! if (!gfc_check_new_interface (ns->op[INTRINSIC_LT],
new_sym, gfc_current_locus)
! || !gfc_check_new_interface (ns->op[INTRINSIC_LT_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_LE:
case INTRINSIC_LE_OS:
! if (!gfc_check_new_interface (ns->op[INTRINSIC_LE],
new_sym, gfc_current_locus)
! || !gfc_check_new_interface (ns->op[INTRINSIC_LE_OS],
new_sym, gfc_current_locus))
return false;
break;
default:
! if (!gfc_check_new_interface (ns->op[current_interface.op],
new_sym, gfc_current_locus))
return false;
}
--- 4185,4244 ----
{
case INTRINSIC_EQ:
case INTRINSIC_EQ_OS:
! if (!gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym,
gfc_current_locus)
! || !gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
! if (!gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym,
gfc_current_locus)
! || !gfc_check_new_interface (ns->op[INTRINSIC_NE_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_GT:
case INTRINSIC_GT_OS:
! if (!gfc_check_new_interface (ns->op[INTRINSIC_GT],
new_sym, gfc_current_locus)
! || !gfc_check_new_interface (ns->op[INTRINSIC_GT_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_GE:
case INTRINSIC_GE_OS:
! if (!gfc_check_new_interface (ns->op[INTRINSIC_GE],
new_sym, gfc_current_locus)
! || !gfc_check_new_interface (ns->op[INTRINSIC_GE_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_LT:
case INTRINSIC_LT_OS:
! if (!gfc_check_new_interface (ns->op[INTRINSIC_LT],
new_sym, gfc_current_locus)
! || !gfc_check_new_interface (ns->op[INTRINSIC_LT_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_LE:
case INTRINSIC_LE_OS:
! if (!gfc_check_new_interface (ns->op[INTRINSIC_LE],
new_sym, gfc_current_locus)
! || !gfc_check_new_interface (ns->op[INTRINSIC_LE_OS],
new_sym, gfc_current_locus))
return false;
break;
default:
! if (!gfc_check_new_interface (ns->op[current_interface.op],
new_sym, gfc_current_locus))
return false;
}
*************** gfc_add_interface (gfc_symbol *new_sym)
*** 4198,4210 ****
break;
case INTERFACE_GENERIC:
for (ns = current_interface.ns; ns; ns = ns->parent)
{
gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
if (sym == NULL)
continue;
! if (!gfc_check_new_interface (sym->generic,
new_sym, gfc_current_locus))
return false;
}
--- 4247,4260 ----
break;
case INTERFACE_GENERIC:
+ case INTERFACE_DTIO:
for (ns = current_interface.ns; ns; ns = ns->parent)
{
gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
if (sym == NULL)
continue;
! if (!gfc_check_new_interface (sym->generic,
new_sym, gfc_current_locus))
return false;
}
*************** gfc_add_interface (gfc_symbol *new_sym)
*** 4213,4219 ****
break;
case INTERFACE_USER_OP:
! if (!gfc_check_new_interface (current_interface.uop->op,
new_sym, gfc_current_locus))
return false;
--- 4263,4269 ----
break;
case INTERFACE_USER_OP:
! if (!gfc_check_new_interface (current_interface.uop->op,
new_sym, gfc_current_locus))
return false;
*************** 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 239525)
--- 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 239525)
--- 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 239525)
--- 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,8722 ----
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 (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 "
--- 8726,8734 ----
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 "
--- 8744,8750 ----
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;
}
}
--- 8761,8771 ----
"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 ****
--- 10937,10957 ----
}
+ /* 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)
*** 13414,13424 ****
--- 13465,13495 ----
}
+ /* 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)
*** 13452,13460 ****
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 "
--- 13523,13531 ----
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)
*** 13472,13484 ****
sym->name, &sym->declared_at))
return false;
! /* FIXME: Once UDDTIO is implemented, the following can be
! removed. */
! gfc_error ("NAMELIST object %qs in namelist %qs at %L has "
! "ALLOCATABLE or POINTER components and thus requires "
! "a defined input/output procedure", nl->sym->name,
! sym->name, &sym->declared_at);
! return false;
}
}
--- 13543,13556 ----
sym->name, &sym->declared_at))
return false;
! if (!dtio)
! {
! gfc_error ("NAMELIST object %qs in namelist %qs at %L has "
! "ALLOCATABLE or POINTER components and thus requires "
! "a defined input/output procedure", nl->sym->name,
! sym->name, &sym->declared_at);
! return false;
! }
}
}
*************** resolve_fl_namelist (gfc_symbol *sym)
*** 13497,13502 ****
--- 13569,13579 ----
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)
*** 15520,15525 ****
--- 15597,15604 ----
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 239525)
--- 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 239525)
--- 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 239525)
--- gcc/fortran/trans-expr.c (working copy)
*************** 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. */
--- 511,524 ----
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
{
--- 529,534 ----
Index: gcc/fortran/trans-io.c
===================================================================
*** gcc/fortran/trans-io.c (revision 239525)
--- 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_value_inquire (stmtblock_t
*** 637,643 ****
body = gfc_finish_block (&newblock);
! cond3 = gfc_unlikely (cond3, PRED_FORTRAN_FAIL_IO);
var = build3_v (COND_EXPR, cond3, body, build_empty_stmt (input_location));
gfc_add_expr_to_block (&se.pre, var);
}
--- 653,659 ----
body = gfc_finish_block (&newblock);
! cond3 = gfc_unlikely (cond3, PRED_FORTRAN_FAIL_IO);
var = build3_v (COND_EXPR, cond3, body, build_empty_stmt (input_location));
gfc_add_expr_to_block (&se.pre, var);
}
*************** 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,2254 ****
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,
! expr);
!
! /* Make sure that the derived type has been built. An external
! function, if only referenced in an io statement, requires this
! check (see PR58771). */
! if (ts->u.derived->backend_decl == NULL_TREE)
! (void) gfc_typenode_for_spec (ts);
! for (c = ts->u.derived->components; c; c = c->next)
! {
! field = c->backend_decl;
! gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
! tmp = fold_build3_loc (UNKNOWN_LOCATION,
! COMPONENT_REF, TREE_TYPE (field),
! expr, field, NULL_TREE);
!
! if (c->attr.dimension)
! {
! tmp = transfer_array_component (tmp, c, & code->loc);
! gfc_add_expr_to_block (&se->pre, tmp);
! }
! else
! {
! if (!c->attr.pointer)
! tmp = gfc_build_addr_expr (NULL_TREE, tmp);
! transfer_expr (se, &c->ts, tmp, code);
! }
}
- return;
-
default:
gfc_internal_error ("Bad IO basetype (%d)", ts->type);
}
--- 2291,2371 ----
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,
! expr);
! /* Make sure that the derived type has been built. An external
! function, if only referenced in an io statement, requires this
! check (see PR58771). */
! if (ts->u.derived->backend_decl == NULL_TREE)
! (void) gfc_typenode_for_spec (ts);
!
! for (c = ts->u.derived->components; c; c = c->next)
! {
! field = c->backend_decl;
! gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
!
! tmp = fold_build3_loc (UNKNOWN_LOCATION,
! COMPONENT_REF, TREE_TYPE (field),
! expr, field, NULL_TREE);
!
! if (c->attr.dimension)
! {
! tmp = transfer_array_component (tmp, c, & code->loc);
! gfc_add_expr_to_block (&se->pre, tmp);
! }
! else
! {
! if (!c->attr.pointer)
! tmp = gfc_build_addr_expr (NULL_TREE, tmp);
! transfer_expr (se, &c->ts, tmp, code, NULL_TREE);
! }
! }
! return;
! }
! /* If a CLASS object gets through to here, fall through and ICE. */
}
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") print *, astring
+ if (member%name.ne."George") call abort
+ if (chairman%name.ne."Charlie") call abort
+ if (member%age.ne.42) call abort
+ if (chairman%age.ne.62) call abort
+ END PROGRAM test
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_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 239525)
--- libgfortran/gfortran.map (working copy)
*************** GFORTRAN_1.1 {
*** 1091,1097 ****
_gfortran_transpose_char4;
_gfortran_unpack0_char4;
_gfortran_unpack1_char4;
! } GFORTRAN_1.0;
GFORTRAN_1.2 {
--- 1091,1097 ----
_gfortran_transpose_char4;
_gfortran_unpack0_char4;
_gfortran_unpack1_char4;
! } GFORTRAN_1.0;
GFORTRAN_1.2 {
*************** GFORTRAN_1.2 {
*** 1099,1110 ****
_gfortran_clz128;
_gfortran_ctz128;
_gfortran_is_extension_of;
! } GFORTRAN_1.1;
GFORTRAN_1.3 {
global:
_gfortran_error_stop_string;
! } GFORTRAN_1.2;
GFORTRAN_1.4 {
global:
--- 1099,1110 ----
_gfortran_clz128;
_gfortran_ctz128;
_gfortran_is_extension_of;
! } GFORTRAN_1.1;
GFORTRAN_1.3 {
global:
_gfortran_error_stop_string;
! } GFORTRAN_1.2;
GFORTRAN_1.4 {
global:
*************** GFORTRAN_1.4 {
*** 1187,1199 ****
_gfortran_cshift0_16_char4;
_gfortran_eoshift0_16_char4;
_gfortran_eoshift2_16_char4;
! } GFORTRAN_1.3;
GFORTRAN_1.5 {
global:
_gfortran_ftell2;
_gfortran_backtrace;
! } GFORTRAN_1.4;
GFORTRAN_1.6 {
global:
--- 1187,1199 ----
_gfortran_cshift0_16_char4;
_gfortran_eoshift0_16_char4;
_gfortran_eoshift2_16_char4;
! } GFORTRAN_1.3;
GFORTRAN_1.5 {
global:
_gfortran_ftell2;
_gfortran_backtrace;
! } GFORTRAN_1.4;
GFORTRAN_1.6 {
global:
*************** GFORTRAN_1.6 {
*** 1274,1280 ****
__ieee_exceptions_MOD_ieee_support_flag_noarg;
__ieee_exceptions_MOD_ieee_support_halting;
__ieee_exceptions_MOD_ieee_usual;
! } GFORTRAN_1.5;
GFORTRAN_1.7 {
global:
--- 1274,1280 ----
__ieee_exceptions_MOD_ieee_support_flag_noarg;
__ieee_exceptions_MOD_ieee_support_halting;
__ieee_exceptions_MOD_ieee_usual;
! } GFORTRAN_1.5;
GFORTRAN_1.7 {
global:
*************** GFORTRAN_1.7 {
*** 1287,1293 ****
_gfortran_mvbits_i16;
_gfortran_shape_1;
_gfortran_shape_2;
! } GFORTRAN_1.6;
F2C_1.0 {
global:
--- 1287,1298 ----
_gfortran_mvbits_i16;
_gfortran_shape_1;
_gfortran_shape_2;
! } GFORTRAN_1.6;
!
! GFORTRAN_1.8 {
! global:
! _gfortran_transfer_derived;
! } GFORTRAN_1.7;
F2C_1.0 {
global:
Index: libgfortran/io/format.c
===================================================================
*** libgfortran/io/format.c (revision 239525)
--- libgfortran/io/format.c (working copy)
*************** free_format_hash_table (gfc_unit *u)
*** 70,76 ****
free (u->format_hash_table[i].key);
}
u->format_hash_table[i].key = NULL;
! u->format_hash_table[i].key_len = 0;
u->format_hash_table[i].hashed_fmt = NULL;
}
}
--- 70,76 ----
free (u->format_hash_table[i].key);
}
u->format_hash_table[i].key = NULL;
! u->format_hash_table[i].key_len = 0;
u->format_hash_table[i].hashed_fmt = NULL;
}
}
*************** reset_node (fnode *fn)
*** 84,90 ****
fn->count = 0;
fn->current = NULL;
!
if (fn->format != FMT_LPAREN)
return;
--- 84,90 ----
fn->count = 0;
fn->current = NULL;
!
if (fn->format != FMT_LPAREN)
return;
*************** 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,
*** 740,746 ****
tail->u.string.length = fmt->value;
tail->repeat = 1;
goto optional_comma;
!
case FMT_RC:
case FMT_RD:
case FMT_RN:
--- 752,758 ----
tail->u.string.length = fmt->value;
tail->repeat = 1;
goto optional_comma;
!
case FMT_RC:
case FMT_RD:
case FMT_RN:
*************** 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 239525)
--- 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 239525)
--- 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 239525)
--- 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 239525)
--- libgfortran/io/transfer.c (working copy)
*************** see the files COPYING3 and COPYING.RUNTI
*** 57,63 ****
transfer_complex
transfer_real128
transfer_complex128
!
and for WRITE
transfer_integer_write
--- 57,63 ----
transfer_complex
transfer_real128
transfer_complex128
!
and for WRITE
transfer_integer_write
*************** 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);
*************** read_sf (st_parameter_dt *dtp, int * len
*** 315,321 ****
the rest of the I/O statement. Set the corresponding flag. */
if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
dtp->u.p.eor_condition = 1;
!
/* If we encounter a CR, it might be a CRLF. */
if (q == '\r') /* Probably a CRLF */
{
--- 324,330 ----
the rest of the I/O statement. Set the corresponding flag. */
if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
dtp->u.p.eor_condition = 1;
!
/* If we encounter a CR, it might be a CRLF. */
if (q == '\r') /* Probably a CRLF */
{
*************** read_block_direct (st_parameter_dt *dtp,
*** 548,554 ****
if (is_stream_io (dtp))
{
! have_read_record = sread (dtp->u.p.current_unit->s, buf,
nbytes);
if (unlikely (have_read_record < 0))
{
--- 557,563 ----
if (is_stream_io (dtp))
{
! have_read_record = sread (dtp->u.p.current_unit->s, buf,
nbytes);
if (unlikely (have_read_record < 0))
{
*************** read_block_direct (st_parameter_dt *dtp,
*** 556,562 ****
return;
}
! dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record;
if (unlikely ((ssize_t) nbytes != have_read_record))
{
--- 565,571 ----
return;
}
! dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record;
if (unlikely ((ssize_t) nbytes != have_read_record))
{
*************** read_block_direct (st_parameter_dt *dtp,
*** 590,596 ****
return;
}
! if (to_read_record != (ssize_t) nbytes)
{
/* Short read, e.g. if we hit EOF. Apparently, we read
more than was written to the last record. */
--- 599,605 ----
return;
}
! if (to_read_record != (ssize_t) nbytes)
{
/* Short read, e.g. if we hit EOF. Apparently, we read
more than was written to the last record. */
*************** read_block_direct (st_parameter_dt *dtp,
*** 639,645 ****
dtp->u.p.current_unit->bytes_left_subrecord -= to_read_subrecord;
! have_read_subrecord = sread (dtp->u.p.current_unit->s,
buf + have_read_record, to_read_subrecord);
if (unlikely (have_read_subrecord < 0))
{
--- 648,654 ----
dtp->u.p.current_unit->bytes_left_subrecord -= to_read_subrecord;
! have_read_subrecord = sread (dtp->u.p.current_unit->s,
buf + have_read_record, to_read_subrecord);
if (unlikely (have_read_subrecord < 0))
{
*************** write_block (st_parameter_dt *dtp, int l
*** 760,766 ****
return NULL;
}
}
!
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
dtp->u.p.size_used += (GFC_IO_INT) length;
--- 769,775 ----
return NULL;
}
}
!
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
dtp->u.p.size_used += (GFC_IO_INT) length;
*************** write_buf (st_parameter_dt *dtp, void *b
*** 793,799 ****
return false;
}
! dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written;
return true;
}
--- 802,808 ----
return false;
}
! dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written;
return true;
}
*************** write_buf (st_parameter_dt *dtp, void *b
*** 811,817 ****
if (buf == NULL && nbytes == 0)
return true;
! have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes);
if (unlikely (have_written < 0))
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
--- 820,826 ----
if (buf == NULL && nbytes == 0)
return true;
! have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes);
if (unlikely (have_written < 0))
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
*************** write_buf (st_parameter_dt *dtp, void *b
*** 849,855 ****
dtp->u.p.current_unit->bytes_left_subrecord -=
(gfc_offset) to_write_subrecord;
! to_write_subrecord = swrite (dtp->u.p.current_unit->s,
buf + have_written, to_write_subrecord);
if (unlikely (to_write_subrecord < 0))
{
--- 858,864 ----
dtp->u.p.current_unit->bytes_left_subrecord -=
(gfc_offset) to_write_subrecord;
! to_write_subrecord = swrite (dtp->u.p.current_unit->s,
buf + have_written, to_write_subrecord);
if (unlikely (to_write_subrecord < 0))
{
*************** write_buf (st_parameter_dt *dtp, void *b
*** 857,863 ****
return false;
}
! dtp->u.p.current_unit->strm_pos += (gfc_offset) to_write_subrecord;
nbytes -= to_write_subrecord;
have_written += to_write_subrecord;
--- 866,872 ----
return false;
}
! dtp->u.p.current_unit->strm_pos += (gfc_offset) to_write_subrecord;
nbytes -= to_write_subrecord;
have_written += to_write_subrecord;
*************** reverse_memcpy (void *dest, const void *
*** 903,909 ****
static void
bswap_array (void *dest, const void *src, size_t size, size_t nelems)
{
! const char *ps;
char *pd;
switch (size)
--- 912,918 ----
static void
bswap_array (void *dest, const void *src, size_t size, size_t nelems)
{
! const char *ps;
char *pd;
switch (size)
*************** 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,1028 ****
/* 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)
{
size_t stride = type == BT_CHARACTER ?
--- 1059,1105 ----
/* 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)
{
size_t stride = type == BT_CHARACTER ?
*************** unformatted_write (st_parameter_dt *dtp,
*** 1045,1057 ****
nelems *= size;
size = kind;
}
!
/* Break up complex into its constituent reals. */
if (type == BT_COMPLEX)
{
nelems *= 2;
size /= 2;
! }
/* By now, all complex variables have been split into their
constituent reals. */
--- 1122,1134 ----
nelems *= size;
size = kind;
}
!
/* Break up complex into its constituent reals. */
if (type == BT_COMPLEX)
{
nelems *= 2;
size /= 2;
! }
/* By now, all complex variables have been split into their
constituent reals. */
*************** 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");
}
*************** static void
*** 1115,1121 ****
write_constant_string (st_parameter_dt *dtp, const fnode *f)
{
char c, delimiter, *p, *q;
! int length;
length = f->u.string.length;
if (length == 0)
--- 1195,1201 ----
write_constant_string (st_parameter_dt *dtp, const fnode *f)
{
char c, delimiter, *p, *q;
! int length;
length = f->u.string.length;
if (length == 0)
*************** write_constant_string (st_parameter_dt *
*** 1124,1130 ****
p = write_block (dtp, length);
if (p == NULL)
return;
!
q = f->u.string.p;
delimiter = q[-1];
--- 1204,1210 ----
p = write_block (dtp, length);
if (p == NULL)
return;
!
q = f->u.string.p;
delimiter = q[-1];
*************** require_type (st_parameter_dt *dtp, bt e
*** 1151,1157 ****
return 0;
/* Adjust item_count before emitting error message. */
! snprintf (buffer, BUFLEN,
"Expected %s for item %d in formatted transfer, got %s",
type_name (expected), dtp->u.p.item_count - 1, type_name (actual));
--- 1231,1237 ----
return 0;
/* Adjust item_count before emitting error message. */
! snprintf (buffer, BUFLEN,
"Expected %s for item %d in formatted transfer, got %s",
type_name (expected), dtp->u.p.item_count - 1, type_name (actual));
*************** require_numeric_type (st_parameter_dt *d
*** 1170,1176 ****
return 0;
/* Adjust item_count before emitting error message. */
! snprintf (buffer, BUFLEN,
"Expected numeric type for item %d in formatted transfer, got %s",
dtp->u.p.item_count - 1, type_name (actual));
--- 1250,1256 ----
return 0;
/* Adjust item_count before emitting error message. */
! snprintf (buffer, BUFLEN,
"Expected numeric type for item %d in formatted transfer, got %s",
dtp->u.p.item_count - 1, type_name (actual));
*************** formatted_transfer_scalar_read (st_param
*** 1273,1279 ****
case FMT_O:
if (n == 0)
! goto need_read_data;
if (!(compile_options.allow_std & GFC_STD_GNU)
&& require_numeric_type (dtp, type, f))
return;
--- 1353,1359 ----
case FMT_O:
if (n == 0)
! goto need_read_data;
if (!(compile_options.allow_std & GFC_STD_GNU)
&& require_numeric_type (dtp, type, f))
return;
*************** 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_read (st_param
*** 1438,1444 ****
}
if (dtp->u.p.skips < 0)
{
! if (is_internal_unit (dtp))
sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR);
else
fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
--- 1577,1583 ----
}
if (dtp->u.p.skips < 0)
{
! if (is_internal_unit (dtp))
sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR);
else
fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
*************** formatted_transfer_scalar_write (st_para
*** 1624,1636 ****
/* Now discharge T, TR and X movements to the right. This is delayed
until a data producing format to suppress trailing spaces. */
!
t = f->format;
if (dtp->u.p.mode == WRITING && dtp->u.p.skips != 0
&& ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O
|| t == FMT_Z || t == FMT_F || t == FMT_E
|| t == FMT_EN || t == FMT_ES || t == FMT_G
! || t == FMT_L || t == FMT_A || t == FMT_D))
|| t == FMT_STRING))
{
if (dtp->u.p.skips > 0)
--- 1763,1776 ----
/* Now discharge T, TR and X movements to the right. This is delayed
until a data producing format to suppress trailing spaces. */
!
t = f->format;
if (dtp->u.p.mode == WRITING && dtp->u.p.skips != 0
&& ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O
|| t == FMT_Z || t == FMT_F || t == FMT_E
|| t == FMT_EN || t == FMT_ES || t == FMT_G
! || t == FMT_L || t == FMT_A || t == FMT_D
! || t == FMT_DT))
|| t == FMT_STRING))
{
if (dtp->u.p.skips > 0)
*************** formatted_transfer_scalar_write (st_para
*** 1639,1651 ****
write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
tmp = (int)(dtp->u.p.current_unit->recl
- dtp->u.p.current_unit->bytes_left);
! dtp->u.p.max_pos =
dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp;
dtp->u.p.skips = 0;
}
if (dtp->u.p.skips < 0)
{
! if (is_internal_unit (dtp))
sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR);
else
fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
--- 1779,1791 ----
write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
tmp = (int)(dtp->u.p.current_unit->recl
- dtp->u.p.current_unit->bytes_left);
! dtp->u.p.max_pos =
dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp;
dtp->u.p.skips = 0;
}
if (dtp->u.p.skips < 0)
{
! if (is_internal_unit (dtp))
sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR);
else
fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
*************** formatted_transfer_scalar_write (st_para
*** 1684,1690 ****
case FMT_O:
if (n == 0)
! goto need_data;
if (!(compile_options.allow_std & GFC_STD_GNU)
&& require_numeric_type (dtp, type, f))
return;
--- 1824,1830 ----
case FMT_O:
if (n == 0)
! goto need_data;
if (!(compile_options.allow_std & GFC_STD_GNU)
&& require_numeric_type (dtp, type, f))
return;
*************** 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
*************** pre_position (st_parameter_dt *dtp)
*** 2340,2346 ****
was specified, we continue from where we last left off. I.e.
there is nothing to do here. */
break;
!
case UNFORMATTED_SEQUENTIAL:
if (dtp->u.p.mode == READING)
us_read (dtp, 0);
--- 2556,2562 ----
was specified, we continue from where we last left off. I.e.
there is nothing to do here. */
break;
!
case UNFORMATTED_SEQUENTIAL:
if (dtp->u.p.mode == READING)
us_read (dtp, 0);
*************** 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
*** 2431,2445 ****
case GFC_CONVERT_NATIVE:
case GFC_CONVERT_SWAP:
break;
!
case GFC_CONVERT_BIG:
conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
break;
!
case GFC_CONVERT_LITTLE:
conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
break;
!
default:
internal_error (&opp.common, "Illegal value for CONVERT");
break;
--- 2648,2662 ----
case GFC_CONVERT_NATIVE:
case GFC_CONVERT_SWAP:
break;
!
case GFC_CONVERT_BIG:
conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
break;
!
case GFC_CONVERT_LITTLE:
conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
break;
!
default:
internal_error (&opp.common, "Illegal value for CONVERT");
break;
*************** 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
*** 2589,2595 ****
return;
}
! if ((cf & IOPARM_DT_HAS_SIZE) != 0
&& dtp->u.p.advance_status != ADVANCE_NO)
{
generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
--- 2805,2811 ----
return;
}
! if ((cf & IOPARM_DT_HAS_SIZE) != 0
&& dtp->u.p.advance_status != ADVANCE_NO)
{
generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
*************** data_transfer_init (st_parameter_dt *dtp
*** 2653,2659 ****
= !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED :
find_option (&dtp->common, dtp->sign, dtp->sign_len, sign_opt,
"Bad SIGN parameter in data transfer statement");
!
if (dtp->u.p.sign_status == SIGN_UNSPECIFIED)
dtp->u.p.sign_status = dtp->u.p.current_unit->flags.sign;
--- 2869,2875 ----
= !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED :
find_option (&dtp->common, dtp->sign, dtp->sign_len, sign_opt,
"Bad SIGN parameter in data transfer statement");
!
if (dtp->u.p.sign_status == SIGN_UNSPECIFIED)
dtp->u.p.sign_status = dtp->u.p.current_unit->flags.sign;
*************** data_transfer_init (st_parameter_dt *dtp
*** 2663,2669 ****
find_option (&dtp->common, dtp->blank, dtp->blank_len,
blank_opt,
"Bad BLANK parameter in data transfer statement");
!
if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
--- 2879,2885 ----
find_option (&dtp->common, dtp->blank, dtp->blank_len,
blank_opt,
"Bad BLANK parameter in data transfer statement");
!
if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
*************** data_transfer_init (st_parameter_dt *dtp
*** 2703,2730 ****
/* Check the POS= specifier: that it is in range and that it is used with a
unit that has been connected for STREAM access. F2003 9.5.1.10. */
!
if (((cf & IOPARM_DT_HAS_POS) != 0))
{
if (is_stream_io (dtp))
{
!
if (dtp->pos <= 0)
{
generate_error (&dtp->common, LIBERROR_BAD_OPTION,
"POS=specifier must be positive");
return;
}
!
if (dtp->pos >= dtp->u.p.current_unit->maxrec)
{
generate_error (&dtp->common, LIBERROR_BAD_OPTION,
"POS=specifier too large");
return;
}
!
dtp->rec = dtp->pos;
!
if (dtp->u.p.mode == READING)
{
/* Reset the endfile flag; if we hit EOF during reading
--- 2919,2946 ----
/* Check the POS= specifier: that it is in range and that it is used with a
unit that has been connected for STREAM access. F2003 9.5.1.10. */
!
if (((cf & IOPARM_DT_HAS_POS) != 0))
{
if (is_stream_io (dtp))
{
!
if (dtp->pos <= 0)
{
generate_error (&dtp->common, LIBERROR_BAD_OPTION,
"POS=specifier must be positive");
return;
}
!
if (dtp->pos >= dtp->u.p.current_unit->maxrec)
{
generate_error (&dtp->common, LIBERROR_BAD_OPTION,
"POS=specifier too large");
return;
}
!
dtp->rec = dtp->pos;
!
if (dtp->u.p.mode == READING)
{
/* Reset the endfile flag; if we hit EOF during reading
*************** data_transfer_init (st_parameter_dt *dtp
*** 2732,2738 ****
rather than worrying about it here. */
dtp->u.p.current_unit->endfile = NO_ENDFILE;
}
!
if (dtp->pos != dtp->u.p.current_unit->strm_pos)
{
fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
--- 2948,2954 ----
rather than worrying about it here. */
dtp->u.p.current_unit->endfile = NO_ENDFILE;
}
!
if (dtp->pos != dtp->u.p.current_unit->strm_pos)
{
fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
*************** data_transfer_init (st_parameter_dt *dtp
*** 2752,2758 ****
return;
}
}
!
/* Sanity checks on the record number. */
if ((cf & IOPARM_DT_HAS_REC) != 0)
--- 2968,2974 ----
return;
}
}
!
/* Sanity checks on the record number. */
if ((cf & IOPARM_DT_HAS_REC) != 0)
*************** data_transfer_init (st_parameter_dt *dtp
*** 2789,2799 ****
/* Position the file. */
if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
! * dtp->u.p.current_unit->recl, SEEK_SET) < 0)
! {
! generate_error (&dtp->common, LIBERROR_OS, NULL);
! return;
! }
/* TODO: This is required to maintain compatibility between
4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */
--- 3005,3015 ----
/* Position the file. */
if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
! * dtp->u.p.current_unit->recl, SEEK_SET) < 0)
! {
! generate_error (&dtp->common, LIBERROR_OS, NULL);
! return;
! }
/* TODO: This is required to maintain compatibility between
4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */
*************** data_transfer_init (st_parameter_dt *dtp
*** 2822,2828 ****
dtp->u.p.max_pos = dtp->u.p.current_unit->saved_pos;
pre_position (dtp);
!
/* Set up the subroutine that will handle the transfers. */
--- 3038,3044 ----
dtp->u.p.max_pos = dtp->u.p.current_unit->saved_pos;
pre_position (dtp);
!
/* Set up the subroutine that will handle the transfers. */
*************** data_transfer_init (st_parameter_dt *dtp
*** 2834,2841 ****
{
if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
{
! dtp->u.p.last_char = EOF - 1;
! dtp->u.p.transfer = list_formatted_read;
}
else
dtp->u.p.transfer = formatted_transfer;
--- 3050,3058 ----
{
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
dtp->u.p.transfer = formatted_transfer;
*************** data_transfer_init (st_parameter_dt *dtp
*** 2896,2909 ****
returns the index of the last element of the array, and also returns
starting record, where the first I/O goes to (necessary in case of
negative strides). */
!
gfc_offset
init_loop_spec (gfc_array_char *desc, array_loop_spec *ls,
gfc_offset *start_record)
{
int rank = GFC_DESCRIPTOR_RANK(desc);
int i;
! gfc_offset index;
int empty;
empty = 0;
--- 3113,3126 ----
returns the index of the last element of the array, and also returns
starting record, where the first I/O goes to (necessary in case of
negative strides). */
!
gfc_offset
init_loop_spec (gfc_array_char *desc, array_loop_spec *ls,
gfc_offset *start_record)
{
int rank = GFC_DESCRIPTOR_RANK(desc);
int i;
! gfc_offset index;
int empty;
empty = 0;
*************** init_loop_spec (gfc_array_char *desc, ar
*** 2916,2922 ****
ls[i].start = GFC_DESCRIPTOR_LBOUND(desc,i);
ls[i].end = GFC_DESCRIPTOR_UBOUND(desc,i);
ls[i].step = GFC_DESCRIPTOR_STRIDE(desc,i);
! empty = empty || (GFC_DESCRIPTOR_UBOUND(desc,i)
< GFC_DESCRIPTOR_LBOUND(desc,i));
if (GFC_DESCRIPTOR_STRIDE(desc,i) > 0)
--- 3133,3139 ----
ls[i].start = GFC_DESCRIPTOR_LBOUND(desc,i);
ls[i].end = GFC_DESCRIPTOR_UBOUND(desc,i);
ls[i].step = GFC_DESCRIPTOR_STRIDE(desc,i);
! empty = empty || (GFC_DESCRIPTOR_UBOUND(desc,i)
< GFC_DESCRIPTOR_LBOUND(desc,i));
if (GFC_DESCRIPTOR_STRIDE(desc,i) > 0)
*************** init_loop_spec (gfc_array_char *desc, ar
*** 2941,2953 ****
/* Determine the index to the next record in an internal unit array by
by incrementing through the array_loop_spec. */
!
gfc_offset
next_array_record (st_parameter_dt *dtp, array_loop_spec *ls, int *finished)
{
int i, carry;
gfc_offset index;
!
carry = 1;
index = 0;
--- 3158,3170 ----
/* Determine the index to the next record in an internal unit array by
by incrementing through the array_loop_spec. */
!
gfc_offset
next_array_record (st_parameter_dt *dtp, array_loop_spec *ls, int *finished)
{
int i, carry;
gfc_offset index;
!
carry = 1;
index = 0;
*************** skip_record (st_parameter_dt *dtp, ssize
*** 2992,3004 ****
/* Direct access files do not generate END conditions,
only I/O errors. */
! if (sseek (dtp->u.p.current_unit->s,
dtp->u.p.current_unit->bytes_left_subrecord, SEEK_CUR) < 0)
{
/* Seeking failed, fall back to seeking by reading data. */
while (dtp->u.p.current_unit->bytes_left_subrecord > 0)
{
! rlength =
(MAX_READ < dtp->u.p.current_unit->bytes_left_subrecord) ?
MAX_READ : dtp->u.p.current_unit->bytes_left_subrecord;
--- 3209,3221 ----
/* Direct access files do not generate END conditions,
only I/O errors. */
! if (sseek (dtp->u.p.current_unit->s,
dtp->u.p.current_unit->bytes_left_subrecord, SEEK_CUR) < 0)
{
/* Seeking failed, fall back to seeking by reading data. */
while (dtp->u.p.current_unit->bytes_left_subrecord > 0)
{
! rlength =
(MAX_READ < dtp->u.p.current_unit->bytes_left_subrecord) ?
MAX_READ : dtp->u.p.current_unit->bytes_left_subrecord;
*************** next_record_r (st_parameter_dt *dtp, int
*** 3066,3072 ****
/* No records in unformatted STREAM I/O. */
case UNFORMATTED_STREAM:
return;
!
case UNFORMATTED_SEQUENTIAL:
next_record_r_unf (dtp, 1);
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
--- 3283,3289 ----
/* No records in unformatted STREAM I/O. */
case UNFORMATTED_STREAM:
return;
!
case UNFORMATTED_SEQUENTIAL:
next_record_r_unf (dtp, 1);
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
*************** next_record_r (st_parameter_dt *dtp, int
*** 3107,3119 ****
}
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
}
! else
{
bytes_left = (int) dtp->u.p.current_unit->bytes_left;
! bytes_left = min_off (bytes_left,
ssize (dtp->u.p.current_unit->s)
- stell (dtp->u.p.current_unit->s));
! if (sseek (dtp->u.p.current_unit->s,
bytes_left, SEEK_CUR) < 0)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
--- 3324,3336 ----
}
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
}
! else
{
bytes_left = (int) dtp->u.p.current_unit->bytes_left;
! bytes_left = min_off (bytes_left,
ssize (dtp->u.p.current_unit->s)
- stell (dtp->u.p.current_unit->s));
! if (sseek (dtp->u.p.current_unit->s,
bytes_left, SEEK_CUR) < 0)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
*************** next_record_r (st_parameter_dt *dtp, int
*** 3121,3136 ****
}
dtp->u.p.current_unit->bytes_left
= dtp->u.p.current_unit->recl;
! }
break;
}
! else
{
do
{
errno = 0;
cc = fbuf_getc (dtp->u.p.current_unit);
! if (cc == EOF)
{
if (errno != 0)
generate_error (&dtp->common, LIBERROR_OS, NULL);
--- 3338,3353 ----
}
dtp->u.p.current_unit->bytes_left
= dtp->u.p.current_unit->recl;
! }
break;
}
! else
{
do
{
errno = 0;
cc = fbuf_getc (dtp->u.p.current_unit);
! if (cc == EOF)
{
if (errno != 0)
generate_error (&dtp->common, LIBERROR_OS, NULL);
*************** next_record_r (st_parameter_dt *dtp, int
*** 3144,3153 ****
}
break;
}
!
if (is_stream_io (dtp))
dtp->u.p.current_unit->strm_pos++;
!
p = (char) cc;
}
while (p != '\n');
--- 3361,3370 ----
}
break;
}
!
if (is_stream_io (dtp))
dtp->u.p.current_unit->strm_pos++;
!
p = (char) cc;
}
while (p != '\n');
*************** next_record_w_unf (st_parameter_dt *dtp,
*** 3240,3246 ****
/* Seek to the head and overwrite the bogus length with the real
length. */
! if (unlikely (sseek (dtp->u.p.current_unit->s, - m - record_marker,
SEEK_CUR) < 0))
goto io_error;
--- 3457,3463 ----
/* Seek to the head and overwrite the bogus length with the real
length. */
! if (unlikely (sseek (dtp->u.p.current_unit->s, - m - record_marker,
SEEK_CUR) < 0))
goto io_error;
*************** sset (stream * s, int c, ssize_t nbyte)
*** 3301,3307 ****
return trans;
bytes_left -= trans;
}
!
return nbyte - bytes_left;
}
--- 3518,3524 ----
return trans;
bytes_left -= trans;
}
!
return nbyte - bytes_left;
}
*************** next_record_w (st_parameter_dt *dtp, int
*** 3330,3337 ****
fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
fbuf_flush (dtp->u.p.current_unit, WRITING);
! if (sset (dtp->u.p.current_unit->s, ' ',
! dtp->u.p.current_unit->bytes_left)
!= dtp->u.p.current_unit->bytes_left)
goto io_error;
--- 3547,3554 ----
fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
fbuf_flush (dtp->u.p.current_unit, WRITING);
! if (sset (dtp->u.p.current_unit->s, ' ',
! dtp->u.p.current_unit->bytes_left)
!= dtp->u.p.current_unit->bytes_left)
goto io_error;
*************** next_record_w (st_parameter_dt *dtp, int
*** 3362,3368 ****
int finished;
length = (int) dtp->u.p.current_unit->bytes_left;
!
/* If the farthest position reached is greater than current
position, adjust the position and set length to pad out
whats left. Otherwise just pad whats left.
--- 3579,3585 ----
int finished;
length = (int) dtp->u.p.current_unit->bytes_left;
!
/* If the farthest position reached is greater than current
position, adjust the position and set length to pad out
whats left. Otherwise just pad whats left.
*************** next_record_w (st_parameter_dt *dtp, int
*** 3372,3378 ****
if (max_pos > m)
{
length = (int) (max_pos - m);
! if (sseek (dtp->u.p.current_unit->s,
length, SEEK_CUR) < 0)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
--- 3589,3595 ----
if (max_pos > m)
{
length = (int) (max_pos - m);
! if (sseek (dtp->u.p.current_unit->s,
length, SEEK_CUR) < 0)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
*************** next_record_w (st_parameter_dt *dtp, int
*** 3399,3405 ****
&finished);
if (finished)
dtp->u.p.current_unit->endfile = AT_ENDFILE;
!
/* Now seek to this record */
record = record * dtp->u.p.current_unit->recl;
--- 3616,3622 ----
&finished);
if (finished)
dtp->u.p.current_unit->endfile = AT_ENDFILE;
!
/* Now seek to this record */
record = record * dtp->u.p.current_unit->recl;
*************** next_record_w (st_parameter_dt *dtp, int
*** 3425,3431 ****
if (max_pos > m)
{
length = (int) (max_pos - m);
! if (sseek (dtp->u.p.current_unit->s,
length, SEEK_CUR) < 0)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
--- 3642,3648 ----
if (max_pos > m)
{
length = (int) (max_pos - m);
! if (sseek (dtp->u.p.current_unit->s,
length, SEEK_CUR) < 0)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
*************** 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 ----
*************** finalize_transfer (st_parameter_dt *dtp)
*** 3607,3613 ****
write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
tmp = (int)(dtp->u.p.current_unit->recl
- dtp->u.p.current_unit->bytes_left);
! dtp->u.p.max_pos =
dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp;
dtp->u.p.skips = 0;
}
--- 3827,3833 ----
write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
tmp = (int)(dtp->u.p.current_unit->recl
- dtp->u.p.current_unit->bytes_left);
! dtp->u.p.max_pos =
dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp;
dtp->u.p.skips = 0;
}
*************** finalize_transfer (st_parameter_dt *dtp)
*** 3618,3626 ****
fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
goto done;
}
! else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
&& dtp->u.p.mode == WRITING && !is_internal_unit (dtp))
! fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
dtp->u.p.current_unit->saved_pos = 0;
--- 3838,3846 ----
fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
goto done;
}
! else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
&& dtp->u.p.mode == WRITING && !is_internal_unit (dtp))
! fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
dtp->u.p.current_unit->saved_pos = 0;
*************** finalize_transfer (st_parameter_dt *dtp)
*** 3648,3656 ****
data transfer, it just updates the length counter. */
static void
! iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)),
void *dest __attribute__ ((unused)),
! int kind __attribute__((unused)),
size_t size, size_t nelems)
{
if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
--- 3868,3876 ----
data transfer, it just updates the length counter. */
static void
! iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)),
void *dest __attribute__ ((unused)),
! int kind __attribute__((unused)),
size_t size, size_t nelems)
{
if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
*************** void
*** 3722,3728 ****
st_read_done (st_parameter_dt *dtp)
{
finalize_transfer (dtp);
!
if (is_internal_unit (dtp) || dtp->u.p.format_not_saved)
{
free_format_data (dtp->u.p.fmt);
--- 3942,3948 ----
st_read_done (st_parameter_dt *dtp)
{
finalize_transfer (dtp);
!
if (is_internal_unit (dtp) || dtp->u.p.format_not_saved)
{
free_format_data (dtp->u.p.fmt);
*************** st_read_done (st_parameter_dt *dtp)
*** 3735,3741 ****
unlock_unit (dtp->u.p.current_unit);
free_internal_unit (dtp);
!
library_end ();
}
--- 3955,3961 ----
unlock_unit (dtp->u.p.current_unit);
free_internal_unit (dtp);
!
library_end ();
}
*************** st_write_done (st_parameter_dt *dtp)
*** 3759,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. */
--- 3979,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_write_done (st_parameter_dt *dtp)
*** 3773,3779 ****
case NO_ENDFILE:
/* Get rid of whatever is after this record. */
if (!is_internal_unit (dtp))
! unit_truncate (dtp->u.p.current_unit,
stell (dtp->u.p.current_unit->s),
&dtp->common);
dtp->u.p.current_unit->endfile = AT_ENDFILE;
--- 3994,4000 ----
case NO_ENDFILE:
/* Get rid of whatever is after this record. */
if (!is_internal_unit (dtp))
! unit_truncate (dtp->u.p.current_unit,
stell (dtp->u.p.current_unit->s),
&dtp->common);
dtp->u.p.current_unit->endfile = AT_ENDFILE;
*************** st_write_done (st_parameter_dt *dtp)
*** 3790,3796 ****
if (dtp->u.p.current_unit != NULL)
unlock_unit (dtp->u.p.current_unit);
!
free_internal_unit (dtp);
library_end ();
--- 4011,4017 ----
if (dtp->u.p.current_unit != NULL)
unlock_unit (dtp->u.p.current_unit);
!
free_internal_unit (dtp);
library_end ();
*************** 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);
*************** hit_eof (st_parameter_dt * dtp)
*** 3911,3917 ****
else
dtp->u.p.current_unit->endfile = AT_ENDFILE;
break;
!
case AFTER_ENDFILE:
generate_error (&dtp->common, LIBERROR_ENDFILE, NULL);
dtp->u.p.current_unit->current_record = 0;
--- 4135,4141 ----
else
dtp->u.p.current_unit->endfile = AT_ENDFILE;
break;
!
case AFTER_ENDFILE:
generate_error (&dtp->common, LIBERROR_ENDFILE, NULL);
dtp->u.p.current_unit->current_record = 0;
Index: libgfortran/io/unix.c
===================================================================
*** libgfortran/io/unix.c (revision 239525)
--- 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 239525)
--- libgfortran/io/write.c (working copy)
*************** static void
*** 44,50 ****
memcpy4 (gfc_char4_t *dest, const char *source, int k)
{
int j;
!
const char *p = source;
for (j = 0; j < k; j++)
*dest++ = (gfc_char4_t) *p++;
--- 44,50 ----
memcpy4 (gfc_char4_t *dest, const char *source, int k)
{
int j;
!
const char *p = source;
for (j = 0; j < k; j++)
*dest++ = (gfc_char4_t) *p++;
*************** write_default_char4 (st_parameter_dt *dt
*** 63,69 ****
int j, k = 0;
gfc_char4_t c;
uchar d;
!
/* Take care of preceding blanks. */
if (w_len > src_len)
{
--- 63,69 ----
int j, k = 0;
gfc_char4_t c;
uchar d;
!
/* Take care of preceding blanks. */
if (w_len > src_len)
{
*************** write_utf8_char4 (st_parameter_dt *dtp,
*** 153,159 ****
static const uchar masks[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
static const uchar limits[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
int nbytes;
! uchar buf[6], d, *q;
/* Take care of preceding blanks. */
if (w_len > src_len)
--- 153,159 ----
static const uchar masks[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
static const uchar limits[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
int nbytes;
! uchar buf[6], d, *q;
/* Take care of preceding blanks. */
if (w_len > src_len)
*************** write_a (st_parameter_dt *dtp, const fno
*** 273,279 ****
bytes = 0;
}
! /* Write out the CR_LF sequence. */
q++;
p = write_block (dtp, 2);
if (p == NULL)
--- 273,279 ----
bytes = 0;
}
! /* Write out the CR_LF sequence. */
q++;
p = write_block (dtp, 2);
if (p == NULL)
*************** write_a_char4 (st_parameter_dt *dtp, con
*** 381,387 ****
bytes = 0;
}
! /* Write out the CR_LF sequence. */
write_default_char4 (dtp, crlf, 2, 0);
}
else
--- 381,387 ----
bytes = 0;
}
! /* Write out the CR_LF sequence. */
write_default_char4 (dtp, crlf, 2, 0);
}
else
*************** write_l (st_parameter_dt *dtp, const fno
*** 528,534 ****
GFC_INTEGER_LARGEST n;
wlen = (f->format == FMT_G && f->u.w == 0) ? 1 : f->u.w;
!
p = write_block (dtp, wlen);
if (p == NULL)
return;
--- 528,534 ----
GFC_INTEGER_LARGEST n;
wlen = (f->format == FMT_G && f->u.w == 0) ? 1 : f->u.w;
!
p = write_block (dtp, wlen);
if (p == NULL)
return;
*************** write_decimal (st_parameter_dt *dtp, con
*** 694,700 ****
if (n < 0)
n = -n;
nsign = sign == S_NONE ? 0 : 1;
!
/* conv calls itoa which sets the negative sign needed
by write_integer. The sign '+' or '-' is set below based on sign
calculated above, so we just point past the sign in the string
--- 694,700 ----
if (n < 0)
n = -n;
nsign = sign == S_NONE ? 0 : 1;
!
/* conv calls itoa which sets the negative sign needed
by write_integer. The sign '+' or '-' is set below based on sign
calculated above, so we just point past the sign in the string
*************** btoa_big (const char *s, char *buffer, i
*** 847,853 ****
{
char *q;
int i, j;
!
q = buffer;
if (big_endian)
{
--- 847,853 ----
{
char *q;
int i, j;
!
q = buffer;
if (big_endian)
{
*************** btoa_big (const char *s, char *buffer, i
*** 893,899 ****
if (*n == 0)
return "0";
! /* Move past any leading zeros. */
while (*buffer == '0')
buffer++;
--- 893,899 ----
if (*n == 0)
return "0";
! /* Move past any leading zeros. */
while (*buffer == '0')
buffer++;
*************** otoa_big (const char *s, char *buffer, i
*** 968,974 ****
if (*n == 0)
return "0";
! /* Move past any leading zeros. */
while (*q == '0')
q++;
--- 968,974 ----
if (*n == 0)
return "0";
! /* Move past any leading zeros. */
while (*q == '0')
q++;
*************** ztoa_big (const char *s, char *buffer, i
*** 986,994 ****
char *q;
uint8_t h, l;
int i;
!
q = buffer;
!
if (big_endian)
{
const char *p = s;
--- 986,994 ----
char *q;
uint8_t h, l;
int i;
!
q = buffer;
!
if (big_endian)
{
const char *p = s;
*************** ztoa_big (const char *s, char *buffer, i
*** 1021,1031 ****
}
*q = '\0';
!
if (*n == 0)
return "0";
!
! /* Move past any leading zeros. */
while (*buffer == '0')
buffer++;
--- 1021,1031 ----
}
*q = '\0';
!
if (*n == 0)
return "0";
!
! /* Move past any leading zeros. */
while (*buffer == '0')
buffer++;
*************** write_o (st_parameter_dt *dtp, const fno
*** 1067,1073 ****
const char *p;
char itoa_buf[GFC_OTOA_BUF_SIZE];
GFC_UINTEGER_LARGEST n = 0;
!
if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
{
p = otoa_big (source, itoa_buf, len, &n);
--- 1067,1073 ----
const char *p;
char itoa_buf[GFC_OTOA_BUF_SIZE];
GFC_UINTEGER_LARGEST n = 0;
!
if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
{
p = otoa_big (source, itoa_buf, len, &n);
*************** write_float_0 (st_parameter_dt *dtp, con
*** 1407,1418 ****
/* Precision for snprintf call. */
int precision = get_precision (dtp, f, source, kind);
!
/* String buffer to hold final result. */
result = select_string (f, str_buf, &res_len);
!
buffer = select_buffer (precision, buf_stack, &buf_size);
!
get_float_string (dtp, f, source , kind, 0, buffer,
precision, buf_size, result, &res_len);
write_float_string (dtp, result, res_len);
--- 1407,1418 ----
/* Precision for snprintf call. */
int precision = get_precision (dtp, f, source, kind);
!
/* String buffer to hold final result. */
result = select_string (f, str_buf, &res_len);
!
buffer = select_buffer (precision, buf_stack, &buf_size);
!
get_float_string (dtp, f, source , kind, 0, buffer,
precision, buf_size, result, &res_len);
write_float_string (dtp, result, res_len);
*************** write_real (st_parameter_dt *dtp, const
*** 1525,1537 ****
/* Precision for snprintf call. */
int precision = get_precision (dtp, &f, source, kind);
!
/* String buffer to hold final result. */
result = select_string (&f, str_buf, &res_len);
/* scratch buffer to hold final result. */
buffer = select_buffer (precision, buf_stack, &buf_size);
!
get_float_string (dtp, &f, source , kind, 1, buffer,
precision, buf_size, result, &res_len);
write_float_string (dtp, result, res_len);
--- 1525,1537 ----
/* Precision for snprintf call. */
int precision = get_precision (dtp, &f, source, kind);
!
/* String buffer to hold final result. */
result = select_string (&f, str_buf, &res_len);
/* scratch buffer to hold final result. */
buffer = select_buffer (precision, buf_stack, &buf_size);
!
get_float_string (dtp, &f, source , kind, 1, buffer,
precision, buf_size, result, &res_len);
write_float_string (dtp, result, res_len);
*************** write_real_g0 (st_parameter_dt *dtp, con
*** 1554,1560 ****
char str_buf[BUF_STACK_SZ];
char *buffer, *result;
size_t buf_size, res_len;
! int comp_d;
set_fnode_default (dtp, &f, kind);
if (d > 0)
--- 1554,1560 ----
char str_buf[BUF_STACK_SZ];
char *buffer, *result;
size_t buf_size, res_len;
! int comp_d;
set_fnode_default (dtp, &f, kind);
if (d > 0)
*************** write_real_g0 (st_parameter_dt *dtp, con
*** 1570,1576 ****
/* Precision for snprintf call. */
int precision = get_precision (dtp, &f, source, kind);
!
/* String buffer to hold final result. */
result = select_string (&f, str_buf, &res_len);
--- 1570,1576 ----
/* Precision for snprintf call. */
int precision = get_precision (dtp, &f, source, kind);
!
/* String buffer to hold final result. */
result = select_string (&f, str_buf, &res_len);
*************** write_complex (st_parameter_dt *dtp, con
*** 1608,1643 ****
dtp->u.p.scale_factor = 1;
set_fnode_default (dtp, &f, kind);
!
/* Set width for two values, parenthesis, and comma. */
width = 2 * f.u.real.w + 3;
/* Set for no blanks so we get a string result with no leading
blanks. We will pad left later. */
dtp->u.p.g0_no_blanks = 1;
!
/* Precision for snprintf call. */
int precision = get_precision (dtp, &f, source, kind);
!
/* String buffers to hold final result. */
result1 = select_string (&f, str1_buf, &res_len1);
result2 = select_string (&f, str2_buf, &res_len2);
buffer = select_buffer (precision, buf_stack, &buf_size);
!
get_float_string (dtp, &f, source , kind, 0, buffer,
precision, buf_size, result1, &res_len1);
get_float_string (dtp, &f, source + size / 2 , kind, 0, buffer,
precision, buf_size, result2, &res_len2);
lblanks = width - res_len1 - res_len2 - 3;
!
write_x (dtp, lblanks, lblanks);
write_char (dtp, '(');
write_float_string (dtp, result1, res_len1);
write_char (dtp, semi_comma);
write_float_string (dtp, result2, res_len2);
write_char (dtp, ')');
!
dtp->u.p.scale_factor = orig_scale;
dtp->u.p.g0_no_blanks = 0;
if (buf_size > BUF_STACK_SZ)
--- 1608,1643 ----
dtp->u.p.scale_factor = 1;
set_fnode_default (dtp, &f, kind);
!
/* Set width for two values, parenthesis, and comma. */
width = 2 * f.u.real.w + 3;
/* Set for no blanks so we get a string result with no leading
blanks. We will pad left later. */
dtp->u.p.g0_no_blanks = 1;
!
/* Precision for snprintf call. */
int precision = get_precision (dtp, &f, source, kind);
!
/* String buffers to hold final result. */
result1 = select_string (&f, str1_buf, &res_len1);
result2 = select_string (&f, str2_buf, &res_len2);
buffer = select_buffer (precision, buf_stack, &buf_size);
!
get_float_string (dtp, &f, source , kind, 0, buffer,
precision, buf_size, result1, &res_len1);
get_float_string (dtp, &f, source + size / 2 , kind, 0, buffer,
precision, buf_size, result2, &res_len2);
lblanks = width - res_len1 - res_len2 - 3;
!
write_x (dtp, lblanks, lblanks);
write_char (dtp, '(');
write_float_string (dtp, result1, res_len1);
write_char (dtp, semi_comma);
write_float_string (dtp, result2, res_len2);
write_char (dtp, ')');
!
dtp->u.p.scale_factor = orig_scale;
dtp->u.p.g0_no_blanks = 0;
if (buf_size > BUF_STACK_SZ)
*************** 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
*** 1844,1850 ****
size_t base_name_len;
size_t base_var_name_len;
size_t tot_len;
!
/* Set the character to be used to separate values
to a comma or semi-colon. */
--- 1884,1890 ----
size_t base_name_len;
size_t base_var_name_len;
size_t tot_len;
!
/* Set the character to be used to separate values
to a comma or semi-colon. */
*************** nml_write_obj (st_parameter_dt *dtp, nam
*** 1903,1909 ****
break;
default:
! obj_size = len;
}
if (obj->var_rank)
--- 1943,1949 ----
break;
default:
! obj_size = len;
}
if (obj->var_rank)
*************** 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,2013 ****
components. */
/* First ext_name => get length of all possible components */
base_name_len = base_name ? strlen (base_name) : 0;
base_var_name_len = base ? strlen (base->var_name) : 0;
! ext_name_len = base_name_len + base_var_name_len
+ strlen (obj->var_name) + obj->var_rank * NML_DIGITS + 1;
ext_name = xmalloc (ext_name_len);
if (base_name)
memcpy (ext_name, base_name, base_name_len);
clen = strlen (obj->var_name + base_var_name_len);
! memcpy (ext_name + base_name_len,
obj->var_name + base_var_name_len, clen);
!
/* Append the qualifier. */
tot_len = base_name_len + clen;
--- 2035,2099 ----
components. */
/* First ext_name => get length of all possible components */
+ if (obj->dtio_sub != NULL)
+ {
+ int unit = dtp->u.p.current_unit->unit_number;
+ char iotype[] = "NAMELIST";
+ gfc_charlen_type iotype_len = 8;
+ char tmp_iomsg[IOMSG_LEN] = "";
+ char *child_iomsg;
+ gfc_charlen_type child_iomsg_len;
+ int noiostat;
+ int *child_iostat = NULL;
+ gfc_array_i4 vlist;
+ gfc_class list_obj;
+ formatted_dtio dtio_ptr = (formatted_dtio)obj->dtio_sub;
+
+ GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
+
+ list_obj.data = p;
+ list_obj.vptr = obj->vtable;
+ list_obj.len = 0;
+
+ /* Set iostat, intent(out). */
+ noiostat = 0;
+ child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
+ dtp->common.iostat : &noiostat;
+
+ /* Set iomsg, intent(inout). */
+ if (dtp->common.flags & IOPARM_HAS_IOMSG)
+ {
+ child_iomsg = dtp->common.iomsg;
+ child_iomsg_len = dtp->common.iomsg_len;
+ }
+ else
+ {
+ child_iomsg = tmp_iomsg;
+ child_iomsg_len = IOMSG_LEN;
+ }
+ namelist_write_newline (dtp);
+ /* Call the user defined formatted WRITE procedure. */
+ dtp->u.p.current_unit->child_dtio++;
+ dtio_ptr ((void *)&list_obj, &unit, iotype, &vlist,
+ child_iostat, child_iomsg,
+ iotype_len, child_iomsg_len);
+ dtp->u.p.current_unit->child_dtio--;
+
+ goto obj_loop;
+ }
base_name_len = base_name ? strlen (base_name) : 0;
base_var_name_len = base ? strlen (base->var_name) : 0;
! ext_name_len = base_name_len + base_var_name_len
+ strlen (obj->var_name) + obj->var_rank * NML_DIGITS + 1;
ext_name = xmalloc (ext_name_len);
if (base_name)
memcpy (ext_name, base_name, base_name_len);
clen = strlen (obj->var_name + base_var_name_len);
! memcpy (ext_name + base_name_len,
obj->var_name + base_var_name_len, clen);
!
/* Append the qualifier. */
tot_len = base_name_len + clen;
*************** nml_write_obj (st_parameter_dt *dtp, nam
*** 2018,2024 ****
ext_name[tot_len] = '(';
tot_len++;
}
! snprintf (ext_name + tot_len, ext_name_len - tot_len, "%d",
(int) obj->ls[dim_i].idx);
tot_len += strlen (ext_name + tot_len);
ext_name[tot_len] = ((int) dim_i == obj->var_rank - 1) ? ')' : ',';
--- 2104,2110 ----
ext_name[tot_len] = '(';
tot_len++;
}
! snprintf (ext_name + tot_len, ext_name_len - tot_len, "%d",
(int) obj->ls[dim_i].idx);
tot_len += strlen (ext_name + tot_len);
ext_name[tot_len] = ((int) dim_i == obj->var_rank - 1) ? ')' : ',';
More information about the Gcc-patches
mailing list