* Ping : [Patch, fortran] PR48298 - [F03] User-Defined Derived-Type IO (DTIO)
@ 2016-08-27 18:50 Paul Richard Thomas
2016-08-27 20:15 ` Janne Blomqvist
2016-08-30 10:58 ` Paul Richard Thomas
0 siblings, 2 replies; 10+ messages in thread
From: Paul Richard Thomas @ 2016-08-27 18:50 UTC (permalink / raw)
To: fortran, gcc-patches
Cc: jerry DeLisle, Damian Rouson, Ian Chivers, Jane Sleightholme
[-- Attachment #1: Type: text/plain, Size: 7481 bytes --]
Dear All,
Please find attached the complete patch for DTIO, including the fix
for the mutex_lock problem and all the testcases.
Although we have said that we would commit on Monday if no review is
forthcoming, we would very much prefer that somebody takes a look. We
understand perfectly that a 4052 line patch is rather daunting.
However, even a cursory scan of the patch would be helpful.
Many thanks to Dominique for giving the patch a whirl. This almost
certainly helped keep our blood pressure more or less level :-)
Best regards
Paul and Jerry
On 22 August 2016 at 14:32, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
> Dear All,
>
> The attached patch implements the above DTIO feature. This is the
> penultimate F2003 feature to be implemented in gfortran. (The last is
> Parameterized Derived-Types, which look to be difficult to judge by
> the remarks coming from other vendors).
>
> Although fairly long, the patch is straightforward. It includes some
> whitespace corrections, which are not remarked upon in the ChangeLogs.
>
> There are four known issues, for which PRs will be raised:
> 1) DTIO to internal units is not implemented;
> 2) Inquire length is not implemented;
> 3) Size = in READ statements is not implemented; and
> 4) There is a mystery optimization bug, at all levels of optimization,
> which causes IF statements to disappear in some of the testcases. This
> has been masked by the chunk in trans-decl.c that forces derived-type
> and class objects with associated DTIO procedures to be TREE_STATIC.
>
> The testcases dtio_[3,4].f90 are on their way. We had set ourselves
> the target of today to submit but the issue #4 derailed the
> preparation of these testcases. These will be posted as soon as
> possible.
>
> Bootstrapped and regtested on FC21/x86_64 - OK for trunk?
>
> Given that DTIO is only triggered by the specific typebound or generic
> interfaces, we intend to commit the patch in one week from today if no
> review is forthcoming.
>
> Paul and Jerry
>
> 2016-08-22 Paul Thomas <pault@gcc.gnu.org>
> Jerry DeLisle <jvdelisle@gcc.gnu.org>
>
> PR fortran/48298
>
> * decl.c (access_attr_decl): Include case INTERFACE_DTIO as
> appropriate.
> * gfortran.h : Add INTRINSIC_FORMATTED and
> INTRINSIC_UNFORMATTED to gfc_intrinsic_op. Add INTERFACE_DTIO
> to interface type. Add new enum 'dtio_codes'. Add bitfield
> 'has_dtio_procs' to symbol_attr. Add prototypes
> 'gfc_check_dtio_interfaces' and 'gfc_find_specific_dtio_proc'.
> * interface.c (dtio_op): New function.
> (gfc_match_generic_spec): Match generic DTIO interfaces.
> (gfc_match_interface): Treat DTIO interfaces in the same way as
> (gfc_current_interface_head): Add INTERFACE_DTIO appropriately.
> (check_dtio_arg_TKR_intent): New function.
> (check_dtio_interface1): New function.
> (gfc_check_dtio_interfaces): New function.
> (gfc_find_specific_dtio_proc): New function.
> * io.c : Add FMT_DT to format_token.
> (format_lex): Handle DTIO formatting.
> * match.c (gfc_op2string): Add DTIO operators.
> * resolve.c (derived_inaccessible): Ignore pointer components
> to enclosing derived type.
> (resolve_transfer): Resolve transfers that involve DTIO.
> procedures. Find the specific subroutine for the transfer and
> use its existence to over-ride some of the constraints on
> derived types.
> (dtio_procs_present): New function.
> (resolve_fl_namelist): Remove inhibition of polymorphic objects
> in namelists if DTIO read and write subroutines exist. Likewise
> for derived types.
> (resolve_types): Invoke 'gfc_verify_dtio_procedures'.
> * symbol.c : Set 'dtio_procs' using 'minit'.
> * trans-decl.c (gfc_finish_var_decl): If a derived-type/class
> object is associated with DTIO procedures, make it TREE_STATIC.
> * trans-expr.c (gfc_conv_derived_to_class): Check 'info' in the
> test for 'useflags'. If the se expression exists and is a
> pointer, use it as the class _data.
> * trans-io.c : Add IOCALL_X_DERIVED to iocall and the function
> prototype. Add two new arguments to IOCALL_SET_NML_VAL.
> (set_parameter_tree): Renamed from 'set_parameter_const', now
> returns void and has new tree argument. Calls modified to match
> new interface.
> (transfer_namelist_element): Transfer DTIO procedure pointer
> and the table to the vpointer, using the two new arguments of
> IOCALL_SET_NML_VAL.
> (get_dtio_proc): New function.
> (transfer_expr): Add new argument for the vptr field of class
> objects. Add the code to call the specific DTIO proc, convert
> derived types to class and call IOCALL_X_DERIVED.
> (trans_transfer): Add BT_CLASS to structures for treatment by
> the scalarizer. Obtain the vptr for the dynamic type, both for
> scalar and array transfer.
>
> 2016-08-22 Jerry DeLisle <jvdelisle@gcc.gnu.org>
> Paul Thomas <pault@gcc.gnu.org>
>
> PR libgfortran/48298
> * gfortran.map : Flag _gfortran_transfer_derived.
> * io/format.c (format_lex): Detect DTIO formatting.
> (parse_format_list): Parse the DTIO format.
> (next_format): Include FMT_DT.
> * io/format.h : Likewise. Add structure 'udf' to structure
> 'fnode' to carry the IOTYPE string and the 'vlist'.
> * io/io.h : Add prototypes for the two types of DTIO subroutine
> and a typedef for gfc_class. Also, add to 'namelist_type'
> fields for the pointer to the DTIO procedure and the vtable.
> Add fields to struct st_parameter_dt for pointers to the two
> types of DTIO subroutine. Add to gfc_unit DTIO specific fields.
> (internal_proto): Add prototype for 'read_user_defined' and
> 'write_user_defined'.
> * io/list_read.c (check_buffers): Use the 'current_unit' field.
> (unget_char): Likewise.
> (eat_spaces): Likewise.
> (list_formatted_read_scalar): For case BT_CLASS, call the DTIO
> procedure.
> (nml_get_obj_data): Likewise when DTIO procedure is present.
> * io/transfer.c : Export prototypes for 'transfer_derived' and
> 'transfer_derived_write'.
> (unformatted_read): For case BT_CLASS, call the DTIO procedure.
> (unformatted_write): Likewise.
> (formatted_transfer_scalar_read): Likewise.
> (formatted_transfer_scalar_write: Likewise.
> (transfer_derived): New function.
> (data_transfer_init): Set last_char if no child_dtio.
> (finalize_transfer): Return if child_dtio set.
> (st_write_done): Add condition for child_dtio not set.
> Add extra arguments for st_set_nml_var prototype.
> (st_set_nml_var): Set the 'dtio_sub' and 'vtable' fields of the
> 'nml' structure.
> * io/unix.c (tempfile_open): Revert to C style comment.
> * io/write.c (list_formatted_write_scalar): Do the DTIO call.
> (nml_write_obj): Add BT_CLASS and do the DTIO call.
>
> 2016-08-22 Jerry DeLisle <jvdelisle@gcc.gnu.org>
> Paul Thomas <pault@gcc.gnu.org>
>
> PR fortran/48298
> * gfortran.dg/dtio_1.f90: New test.
> * gfortran.dg/dtio_2.f90: New test.
> * gfortran.dg/dtio_5.f90: New test.
> * gfortran.dg/dtio_6.f90: New test.
> * gfortran.dg/dtio_7.f90: New test.
> * gfortran.dg/dtio_8.f90: New test.
> * gfortran.dg/dtio_9.f90: New test.
> * gfortran.dg/dtio_10.f90: New test.
--
The difference between genius and stupidity is; genius has its limits.
Albert Einstein
[-- Attachment #2: submit2.diff --]
[-- Type: text/plain, Size: 124658 bytes --]
Index: gcc/fortran/decl.c
===================================================================
*** gcc/fortran/decl.c (revision 239769)
--- gcc/fortran/decl.c (working copy)
*************** access_attr_decl (gfc_statement st)
*** 7469,7474 ****
--- 7469,7475 ----
goto syntax;
case INTERFACE_GENERIC:
+ case INTERFACE_DTIO:
if (gfc_get_symbol (name, NULL, &sym))
goto done;
*************** gfc_match_generic (void)
*** 9378,9383 ****
--- 9379,9385 ----
switch (op_type)
{
case INTERFACE_GENERIC:
+ case INTERFACE_DTIO:
snprintf (bind_name, sizeof (bind_name), "%s", name);
break;
*************** gfc_match_generic (void)
*** 9413,9418 ****
--- 9415,9421 ----
switch (op_type)
{
+ case INTERFACE_DTIO:
case INTERFACE_USER_OP:
case INTERFACE_GENERIC:
{
*************** gfc_match_generic (void)
*** 9467,9472 ****
--- 9470,9476 ----
switch (op_type)
{
+ case INTERFACE_DTIO:
case INTERFACE_GENERIC:
case INTERFACE_USER_OP:
{
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 239769)
--- gcc/fortran/gfortran.h (working copy)
*************** enum gfc_intrinsic_op
*** 177,184 ****
/* .EQ., .NE., .GT., .GE., .LT., .LE. (OS = Old-Style) */
INTRINSIC_EQ_OS, INTRINSIC_NE_OS, INTRINSIC_GT_OS, INTRINSIC_GE_OS,
INTRINSIC_LT_OS, INTRINSIC_LE_OS,
! INTRINSIC_NOT, INTRINSIC_USER, INTRINSIC_ASSIGN,
! INTRINSIC_PARENTHESES, GFC_INTRINSIC_END /* Sentinel */
};
/* This macro is the number of intrinsic operators that exist.
--- 177,186 ----
/* .EQ., .NE., .GT., .GE., .LT., .LE. (OS = Old-Style) */
INTRINSIC_EQ_OS, INTRINSIC_NE_OS, INTRINSIC_GT_OS, INTRINSIC_GE_OS,
INTRINSIC_LT_OS, INTRINSIC_LE_OS,
! INTRINSIC_NOT, INTRINSIC_USER, INTRINSIC_ASSIGN, INTRINSIC_PARENTHESES,
! /* User defined derived type pseudo operator. */
! INTRINSIC_FORMATTED, INTRINSIC_UNFORMATTED,
! GFC_INTRINSIC_END /* Sentinel */
};
/* This macro is the number of intrinsic operators that exist.
*************** enum gfc_statement
*** 261,267 ****
enum interface_type
{
INTERFACE_NAMELESS = 1, INTERFACE_GENERIC,
! INTERFACE_INTRINSIC_OP, INTERFACE_USER_OP, INTERFACE_ABSTRACT
};
/* Symbol flavors: these are all mutually exclusive.
--- 263,270 ----
enum interface_type
{
INTERFACE_NAMELESS = 1, INTERFACE_GENERIC,
! INTERFACE_INTRINSIC_OP, INTERFACE_USER_OP, INTERFACE_ABSTRACT,
! INTERFACE_DTIO
};
/* Symbol flavors: these are all mutually exclusive.
*************** extern const mstring access_types[];
*** 313,318 ****
--- 316,327 ----
extern const mstring ifsrc_types[];
extern const mstring save_status[];
+ /* Strings for DTIO procedure names. In symbol.c. */
+ extern const mstring dtio_procs[];
+
+ enum dtio_codes
+ { DTIO_RF = 0, DTIO_WF, DTIO_RUF, DTIO_WUF };
+
/* Enumeration of all the generic intrinsic functions. Used by the
backend for identification of a function. */
*************** typedef struct
*** 841,847 ****
entities. */
unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1,
private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1,
! event_comp:1, defined_assign_comp:1, unlimited_polymorphic:1;
/* This is a temporary selector for SELECT TYPE or an associate
variable for SELECT_TYPE or ASSOCIATE. */
--- 850,857 ----
entities. */
unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1,
private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1,
! event_comp:1, defined_assign_comp:1, unlimited_polymorphic:1,
! has_dtio_procs:1;
/* This is a temporary selector for SELECT TYPE or an associate
variable for SELECT_TYPE or ASSOCIATE. */
*************** bool gfc_check_operator_interface (gfc_s
*** 3170,3175 ****
--- 3180,3188 ----
int gfc_has_vector_subscript (gfc_expr*);
gfc_intrinsic_op gfc_equivalent_op (gfc_intrinsic_op);
bool gfc_check_typebound_override (gfc_symtree*, gfc_symtree*);
+ void gfc_check_dtio_interfaces (gfc_symbol*);
+ gfc_symbol* gfc_find_specific_dtio_proc (gfc_symbol*, bool, bool);
+
/* io.c */
extern gfc_st_label format_asterisk;
Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c (revision 239769)
--- gcc/fortran/interface.c (working copy)
*************** fold_unary_intrinsic (gfc_intrinsic_op o
*** 115,120 ****
--- 115,133 ----
}
+ /* Return the operator depending on the DTIO moded string. */
+
+ static gfc_intrinsic_op
+ dtio_op (char* mode)
+ {
+ if (strncmp (mode, "formatted", 9) == 0)
+ return INTRINSIC_FORMATTED;
+ if (strncmp (mode, "unformatted", 9) == 0)
+ return INTRINSIC_UNFORMATTED;
+ return INTRINSIC_NONE;
+ }
+
+
/* Match a generic specification. Depending on which type of
interface is found, the 'name' or 'op' pointers may be set.
This subroutine doesn't return MATCH_NO. */
*************** gfc_match_generic_spec (interface_type *
*** 162,167 ****
--- 175,214 ----
return MATCH_YES;
}
+ if (gfc_match (" read ( %n )", buffer) == MATCH_YES)
+ {
+ *op = dtio_op (buffer);
+ if (*op == INTRINSIC_FORMATTED)
+ {
+ strcpy (name, gfc_code2string (dtio_procs, DTIO_RF));
+ *type = INTERFACE_DTIO;
+ }
+ if (*op == INTRINSIC_UNFORMATTED)
+ {
+ strcpy (name, gfc_code2string (dtio_procs, DTIO_RUF));
+ *type = INTERFACE_DTIO;
+ }
+ if (*op != INTRINSIC_NONE)
+ return MATCH_YES;
+ }
+
+ if (gfc_match (" write ( %n )", buffer) == MATCH_YES)
+ {
+ *op = dtio_op (buffer);
+ if (*op == INTRINSIC_FORMATTED)
+ {
+ strcpy (name, gfc_code2string (dtio_procs, DTIO_WF));
+ *type = INTERFACE_DTIO;
+ }
+ if (*op == INTRINSIC_UNFORMATTED)
+ {
+ strcpy (name, gfc_code2string (dtio_procs, DTIO_WUF));
+ *type = INTERFACE_DTIO;
+ }
+ if (*op != INTRINSIC_NONE)
+ return MATCH_YES;
+ }
+
if (gfc_match_name (buffer) == MATCH_YES)
{
strcpy (name, buffer);
*************** gfc_match_interface (void)
*** 209,214 ****
--- 256,262 ----
switch (type)
{
+ case INTERFACE_DTIO:
case INTERFACE_GENERIC:
if (gfc_get_symbol (name, NULL, &sym))
return MATCH_ERROR;
*************** gfc_match_end_interface (void)
*** 371,376 ****
--- 419,425 ----
break;
+ case INTERFACE_DTIO:
case INTERFACE_GENERIC:
if (type != current_interface.type
|| strcmp (current_interface.sym->name, name) != 0)
*************** gfc_add_interface (gfc_symbol *new_sym)
*** 4198,4203 ****
--- 4247,4253 ----
break;
case INTERFACE_GENERIC:
+ case INTERFACE_DTIO:
for (ns = current_interface.ns; ns; ns = ns->parent)
{
gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
*************** gfc_current_interface_head (void)
*** 4245,4250 ****
--- 4295,4301 ----
break;
case INTERFACE_GENERIC:
+ case INTERFACE_DTIO:
return current_interface.sym->generic;
break;
*************** gfc_set_current_interface_head (gfc_inte
*** 4268,4273 ****
--- 4319,4325 ----
break;
case INTERFACE_GENERIC:
+ case INTERFACE_DTIO:
current_interface.sym->generic = i;
break;
*************** gfc_check_typebound_override (gfc_symtre
*** 4484,4486 ****
--- 4536,4839 ----
return true;
}
+
+
+ /* The following three functions check that the formal arguments
+ of user defined derived type IO procedures are compliant with
+ the requirements of the standard. */
+
+ static void
+ check_dtio_arg_TKR_intent (gfc_symbol *fsym, bool typebound, bt type,
+ int kind, int rank, sym_intent intent)
+ {
+ if (fsym->ts.type != type)
+ gfc_error ("DTIO dummy argument at %L must be of type %s",
+ &fsym->declared_at, gfc_basic_typename (type));
+
+ if (fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED
+ && fsym->ts.kind != kind)
+ gfc_error ("DTIO dummy argument at %L must be of KIND = %d",
+ &fsym->declared_at, kind);
+
+ if (!typebound
+ && rank == 0
+ && (((type == BT_CLASS) && CLASS_DATA (fsym)->attr.dimension)
+ || ((type != BT_CLASS) && fsym->attr.dimension)))
+ gfc_error ("DTIO dummy argument at %L be a scalar",
+ &fsym->declared_at);
+ else if (rank == 1
+ && (fsym->as == NULL || fsym->as->type != AS_ASSUMED_SHAPE))
+ gfc_error ("DTIO dummy argument at %L must be an "
+ "ASSUMED SHAPE ARRAY", &fsym->declared_at);
+
+ if (fsym->attr.intent != intent)
+ gfc_error ("DTIO dummy argument at %L must have intent %s",
+ &fsym->declared_at, gfc_code2string (intents, (int)intent));
+ return;
+ }
+
+
+ static void
+ check_dtio_interface1 (gfc_symbol *derived, gfc_symtree *tb_io_st,
+ bool typebound, bool formatted, int code)
+ {
+ gfc_symbol *dtio_sub, *generic_proc, *fsym;
+ gfc_typebound_proc *tb_io_proc, *specific_proc;
+ gfc_interface *intr;
+ gfc_formal_arglist *formal;
+ int arg_num;
+
+ bool read = ((dtio_codes)code == DTIO_RF)
+ || ((dtio_codes)code == DTIO_RUF);
+ bt type;
+ sym_intent intent;
+ int kind;
+
+ dtio_sub = NULL;
+ if (typebound)
+ {
+ /* Typebound DTIO binding. */
+ tb_io_proc = tb_io_st->n.tb;
+ gcc_assert (tb_io_proc != NULL);
+ gcc_assert (tb_io_proc->is_generic);
+ gcc_assert (tb_io_proc->u.generic->next == NULL);
+
+ specific_proc = tb_io_proc->u.generic->specific;
+ gcc_assert (!specific_proc->is_generic);
+
+ dtio_sub = specific_proc->u.specific->n.sym;
+ }
+ else
+ {
+ generic_proc = tb_io_st->n.sym;
+ gcc_assert (generic_proc);
+ gcc_assert (generic_proc->generic);
+
+ for (intr = tb_io_st->n.sym->generic; intr; intr = intr->next)
+ {
+ if (intr->sym && intr->sym->formal
+ && ((intr->sym->formal->sym->ts.type == BT_CLASS
+ && CLASS_DATA (intr->sym->formal->sym)->ts.u.derived
+ == derived)
+ || (intr->sym->formal->sym->ts.type == BT_DERIVED
+ && intr->sym->formal->sym->ts.u.derived == derived)))
+ dtio_sub = intr->sym;
+ }
+
+ if (dtio_sub == NULL)
+ return;
+ }
+
+ gcc_assert (dtio_sub);
+ if (!dtio_sub->attr.subroutine)
+ gfc_error ("DTIO procedure %s at %L must be a subroutine",
+ dtio_sub->name, &dtio_sub->declared_at);
+
+ /* Now go through the formal arglist. */
+ arg_num = 1;
+ for (formal = dtio_sub->formal; formal; formal = formal->next, arg_num++)
+ {
+ if (!formatted && arg_num == 3)
+ arg_num = 5;
+ fsym = formal->sym;
+ switch (arg_num)
+ {
+ case(1): /* DTV */
+ type = derived->attr.sequence || derived->attr.is_bind_c ?
+ BT_DERIVED : BT_CLASS;
+ kind = 0;
+ intent = read ? INTENT_INOUT : INTENT_IN;
+ check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+ 0, intent);
+ break;
+
+ case(2): /* UNIT */
+ type = BT_INTEGER;
+ kind = gfc_default_integer_kind;
+ intent = INTENT_IN;
+ check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+ 0, intent);
+ break;
+ case(3): /* IOTYPE */
+ type = BT_CHARACTER;
+ kind = gfc_default_character_kind;
+ intent = INTENT_IN;
+ check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+ 0, intent);
+ break;
+ case(4): /* VLIST */
+ type = BT_INTEGER;
+ kind = gfc_default_integer_kind;
+ intent = INTENT_IN;
+ check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+ 1, intent);
+ break;
+ case(5): /* IOSTAT */
+ type = BT_INTEGER;
+ kind = gfc_default_integer_kind;
+ intent = INTENT_OUT;
+ check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+ 0, intent);
+ break;
+ case(6): /* IOMSG */
+ type = BT_CHARACTER;
+ kind = gfc_default_character_kind;
+ intent = INTENT_INOUT;
+ check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
+ 0, intent);
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ }
+ derived->attr.has_dtio_procs = 1;
+ return;
+ }
+
+ void
+ gfc_check_dtio_interfaces (gfc_symbol *derived)
+ {
+ gfc_symtree *tb_io_st;
+ bool t = false;
+ int code;
+ bool formatted;
+
+ if (derived->attr.is_class == 1 || derived->attr.vtype == 1)
+ return;
+
+ /* Check typebound DTIO bindings. */
+ for (code = 0; code < 4; code++)
+ {
+ formatted = ((dtio_codes)code == DTIO_RF)
+ || ((dtio_codes)code == DTIO_WF);
+
+ tb_io_st = gfc_find_typebound_proc (derived, &t,
+ gfc_code2string (dtio_procs, code),
+ true, &derived->declared_at);
+ if (tb_io_st != NULL)
+ check_dtio_interface1 (derived, tb_io_st, true, formatted, code);
+ }
+
+ /* Check generic DTIO interfaces. */
+ for (code = 0; code < 4; code++)
+ {
+ formatted = ((dtio_codes)code == DTIO_RF)
+ || ((dtio_codes)code == DTIO_WF);
+
+ tb_io_st = gfc_find_symtree (derived->ns->sym_root,
+ gfc_code2string (dtio_procs, code));
+ if (tb_io_st != NULL)
+ check_dtio_interface1 (derived, tb_io_st, false, formatted, code);
+ }
+ }
+
+
+ gfc_symbol *
+ gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted)
+ {
+ gfc_symtree *tb_io_st = NULL;
+ gfc_symbol *dtio_sub = NULL;
+ gfc_symbol *extended;
+ gfc_typebound_proc *tb_io_proc, *specific_proc;
+ bool t = false;
+
+ /* Try to find a typebound DTIO binding. */
+ if (formatted == true)
+ {
+ if (write == true)
+ tb_io_st = gfc_find_typebound_proc (derived, &t,
+ gfc_code2string (dtio_procs,
+ DTIO_WF),
+ true,
+ &derived->declared_at);
+ else
+ tb_io_st = gfc_find_typebound_proc (derived, &t,
+ gfc_code2string (dtio_procs,
+ DTIO_RF),
+ true,
+ &derived->declared_at);
+ }
+ else
+ {
+ if (write == true)
+ tb_io_st = gfc_find_typebound_proc (derived, &t,
+ gfc_code2string (dtio_procs,
+ DTIO_WUF),
+ true,
+ &derived->declared_at);
+ else
+ tb_io_st = gfc_find_typebound_proc (derived, &t,
+ gfc_code2string (dtio_procs,
+ DTIO_RUF),
+ true,
+ &derived->declared_at);
+ }
+
+ if (tb_io_st != NULL)
+ {
+ tb_io_proc = tb_io_st->n.tb;
+ gcc_assert (tb_io_proc != NULL);
+ gcc_assert (tb_io_proc->is_generic);
+ gcc_assert (tb_io_proc->u.generic->next == NULL);
+
+ specific_proc = tb_io_proc->u.generic->specific;
+ gcc_assert (!specific_proc->is_generic);
+
+ dtio_sub = specific_proc->u.specific->n.sym;
+ }
+
+ if (tb_io_st != NULL)
+ goto finish;
+
+ /* If there is not a typebound binding, look for a generic
+ DTIO interface. */
+ for (extended = derived; extended;
+ extended = gfc_get_derived_super_type (extended))
+ {
+ if (formatted == true)
+ {
+ if (write == true)
+ tb_io_st = gfc_find_symtree (extended->ns->sym_root,
+ gfc_code2string (dtio_procs,
+ DTIO_WF));
+ else
+ tb_io_st = gfc_find_symtree (extended->ns->sym_root,
+ gfc_code2string (dtio_procs,
+ DTIO_RF));
+ }
+ else
+ {
+ if (write == true)
+ tb_io_st = gfc_find_symtree (extended->ns->sym_root,
+ gfc_code2string (dtio_procs,
+ DTIO_WUF));
+ else
+ tb_io_st = gfc_find_symtree (extended->ns->sym_root,
+ gfc_code2string (dtio_procs,
+ DTIO_RUF));
+ }
+
+ if (tb_io_st != NULL
+ && tb_io_st->n.sym
+ && tb_io_st->n.sym->generic)
+ {
+ gfc_interface *intr;
+ for (intr = tb_io_st->n.sym->generic; intr; intr = intr->next)
+ {
+ gfc_symbol *fsym = intr->sym->formal->sym;
+ if (intr->sym && intr->sym->formal
+ && ((fsym->ts.type == BT_CLASS
+ && CLASS_DATA (fsym)->ts.u.derived == extended)
+ || (fsym->ts.type == BT_DERIVED
+ && fsym->ts.u.derived == extended)))
+ dtio_sub = intr->sym;
+ }
+ }
+ }
+
+ finish:
+ if (dtio_sub && derived != CLASS_DATA (dtio_sub->formal->sym)->ts.u.derived)
+ gfc_find_derived_vtab (derived);
+
+ return dtio_sub;
+ }
Index: gcc/fortran/io.c
===================================================================
*** gcc/fortran/io.c (revision 239769)
--- gcc/fortran/io.c (working copy)
*************** enum format_token
*** 113,119 ****
FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F,
FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END,
FMT_ERROR, FMT_DC, FMT_DP, FMT_T, FMT_TR, FMT_TL, FMT_STAR, FMT_RC,
! FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ
};
/* Local variables for checking format strings. The saved_token is
--- 113,119 ----
FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F,
FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END,
FMT_ERROR, FMT_DC, FMT_DP, FMT_T, FMT_TR, FMT_TL, FMT_STAR, FMT_RC,
! FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT
};
/* Local variables for checking format strings. The saved_token is
*************** format_lex (void)
*** 463,468 ****
--- 463,506 ----
return FMT_ERROR;
token = FMT_DC;
}
+ else if (c == 'T')
+ {
+ if (!gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DT format "
+ "specifier not allowed at %C"))
+ return FMT_ERROR;
+ token = FMT_DT;
+ c = next_char_not_space (&error);
+ if (c == '\'' || c == '"')
+ {
+ delim = c;
+ value = 0;
+
+ for (;;)
+ {
+ c = next_char (INSTRING_WARN);
+ if (c == '\0')
+ {
+ token = FMT_END;
+ break;
+ }
+
+ if (c == delim)
+ {
+ c = next_char (NONSTRING);
+
+ if (c == '\0')
+ {
+ token = FMT_END;
+ break;
+ }
+ unget_char ();
+ break;
+ }
+ }
+ }
+ else
+ unget_char ();
+ }
else
{
token = FMT_D;
*************** format_item_1:
*** 652,657 ****
--- 690,743 ----
return false;
goto between_desc;
+ case FMT_DT:
+ t = format_lex ();
+ if (t == FMT_ERROR)
+ goto fail;
+ switch (t)
+ {
+ case FMT_RPAREN:
+ level--;
+ if (level < 0)
+ goto finished;
+ goto between_desc;
+
+ case FMT_COMMA:
+ goto format_item;
+
+ case FMT_LPAREN:
+
+ dtio_vlist:
+ t = format_lex ();
+ if (t == FMT_ERROR)
+ goto fail;
+
+ if (t != FMT_POSINT)
+ {
+ error = posint_required;
+ goto syntax;
+ }
+
+ t = format_lex ();
+ if (t == FMT_ERROR)
+ goto fail;
+
+ if (t == FMT_COMMA)
+ goto dtio_vlist;
+ if (t != FMT_RPAREN)
+ {
+ error = _("Right parenthesis expected at %C");
+ goto syntax;
+ }
+ goto between_desc;
+
+ default:
+ error = unexpected_element;
+ goto syntax;
+ }
+
+ goto format_item;
+
case FMT_SIGN:
case FMT_BLANK:
case FMT_DP:
Index: gcc/fortran/match.c
===================================================================
*** gcc/fortran/match.c (revision 239769)
--- gcc/fortran/match.c (working copy)
*************** gfc_op2string (gfc_intrinsic_op op)
*** 102,107 ****
--- 102,113 ----
case INTRINSIC_NONE:
return "none";
+ /* DTIO */
+ case INTRINSIC_FORMATTED:
+ return "formatted";
+ case INTRINSIC_UNFORMATTED:
+ return "unformatted";
+
default:
break;
}
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 239769)
--- gcc/fortran/resolve.c (working copy)
*************** derived_inaccessible (gfc_symbol *sym)
*** 6689,6694 ****
--- 6689,6698 ----
for (c = sym->components; c; c = c->next)
{
+ if (c->ts.type == BT_DERIVED && c->attr.pointer
+ && sym == c->ts.u.derived)
+ continue;
+
if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
return 1;
}
*************** static void
*** 8642,8650 ****
resolve_transfer (gfc_code *code)
{
gfc_typespec *ts;
! gfc_symbol *sym;
gfc_ref *ref;
gfc_expr *exp;
exp = code->expr1;
--- 8646,8658 ----
resolve_transfer (gfc_code *code)
{
gfc_typespec *ts;
! gfc_symbol *sym, *derived;
gfc_ref *ref;
gfc_expr *exp;
+ bool write = false;
+ bool formatted = false;
+ gfc_dt *dt = code->ext.dt;
+ gfc_symbol *dtio_sub = NULL;
exp = code->expr1;
*************** resolve_transfer (gfc_code *code)
*** 8668,8674 ****
/* If we are reading, the variable will be changed. Note that
code->ext.dt may be NULL if the TRANSFER is related to
an INQUIRE statement -- but in this case, we are not reading, either. */
! if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ
&& !gfc_check_vardef_context (exp, false, false, false,
_("item in READ")))
return;
--- 8676,8682 ----
/* If we are reading, the variable will be changed. Note that
code->ext.dt may be NULL if the TRANSFER is related to
an INQUIRE statement -- but in this case, we are not reading, either. */
! if (dt && dt->dt_io_kind->value.iokind == M_READ
&& !gfc_check_vardef_context (exp, false, false, false,
_("item in READ")))
return;
*************** resolve_transfer (gfc_code *code)
*** 8680,8688 ****
if (ref->type == REF_COMPONENT)
ts = &ref->u.c.component->ts;
! if (ts->type == BT_CLASS)
{
- /* FIXME: Test for defined input/output. */
gfc_error ("Data transfer element at %L cannot be polymorphic unless "
"it is processed by a defined input/output procedure",
&code->loc);
--- 8688,8740 ----
if (ref->type == REF_COMPONENT)
ts = &ref->u.c.component->ts;
! if (dt && dt->dt_io_kind->value.iokind != M_INQUIRE
! && (ts->type == BT_DERIVED || ts->type == BT_CLASS))
! {
! if (ts->type == BT_DERIVED)
! derived = ts->u.derived;
! else
! derived = ts->u.derived->components->ts.u.derived;
!
! if (dt->format_expr)
! {
! char *fmt;
! fmt = gfc_widechar_to_char (dt->format_expr->value.character.string,
! -1);
! if (strtok (fmt, "DT") != NULL)
! formatted = true;
! }
! else if (dt->format_label == &format_asterisk)
! {
! /* List directed io must call the formatted DTIO procedure. */
! formatted = true;
! }
!
! write = dt->dt_io_kind->value.iokind == M_WRITE
! || dt->dt_io_kind->value.iokind == M_PRINT;
! dtio_sub = gfc_find_specific_dtio_proc (derived, write, formatted);
!
! if (dtio_sub != NULL && exp->expr_type == EXPR_VARIABLE)
! {
! sym = exp->symtree->n.sym->ns->proc_name;
! /* Check to see if this is a nested DTIO call, with the
! dummy as the io-list object. */
! if (sym && sym == dtio_sub && sym->formal
! && sym->formal->sym == exp->symtree->n.sym
! && exp->ref == NULL)
! {
! if (!sym->attr.recursive)
! {
! gfc_error ("DTIO %s procedure at %L must be recursive",
! sym->name, &sym->declared_at);
! return;
! }
! }
! }
! }
!
! if (ts->type == BT_CLASS && dtio_sub == NULL)
{
gfc_error ("Data transfer element at %L cannot be polymorphic unless "
"it is processed by a defined input/output procedure",
&code->loc);
*************** resolve_transfer (gfc_code *code)
*** 8692,8699 ****
if (ts->type == BT_DERIVED)
{
/* Check that transferred derived type doesn't contain POINTER
! components. */
! if (ts->u.derived->attr.pointer_comp)
{
gfc_error ("Data transfer element at %L cannot have POINTER "
"components unless it is processed by a defined "
--- 8744,8752 ----
if (ts->type == BT_DERIVED)
{
/* Check that transferred derived type doesn't contain POINTER
! components unless it is processed by a defined input/output
! procedure". */
! if (ts->u.derived->attr.pointer_comp && dtio_sub == NULL)
{
gfc_error ("Data transfer element at %L cannot have POINTER "
"components unless it is processed by a defined "
*************** resolve_transfer (gfc_code *code)
*** 8709,8715 ****
return;
}
! if (ts->u.derived->attr.alloc_comp)
{
gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
"components unless it is processed by a defined "
--- 8762,8768 ----
return;
}
! if (ts->u.derived->attr.alloc_comp && dtio_sub == NULL)
{
gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
"components unless it is processed by a defined "
*************** resolve_transfer (gfc_code *code)
*** 8726,8735 ****
"cannot have PRIVATE components", &code->loc))
return;
}
! else if (derived_inaccessible (ts->u.derived))
{
gfc_error ("Data transfer element at %L cannot have "
! "PRIVATE components",&code->loc);
return;
}
}
--- 8779,8789 ----
"cannot have PRIVATE components", &code->loc))
return;
}
! else if (derived_inaccessible (ts->u.derived) && dtio_sub == NULL)
{
gfc_error ("Data transfer element at %L cannot have "
! "PRIVATE components unless it is processed by "
! "a defined input/output procedure", &code->loc);
return;
}
}
*************** resolve_bind_c_derived_types (gfc_symbol
*** 10901,10906 ****
--- 10955,10975 ----
}
+ /* Check the interfaces of DTIO procedures associated with derived
+ type 'sym'. These procedures can either have typebound bindings or
+ can appear in DTIO generic interfaces. */
+
+ static void
+ gfc_verify_DTIO_procedures (gfc_symbol *sym)
+ {
+ if (!sym || sym->attr.flavor != FL_DERIVED)
+ return;
+
+ gfc_check_dtio_interfaces (sym);
+
+ return;
+ }
+
/* Verify that any binding labels used in a given namespace do not collide
with the names or binding labels of any global symbols. Multiple INTERFACE
for the same procedure are permitted. */
*************** resolve_fl_derived (gfc_symbol *sym)
*** 13421,13431 ****
--- 13490,13520 ----
}
+ /* Check for formatted read and write DTIO procedures. */
+
+ static bool
+ dtio_procs_present (gfc_symbol *sym)
+ {
+ gfc_symbol *derived;
+
+ if (sym->ts.type == BT_CLASS)
+ derived = CLASS_DATA (sym)->ts.u.derived;
+ else if (sym->ts.type == BT_DERIVED)
+ derived = sym->ts.u.derived;
+ else
+ return false;
+
+ return gfc_find_specific_dtio_proc (derived, true, true) != NULL
+ && gfc_find_specific_dtio_proc (derived, false, true) != NULL;
+ }
+
+
static bool
resolve_fl_namelist (gfc_symbol *sym)
{
gfc_namelist *nl;
gfc_symbol *nlsym;
+ bool dtio;
for (nl = sym->namelist; nl; nl = nl->next)
{
*************** resolve_fl_namelist (gfc_symbol *sym)
*** 13459,13467 ****
sym->name, &sym->declared_at))
return false;
! /* FIXME: Once UDDTIO is implemented, the following can be
! removed. */
! if (nl->sym->ts.type == BT_CLASS)
{
gfc_error ("NAMELIST object %qs in namelist %qs at %L is "
"polymorphic and requires a defined input/output "
--- 13548,13556 ----
sym->name, &sym->declared_at))
return false;
! dtio = dtio_procs_present (nl->sym);
!
! if (nl->sym->ts.type == BT_CLASS && !dtio)
{
gfc_error ("NAMELIST object %qs in namelist %qs at %L is "
"polymorphic and requires a defined input/output "
*************** resolve_fl_namelist (gfc_symbol *sym)
*** 13479,13486 ****
sym->name, &sym->declared_at))
return false;
! /* FIXME: Once UDDTIO is implemented, the following can be
! removed. */
gfc_error ("NAMELIST object %qs in namelist %qs at %L has "
"ALLOCATABLE or POINTER components and thus requires "
"a defined input/output procedure", nl->sym->name,
--- 13568,13575 ----
sym->name, &sym->declared_at))
return false;
! if (!dtio)
! {
gfc_error ("NAMELIST object %qs in namelist %qs at %L has "
"ALLOCATABLE or POINTER components and thus requires "
"a defined input/output procedure", nl->sym->name,
*************** resolve_fl_namelist (gfc_symbol *sym)
*** 13488,13493 ****
--- 13577,13583 ----
return false;
}
}
+ }
/* Reject PRIVATE objects in a PUBLIC namelist. */
if (gfc_check_symbol_access (sym))
*************** resolve_fl_namelist (gfc_symbol *sym)
*** 13504,13509 ****
--- 13594,13604 ----
return false;
}
+ /* If the derived type has specific DTIO procedures for both read and
+ write then namelist objects with private components are OK. */
+ if (dtio_procs_present (nl->sym))
+ continue;
+
/* Types with private components that came here by USE-association. */
if (nl->sym->ts.type == BT_DERIVED
&& derived_inaccessible (nl->sym->ts.u.derived))
*************** resolve_types (gfc_namespace *ns)
*** 15527,15532 ****
--- 15622,15629 ----
gfc_resolve_uops (ns->uop_root);
+ gfc_traverse_ns (ns, gfc_verify_DTIO_procedures);
+
gfc_resolve_omp_declare_simd (ns);
gfc_resolve_omp_udrs (ns->omp_udr_root);
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c (revision 239769)
--- gcc/fortran/symbol.c (working copy)
*************** const mstring save_status[] =
*** 87,92 ****
--- 87,101 ----
minit ("IMPLICIT-SAVE", SAVE_IMPLICIT),
};
+ /* Set the mstrings for DTIO procedure names. */
+ const mstring dtio_procs[] =
+ {
+ minit ("_dtio_formatted_read", DTIO_RF),
+ minit ("_dtio_formatted_write", DTIO_WF),
+ minit ("_dtio_unformatted_read", DTIO_RUF),
+ minit ("_dtio_unformatted_write", DTIO_WUF),
+ };
+
/* This is to make sure the backend generates setup code in the correct
order. */
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 239769)
--- gcc/fortran/trans-decl.c (working copy)
*************** gfc_finish_var_decl (tree decl, gfc_symb
*** 638,643 ****
--- 638,653 ----
&& sym->attr.codimension && !sym->attr.allocatable)))
TREE_STATIC (decl) = 1;
+ /* If derived-type variables with DTIO procedures are not made static
+ some bits of code referencing them get optimized away.
+ TODO Understand why this is so and fix it. */
+ if (!sym->attr.use_assoc
+ && ((sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived->attr.has_dtio_procs)
+ || (sym->ts.type == BT_CLASS
+ && CLASS_DATA (sym)->ts.u.derived->attr.has_dtio_procs)))
+ TREE_STATIC (decl) = 1;
+
if (sym->attr.volatile_)
{
TREE_THIS_VOLATILE (decl) = 1;
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 239769)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_get_vptr_from_expr (tree expr)
*** 430,438 ****
else
type = NULL_TREE;
}
! if (TREE_CODE (tmp) == VAR_DECL)
break;
}
return NULL_TREE;
}
--- 430,446 ----
else
type = NULL_TREE;
}
! if (TREE_CODE (tmp) == VAR_DECL
! || TREE_CODE (tmp) == PARM_DECL)
break;
}
+
+ if (POINTER_TYPE_P (TREE_TYPE (tmp)))
+ tmp = build_fold_indirect_ref_loc (input_location, tmp);
+
+ if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+ return gfc_class_vptr_get (tmp);
+
return NULL_TREE;
}
*************** gfc_conv_derived_to_class (gfc_se *parms
*** 511,517 ****
if (optional)
cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
! if (parmse->ss && parmse->ss->info->useflags)
{
/* For an array reference in an elemental procedure call we need
to retain the ss to provide the scalarized array reference. */
--- 519,532 ----
if (optional)
cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
! if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
! {
! /* If there is a ready made pointer to a derived type, use it
! rather than evaluating the expression again. */
! tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
! gfc_add_modify (&parmse->pre, ctree, tmp);
! }
! else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
{
/* For an array reference in an elemental procedure call we need
to retain the ss to provide the scalarized array reference. */
*************** gfc_conv_derived_to_class (gfc_se *parms
*** 522,528 ****
cond_optional, tmp,
fold_convert (TREE_TYPE (tmp), null_pointer_node));
gfc_add_modify (&parmse->pre, ctree, tmp);
-
}
else
{
--- 537,542 ----
Index: gcc/fortran/trans-io.c
===================================================================
*** gcc/fortran/trans-io.c (revision 239769)
--- gcc/fortran/trans-io.c (working copy)
*************** enum iocall
*** 132,137 ****
--- 132,138 ----
IOCALL_X_COMPLEX128_WRITE,
IOCALL_X_ARRAY,
IOCALL_X_ARRAY_WRITE,
+ IOCALL_X_DERIVED,
IOCALL_OPEN,
IOCALL_CLOSE,
IOCALL_INQUIRE,
*************** gfc_build_io_library_fndecls (void)
*** 397,402 ****
--- 398,407 ----
void_type_node, 4, dt_parm_type, pvoid_type_node,
integer_type_node, gfc_charlen_type_node);
+ iocall[IOCALL_X_DERIVED] = gfc_build_library_function_decl_with_spec (
+ get_identifier (PREFIX("transfer_derived")), ".wrR",
+ void_type_node, 2, dt_parm_type, pvoid_type_node, pchar_type_node);
+
/* Library entry points */
iocall[IOCALL_READ] = gfc_build_library_function_decl_with_spec (
*************** gfc_build_io_library_fndecls (void)
*** 465,472 ****
iocall[IOCALL_SET_NML_VAL] = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("st_set_nml_var")), ".w.R",
! void_type_node, 6, dt_parm_type, pvoid_type_node, pvoid_type_node,
! gfc_int4_type_node, gfc_charlen_type_node, gfc_int4_type_node);
iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("st_set_nml_var_dim")), ".w",
--- 470,478 ----
iocall[IOCALL_SET_NML_VAL] = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("st_set_nml_var")), ".w.R",
! void_type_node, 8, dt_parm_type, pvoid_type_node, pvoid_type_node,
! gfc_int4_type_node, gfc_charlen_type_node, gfc_int4_type_node,
! pvoid_type_node, pvoid_type_node);
iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("st_set_nml_var_dim")), ".w",
*************** gfc_build_io_library_fndecls (void)
*** 475,486 ****
}
! /* Generate code to store an integer constant into the
! st_parameter_XXX structure. */
!
! static unsigned int
! set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
! unsigned int val)
{
tree tmp;
gfc_st_parameter_field *p = &st_parameter_field[type];
--- 481,488 ----
}
! static void
! set_parameter_tree (stmtblock_t *block, tree var, enum iofield type, tree value)
{
tree tmp;
gfc_st_parameter_field *p = &st_parameter_field[type];
*************** set_parameter_const (stmtblock_t *block,
*** 491,497 ****
var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
var, p->field, NULL_TREE);
! gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (p->field), val));
return p->mask;
}
--- 493,513 ----
var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
var, p->field, NULL_TREE);
! gfc_add_modify (block, tmp, value);
! }
!
!
! /* Generate code to store an integer constant into the
! st_parameter_XXX structure. */
!
! static unsigned int
! set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
! unsigned int val)
! {
! gfc_st_parameter_field *p = &st_parameter_field[type];
!
! set_parameter_tree (block, var, type,
! build_int_cst (TREE_TYPE (p->field), val));
return p->mask;
}
*************** set_parameter_ref (stmtblock_t *block, s
*** 697,709 ****
gfc_add_modify (postblock, se.expr, tmp);
}
! if (p->param_type == IOPARM_ptype_common)
! var = fold_build3_loc (input_location, COMPONENT_REF,
! st_parameter[IOPARM_ptype_common].type,
! var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
! tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
! var, p->field, NULL_TREE);
! gfc_add_modify (block, tmp, addr);
return p->mask;
}
--- 713,719 ----
gfc_add_modify (postblock, se.expr, tmp);
}
! set_parameter_tree (block, var, type, addr);
return p->mask;
}
*************** transfer_namelist_element (stmtblock_t *
*** 1618,1623 ****
--- 1628,1635 ----
tree dt_parm_addr;
tree decl = NULL_TREE;
tree gfc_int4_type_node = gfc_get_int_type (4);
+ tree dtio_proc = null_pointer_node;
+ tree vtable = null_pointer_node;
int n_dim;
int itype;
int rank = 0;
*************** transfer_namelist_element (stmtblock_t *
*** 1659,1673 ****
dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
if (ts->type == BT_CHARACTER)
tmp = ts->u.cl->backend_decl;
else
tmp = build_int_cst (gfc_charlen_type_node, 0);
tmp = build_call_expr_loc (input_location,
! iocall[IOCALL_SET_NML_VAL], 6,
dt_parm_addr, addr_expr, string,
build_int_cst (gfc_int4_type_node, ts->kind),
! tmp, dtype);
gfc_add_expr_to_block (block, tmp);
/* If the object is an array, transfer rank times:
--- 1671,1707 ----
dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
+ /* Check if the derived type has a specific DTIO for the mode.
+ Note that although namelist io is forbidden to have a format
+ list, the specific subroutine is of the formatted kind. */
+ if (ts->type == BT_DERIVED)
+ {
+ gfc_symbol *dtio_sub = NULL;
+ gfc_symbol *vtab;
+ dtio_sub = gfc_find_specific_dtio_proc (ts->u.derived,
+ last_dt == WRITE,
+ true);
+ if (dtio_sub != NULL)
+ {
+ dtio_proc = gfc_get_symbol_decl (dtio_sub);
+ dtio_proc = gfc_build_addr_expr (NULL, dtio_proc);
+ vtab = gfc_find_derived_vtab (ts->u.derived);
+ vtable = vtab->backend_decl;
+ if (vtable == NULL_TREE)
+ vtable = gfc_get_symbol_decl (vtab);
+ vtable = gfc_build_addr_expr (pvoid_type_node, vtable);
+ }
+ }
+
if (ts->type == BT_CHARACTER)
tmp = ts->u.cl->backend_decl;
else
tmp = build_int_cst (gfc_charlen_type_node, 0);
tmp = build_call_expr_loc (input_location,
! iocall[IOCALL_SET_NML_VAL], 8,
dt_parm_addr, addr_expr, string,
build_int_cst (gfc_int4_type_node, ts->kind),
! tmp, dtype, dtio_proc, vtable);
gfc_add_expr_to_block (block, tmp);
/* If the object is an array, transfer rank times:
*************** transfer_namelist_element (stmtblock_t *
*** 1685,1691 ****
gfc_add_expr_to_block (block, tmp);
}
! if (gfc_bt_struct (ts->type) && ts->u.derived->components)
{
gfc_component *cmp;
--- 1719,1726 ----
gfc_add_expr_to_block (block, tmp);
}
! if (gfc_bt_struct (ts->type) && ts->u.derived->components
! && dtio_proc == null_pointer_node)
{
gfc_component *cmp;
*************** gfc_trans_dt_end (gfc_code * code)
*** 1995,2001 ****
}
static void
! transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code);
/* Given an array field in a derived type variable, generate the code
for the loop that iterates over array elements, and the code that
--- 2030,2037 ----
}
static void
! transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
! gfc_code * code, tree vptr);
/* Given an array field in a derived type variable, generate the code
for the loop that iterates over array elements, and the code that
*************** transfer_array_component (tree expr, gfc
*** 2061,2067 ****
/* Now se.expr contains an element of the array. Take the address and pass
it to the IO routines. */
tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
! transfer_expr (&se, &cm->ts, tmp, NULL);
/* We are done now with the loop body. Wrap up the scalarizer and
return. */
--- 2097,2103 ----
/* Now se.expr contains an element of the array. Take the address and pass
it to the IO routines. */
tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
! transfer_expr (&se, &cm->ts, tmp, NULL, NULL_TREE);
/* We are done now with the loop body. Wrap up the scalarizer and
return. */
*************** transfer_array_component (tree expr, gfc
*** 2081,2090 ****
return gfc_finish_block (&block);
}
/* Generate the call for a scalar transfer node. */
static void
! transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
{
tree tmp, function, arg2, arg3, field, expr;
gfc_component *c;
--- 2117,2169 ----
return gfc_finish_block (&block);
}
+
+ /* Helper function for transfer_expr that looks for the DTIO procedure
+ either as a typebound binding or in a generic interface. If present,
+ the address expression of the procedure is returned. It is assumed
+ that the procedure interface has been checked during resolution. */
+
+ static tree
+ get_dtio_proc (gfc_typespec * ts, gfc_code * code, gfc_symbol **dtio_sub)
+ {
+ gfc_symbol *derived;
+ bool formatted = false;
+ gfc_dt *dt = code->ext.dt;
+
+ if (dt && dt->format_expr)
+ {
+ char *fmt;
+ fmt = gfc_widechar_to_char (dt->format_expr->value.character.string,
+ -1);
+ if (strtok (fmt, "DT") != NULL)
+ formatted = true;
+ }
+ else if (dt && dt->format_label == &format_asterisk)
+ {
+ /* List directed io must call the formatted DTIO procedure. */
+ formatted = true;
+ }
+
+ if (ts->type == BT_DERIVED)
+ derived = ts->u.derived;
+ else
+ derived = ts->u.derived->components->ts.u.derived;
+
+ *dtio_sub = gfc_find_specific_dtio_proc (derived, last_dt == WRITE,
+ formatted);
+
+ if (*dtio_sub)
+ return gfc_build_addr_expr (NULL, gfc_get_symbol_decl (*dtio_sub));
+
+ return NULL_TREE;
+
+ }
+
/* Generate the call for a scalar transfer node. */
static void
! transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
! gfc_code * code, tree vptr)
{
tree tmp, function, arg2, arg3, field, expr;
gfc_component *c;
*************** transfer_expr (gfc_se * se, gfc_typespec
*** 2212,2220 ****
break;
case_bt_struct:
if (ts->u.derived->components == NULL)
return;
!
/* Recurse into the elements of the derived type. */
expr = gfc_evaluate_now (addr_expr, &se->pre);
expr = build_fold_indirect_ref_loc (input_location,
--- 2291,2335 ----
break;
case_bt_struct:
+ case BT_CLASS:
if (ts->u.derived->components == NULL)
return;
! if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
! {
! gfc_symbol *derived;
! gfc_symbol *dtio_sub = NULL;
! /* Test for a specific DTIO subroutine. */
! if (ts->type == BT_DERIVED)
! derived = ts->u.derived;
! else
! derived = ts->u.derived->components->ts.u.derived;
!
! if (derived->attr.has_dtio_procs)
! arg2 = get_dtio_proc (ts, code, &dtio_sub);
!
! if (dtio_sub != NULL)
! {
! tree decl;
! decl = build_fold_indirect_ref_loc (input_location,
! se->expr);
! /* Remember that the first dummy of the DTIO subroutines
! is CLASS(derived) for extensible derived types, so the
! conversion must be done here for derived type and for
! scalarized CLASS array element io-list objects. */
! if ((ts->type == BT_DERIVED
! && !(ts->u.derived->attr.sequence
! || ts->u.derived->attr.is_bind_c))
! || (ts->type == BT_CLASS
! && !GFC_CLASS_TYPE_P (TREE_TYPE (decl))))
! gfc_conv_derived_to_class (se, code->expr1,
! dtio_sub->formal->sym->ts,
! vptr, false, false);
! addr_expr = se->expr;
! function = iocall[IOCALL_X_DERIVED];
! break;
! }
! else if (ts->type == BT_DERIVED)
! {
/* Recurse into the elements of the derived type. */
expr = gfc_evaluate_now (addr_expr, &se->pre);
expr = build_fold_indirect_ref_loc (input_location,
*************** transfer_expr (gfc_se * se, gfc_typespec
*** 2244,2254 ****
{
if (!c->attr.pointer)
tmp = gfc_build_addr_expr (NULL_TREE, tmp);
! transfer_expr (se, &c->ts, tmp, code);
}
}
return;
!
default:
gfc_internal_error ("Bad IO basetype (%d)", ts->type);
}
--- 2359,2371 ----
{
if (!c->attr.pointer)
tmp = gfc_build_addr_expr (NULL_TREE, tmp);
! transfer_expr (se, &c->ts, tmp, code, NULL_TREE);
}
}
return;
! }
! /* If a CLASS object gets through to here, fall through and ICE. */
! }
default:
gfc_internal_error ("Bad IO basetype (%d)", ts->type);
}
*************** gfc_trans_transfer (gfc_code * code)
*** 2303,2308 ****
--- 2420,2426 ----
gfc_ss *ss;
gfc_se se;
tree tmp;
+ tree vptr;
int n;
gfc_start_block (&block);
*************** gfc_trans_transfer (gfc_code * code)
*** 2315,2322 ****
if (expr->rank == 0)
{
/* Transfer a scalar value. */
gfc_conv_expr_reference (&se, expr);
! transfer_expr (&se, &expr->ts, se.expr, code);
}
else
{
--- 2433,2450 ----
if (expr->rank == 0)
{
/* Transfer a scalar value. */
+ if (expr->ts.type == BT_CLASS)
+ {
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, expr);
+ vptr = gfc_get_vptr_from_expr (se.expr);
+ }
+ else
+ {
+ vptr = NULL_TREE;
gfc_conv_expr_reference (&se, expr);
! }
! transfer_expr (&se, &expr->ts, se.expr, code, vptr);
}
else
{
*************** gfc_trans_transfer (gfc_code * code)
*** 2330,2336 ****
gcc_assert (ref && ref->type == REF_ARRAY);
}
! if (!gfc_bt_struct (expr->ts.type)
&& ref && ref->next == NULL
&& !is_subref_array (expr))
{
--- 2458,2465 ----
gcc_assert (ref && ref->type == REF_ARRAY);
}
! if (!(gfc_bt_struct (expr->ts.type)
! || expr->ts.type == BT_CLASS)
&& ref && ref->next == NULL
&& !is_subref_array (expr))
{
*************** gfc_trans_transfer (gfc_code * code)
*** 2378,2386 ****
gfc_copy_loopinfo_to_se (&se, &loop);
se.ss = ss;
-
gfc_conv_expr_reference (&se, expr);
! transfer_expr (&se, &expr->ts, se.expr, code);
}
finish_block_label:
--- 2507,2518 ----
gfc_copy_loopinfo_to_se (&se, &loop);
se.ss = ss;
gfc_conv_expr_reference (&se, expr);
! if (expr->ts.type == BT_CLASS)
! vptr = gfc_get_vptr_from_expr (ss->info->data.array.descriptor);
! else
! vptr = NULL_TREE;
! transfer_expr (&se, &expr->ts, se.expr, code, vptr);
}
finish_block_label:
Index: gcc/testsuite/gfortran.dg/dtio_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/dtio_1.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/dtio_1.f90 (working copy)
***************
*** 0 ****
--- 1,164 ----
+ ! { dg-do run }
+ !
+ ! Functional test of User Defined Derived Type IO, Formatted WRITE/READ
+ !
+ ! 1) Tests passing of iostat out of the user procedure.
+ ! 2) Tests parsing of the DT optional string and passing in and using
+ ! to control execution.
+ ! 3) Tests parsing of the optional vlist, passing in and using it to
+ ! generate a user defined format string.
+ ! 4) Tests passing an iostat or iomsg out of libgfortranthe child procedure back to
+ ! the parent.
+ !
+ MODULE p
+ USE ISO_FORTRAN_ENV
+ TYPE :: person
+ CHARACTER (LEN=20) :: name
+ INTEGER(4) :: age
+ CONTAINS
+ procedure :: pwf
+ procedure :: prf
+ GENERIC :: WRITE(FORMATTED) => pwf
+ GENERIC :: READ(FORMATTED) => prf
+ END TYPE person
+ CONTAINS
+ SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg)
+ CLASS(person), INTENT(IN) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ CHARACTER (LEN=*), INTENT(IN) :: iotype
+ INTEGER, INTENT(IN) :: vlist(:)
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ CHARACTER (LEN=30) :: udfmt
+ INTEGER :: myios
+
+ udfmt='(*(g0))'
+ iomsg = "SUCCESS"
+ iostat=0
+ if (iotype.eq."DT") then
+ if (size(vlist).ne.0) print *, 36
+ WRITE(unit, FMT = '(a,5x,i2)', IOSTAT=iostat, advance='no') trim(dtv%name), dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF DT"
+ endif
+ if (iotype.eq."DTzeroth") then
+ if (size(vlist).ne.0) print *, 40
+ WRITE(unit, FMT = '(g0,g0)', advance='no') dtv%name, dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF DTzeroth"
+ endif
+ if (iotype.eq."DTtwo") then
+ if (size(vlist).ne.2) call abort
+ WRITE(udfmt,'(A,A,I1,A,I1,A)') '(', 'A', vlist(1),',I', vlist(2), ')'
+ WRITE(unit, FMT='(A8,I2)') dtv%name, dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF DTtwo"
+ endif
+ if (iotype.eq."DTthree") then
+ WRITE(udfmt,'(2A,I2,A,I1,A,I2,A)',iostat=myios) '(', 'A', vlist(1),',I', vlist(2), ',F', vlist(3), '.2)'
+ WRITE(unit, FMT=udfmt, IOSTAT=iostat, advance='no') trim(dtv%name), dtv%age, 3.14
+ if (iostat.ne.0) iomsg = "Fail PWF DTthree"
+ endif
+ if (iotype.eq."LISTDIRECTED") then
+ if (size(vlist).ne.0) print *, 55
+ WRITE(unit, FMT = *) dtv%name, dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF LISTDIRECTED"
+ endif
+ if (iotype.eq."NAMELIST") then
+ if (size(vlist).ne.0) print *, 59
+ iostat=6000
+ endif
+ END SUBROUTINE pwf
+
+ SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg)
+ CLASS(person), INTENT(INOUT) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ CHARACTER (LEN=*), INTENT(IN) :: iotype
+ INTEGER, INTENT(IN) :: vlist(:)
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ CHARACTER (LEN=30) :: udfmt
+ INTEGER :: myios
+ real :: areal
+ udfmt='(*(g0))'
+ iomsg = "SUCCESS"
+ iostat=0
+ if (iotype.eq."DT") then
+ if (size(vlist).ne.0) print *, 36
+ READ(unit, FMT = '(a,5x,i2)', IOSTAT=iostat, advance='no') dtv%name, dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF DT"
+ endif
+ if (iotype.eq."DTzeroth") then
+ if (size(vlist).ne.0) print *, 40
+ READ(unit, FMT = '(a,I2)', advance='no') dtv%name, dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF DTzeroth"
+ endif
+ if (iotype.eq."DTtwo") then
+ if (size(vlist).ne.2) call abort
+ WRITE(udfmt,'(A,A,I1,A,I1,A)') '(', 'A', vlist(1),',I', vlist(2), ')'
+ READ(unit, FMT='(A8,I2)') dtv%name, dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF DTtwo"
+ endif
+ if (iotype.eq."DTthree") then
+ WRITE(udfmt,'(2A,I2,A,I1,A,I2,A)',iostat=myios) '(', 'A', vlist(1),',I', vlist(2), ',F', vlist(3), '.2)'
+ READ(unit, FMT=udfmt, IOSTAT=iostat, advance='no') dtv%name, dtv%age, areal
+ if (iostat.ne.0) iomsg = "Fail PWF DTthree"
+ endif
+ if (iotype.eq."LISTDIRECTED") then
+ if (size(vlist).ne.0) print *, 55
+ READ(unit, FMT = *) dtv%name, dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF LISTDIRECTED"
+ endif
+ if (iotype.eq."NAMELIST") then
+ if (size(vlist).ne.0) print *, 59
+ iostat=6000
+ endif
+ !READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age
+ END SUBROUTINE prf
+
+ END MODULE p
+
+ PROGRAM test
+ USE p
+ TYPE (person), SAVE :: chairman
+ TYPE (person), SAVE :: member
+ character(80) :: astring
+ integer :: thelength
+
+ chairman%name="Charlie"
+ chairman%age=62
+ member%name="George"
+ member%age=42
+ astring = "FAILURE"
+ write (10, "(DT'zeroth',3x, DT'three'(11,4,10),11x,DT'two'(8,2))", &
+ & iostat=myiostat, iomsg=astring) member, chairman, member
+ if (myiostat.ne.0) call abort
+ if (astring.ne."SUCCESS") call abort
+ astring = "FAILURE"
+ write (10, *, iostat=myiostat, iomsg=astring) member, chairman, member
+ if (myiostat.ne.0) call abort
+ if (astring.ne."SUCCESS") call abort
+ write(10,*) ! See note below
+ rewind(10)
+ chairman%name="bogus1"
+ chairman%age=99
+ member%name="bogus2"
+ member%age=66
+ astring = "FAILURE"
+ read(10,"(DT'zeroth',3x, DT'three'(11,4,10),11x,DT'two'(8,2))") member, chairman, member
+ if (member%name.ne."George") call abort
+ if (chairman%name.ne." Charlie") call abort
+ if (member%age.ne.42) call abort
+ if (chairman%age.ne.62) call abort
+ chairman%name="bogus1"
+ chairman%age=99
+ member%name="bogus2"
+ member%age=66
+ astring = "FAILURE"
+ read (10, *, iostat=myiostat, iomsg=astring) member, chairman, member
+ ! The user defined procedure reads to the end of the line/file, then finalizing the parent
+ ! reads past, so we wrote a blank line above. User needs to address these nuances in their
+ ! procedures. (subject to interpretation)
+ if (astring.ne."SUCCESS") call abort
+ if (member%name.ne."George") call abort
+ if (chairman%name.ne."Charlie") call abort
+ if (member%age.ne.42) call abort
+ if (chairman%age.ne.62) call abort
+ END PROGRAM test
Index: gcc/testsuite/gfortran.dg/dtio_10.f90
===================================================================
*** gcc/testsuite/gfortran.dg/dtio_10.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/dtio_10.f90 (working copy)
***************
*** 0 ****
--- 1,27 ----
+ ! { dg-do run }
+ !
+ ! Tests runtime check of the required type in dtio formatted read.
+ !
+ module usertypes
+ type udt
+ integer :: myarray(15)
+ end type udt
+ type, extends(udt) :: more
+ integer :: itest = -25
+ end type
+
+ end module usertypes
+
+ program test1
+ use usertypes
+ type (udt) :: udt1
+ type (more) :: more1
+ class (more), allocatable :: somemore
+ integer :: thesize, i, ios
+ character(100) :: errormsg
+
+ read (10, fmt='(dt)', advance='no', size=thesize, iostat=ios, &
+ & iomsg=errormsg) i, udt1
+ if (ios.ne.5006) call abort
+ if (errormsg(1:25).ne."Expected CLASS or DERIVED") call abort
+ end program test1
Index: gcc/testsuite/gfortran.dg/dtio_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/dtio_2.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/dtio_2.f90 (working copy)
***************
*** 0 ****
--- 1,71 ----
+ ! { dg-do run }
+ !
+ ! Functional test of User Defined DT IO, unformatted WRITE/READ
+ !
+ ! 1) Tests unformatted DTV write with other variables in the record
+ ! 2) Tests reading back the recods written.
+ !
+ module p
+ type :: person
+ character (len=20) :: name
+ integer(4) :: age
+ contains
+ procedure :: pwuf
+ procedure :: pruf
+ generic :: write(unformatted) => pwuf
+ generic :: read(unformatted) => pruf
+ end type person
+ contains
+ subroutine pwuf (dtv,unit,iostat,iomsg)
+ class(person), intent(in) :: dtv
+ integer, intent(in) :: unit
+ integer, intent(out) :: iostat
+ character (len=*), intent(inout) :: iomsg
+ write (unit=unit, iostat=iostat, iomsg=iomsg) dtv%name, dtv%age
+ end subroutine pwuf
+
+ subroutine pruf (dtv,unit,iostat,iomsg)
+ class(person), intent(inout) :: dtv
+ integer, intent(in) :: unit
+ integer, intent(out) :: iostat
+ character (len=*), intent(inout) :: iomsg
+ read (unit = unit) dtv%name, dtv%age
+ end subroutine pruf
+
+ end module p
+
+ program test
+ use p
+ type (person), save :: chairman
+ character(3) :: tmpstr1, tmpstr2
+ chairman%name="charlie"
+ chairman%age=62
+
+ open (unit=71, file='myunformatted_data.dat', form='unformatted')
+ write (71) "abc", chairman, "efg"
+ write (71) "hij", chairman, "klm"
+ write (71) "nop", chairman, "qrs"
+ rewind (unit = 71)
+ chairman%name="boggle"
+ chairman%age=1234
+ read (71) tmpstr1, chairman, tmpstr2
+ if (tmpstr1.ne."abc") call abort
+ if (tmpstr2.ne."efg") call abort
+ if (chairman%name.ne."charlie") call abort
+ if (chairman%age.ne.62) call abort
+ chairman%name="boggle"
+ chairman%age=1234
+ read (71) tmpstr1, chairman, tmpstr2
+ if (tmpstr1.ne."hij") call abort
+ if (tmpstr2.ne."klm") call abort
+ if (chairman%name.ne."charlie") call abort
+ if (chairman%age.ne.62) call abort
+ chairman%name="boggle"
+ chairman%age=1234
+ read (71) tmpstr1, chairman, tmpstr2
+ if (tmpstr1.ne."nop") call abort
+ if (tmpstr2.ne."qrs") call abort
+ if (chairman%name.ne."charlie") call abort
+ if (chairman%age.ne.62) call abort
+ close (unit = 71, status='delete')
+ end program test
Index: gcc/testsuite/gfortran.dg/dtio_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/dtio_3.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/dtio_3.f90 (working copy)
***************
*** 0 ****
--- 1,172 ----
+ ! { dg-do run }
+ !
+ ! Functional test of User Defined Derived Type IO.
+ !
+ ! This tests recursive calls where a derived type has a member that is
+ ! itself.
+ !
+ MODULE p
+ USE ISO_FORTRAN_ENV
+ TYPE :: person
+ CHARACTER (LEN=20) :: name
+ INTEGER(4) :: age
+ type(person), pointer :: next => NULL()
+ CONTAINS
+ procedure :: pwf
+ procedure :: prf
+ GENERIC :: WRITE(FORMATTED) => pwf
+ GENERIC :: READ(FORMATTED) => prf
+ END TYPE person
+ CONTAINS
+ RECURSIVE SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg)
+ CLASS(person), INTENT(IN) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ CHARACTER (LEN=*), INTENT(IN) :: iotype
+ INTEGER, INTENT(IN) :: vlist(:)
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ CHARACTER (LEN=30) :: udfmt
+ INTEGER :: myios
+
+ udfmt='(*(g0))'
+ iomsg = "SUCCESS"
+ iostat=0
+ if (iotype.eq."DT") then
+ if (size(vlist).ne.0) print *, 36
+ if (associated(dtv%next)) then
+ WRITE(unit, FMT = '(a20,i2, DT)', IOSTAT=iostat, advance='no') dtv%name, dtv%age, dtv%next
+ else
+ WRITE(unit, FMT = '(a20,i2)', IOSTAT=iostat, advance='no') dtv%name, dtv%age
+ endif
+ if (iostat.ne.0) iomsg = "Fail PWF DT"
+ endif
+ if (iotype.eq."DTzeroth") then
+ if (size(vlist).ne.0) print *, 40
+ WRITE(unit, FMT = '(g0,g0)', advance='no') dtv%name, dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF DTzeroth"
+ endif
+ if (iotype.eq."DTtwo") then
+ if (size(vlist).ne.2) call abort
+ WRITE(udfmt,'(A,A,I1,A,I1,A)') '(', 'A', vlist(1),',I', vlist(2), ')'
+ WRITE(unit, FMT='(A8,I2)') dtv%name, dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF DTtwo"
+ endif
+ if (iotype.eq."DTthree") then
+ WRITE(udfmt,'(2A,I2,A,I1,A,I2,A)',iostat=myios) '(', 'A', vlist(1),',I', vlist(2), ',F', vlist(3), '.2)'
+ WRITE(unit, FMT=udfmt, IOSTAT=iostat, advance='no') trim(dtv%name), dtv%age, 3.14
+ if (iostat.ne.0) iomsg = "Fail PWF DTthree"
+ endif
+ if (iotype.eq."LISTDIRECTED") then
+ if (size(vlist).ne.0) print *, 55
+ if (associated(dtv%next)) then
+ WRITE(unit, FMT = *) dtv%name, dtv%age, dtv%next
+ else
+ WRITE(unit, FMT = *) dtv%name, dtv%age
+ endif
+ if (iostat.ne.0) iomsg = "Fail PWF LISTDIRECTED"
+ endif
+ if (iotype.eq."NAMELIST") then
+ if (size(vlist).ne.0) print *, 59
+ iostat=6000
+ endif
+ if (associated (dtv%next) .and. (iotype.eq."LISTDIRECTED")) write(unit, fmt = *) dtv%next
+ END SUBROUTINE pwf
+
+ RECURSIVE SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg)
+ CLASS(person), INTENT(INOUT) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ CHARACTER (LEN=*), INTENT(IN) :: iotype
+ INTEGER, INTENT(IN) :: vlist(:)
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ CHARACTER (LEN=30) :: udfmt
+ INTEGER :: myios
+ real :: areal
+ udfmt='(*(g0))'
+ iomsg = "SUCCESS"
+ iostat=0
+ if (iotype.eq."DT") then
+ if (size(vlist).ne.0) print *, 36
+ if (associated(dtv%next)) then
+ READ(unit, FMT = '(a20,i2, DT)', IOSTAT=iostat, advance='no') dtv%name, dtv%age, dtv%next
+ else
+ READ(unit, FMT = '(a20,i2)', IOSTAT=iostat, advance='no') dtv%name, dtv%age
+ endif
+ if (iostat.ne.0) iomsg = "Fail PWF DT"
+ endif
+ if (iotype.eq."DTzeroth") then
+ if (size(vlist).ne.0) print *, 40
+ READ(unit, FMT = '(a,I2)', advance='no') dtv%name, dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF DTzeroth"
+ endif
+ if (iotype.eq."DTtwo") then
+ if (size(vlist).ne.2) call abort
+ WRITE(udfmt,'(A,A,I1,A,I1,A)') '(', 'A', vlist(1),',I', vlist(2), ')'
+ READ(unit, FMT='(A8,I2)') dtv%name, dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF DTtwo"
+ endif
+ if (iotype.eq."DTthree") then
+ WRITE(udfmt,'(2A,I2,A,I1,A,I2,A)',iostat=myios) '(', 'A', vlist(1),',I', vlist(2), ',F', vlist(3), '.2)'
+ READ(unit, FMT=udfmt, IOSTAT=iostat, advance='no') dtv%name, dtv%age, areal
+ if (iostat.ne.0) iomsg = "Fail PWF DTthree"
+ endif
+ if (iotype.eq."LISTDIRECTED") then
+ if (size(vlist).ne.0) print *, 55
+ READ(unit, FMT = *) dtv%name, dtv%age
+ if (iostat.ne.0) iomsg = "Fail PWF LISTDIRECTED"
+ endif
+ if (iotype.eq."NAMELIST") then
+ if (size(vlist).ne.0) print *, 59
+ iostat=6000
+ endif
+ !READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age
+ END SUBROUTINE prf
+
+ END MODULE p
+
+ PROGRAM test
+ USE p
+ TYPE (person) :: chairman
+ TYPE (person), target :: member
+ character(80) :: astring
+ integer :: thelength
+
+ chairman%name="Charlie"
+ chairman%age=62
+ member%name="George"
+ member%age=42
+ astring = "FAILURE"
+ ! At this point, next is NULL as defined up in the type block.
+ open(10, status = "scratch")
+ write (10, *, iostat=myiostat, iomsg=astring) member, chairman
+ write(10,*)
+ rewind(10)
+ chairman%name="bogus1"
+ chairman%age=99
+ member%name="bogus2"
+ member%age=66
+ read (10, *, iostat=myiostat, iomsg=astring) member, chairman
+ if (astring.ne."SUCCESS") print *, astring
+ if (member%name.ne."George") call abort
+ if (chairman%name.ne."Charlie") call abort
+ if (member%age.ne.42) call abort
+ if (chairman%age.ne.62) call abort
+ close(10, status='delete')
+ ! Now we set next to point to member. This changes the code path
+ ! in the pwf and prf procedures.
+ chairman%next => member
+ open(10, status = "scratch")
+ write (10,"(DT)") chairman
+ rewind(10)
+ chairman%name="bogus1"
+ chairman%age=99
+ member%name="bogus2"
+ member%age=66
+ read (10,"(DT)", iomsg=astring) chairman
+ !print *, trim(astring)
+ if (member%name.ne."George") call abort
+ if (chairman%name.ne."Charlie") call abort
+ if (member%age.ne.42) call abort
+ if (chairman%age.ne.62) call abort
+ close(10)
+ END PROGRAM test
Index: gcc/testsuite/gfortran.dg/dtio_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/dtio_4.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/dtio_4.f90 (working copy)
***************
*** 0 ****
--- 1,107 ----
+ ! { dg-do run }
+ !
+ ! Functional test of User Defined Derived Type IO.
+ !
+ ! This tests a combination of module procedure and generic procedure
+ ! and performs reading and writing an array with a pseudo user defined
+ ! tag at the beginning of the file.
+ !
+ module usertypes
+ type udt
+ integer :: myarray(15)
+ contains
+ procedure :: user_defined_read
+ generic :: read (formatted) => user_defined_read
+ end type udt
+ type, extends(udt) :: more
+ integer :: someinteger = -25
+ end type
+
+ interface write(formatted)
+ module procedure user_defined_write
+ end interface
+
+ integer :: result_array(15)
+ contains
+ subroutine user_defined_read (dtv, unit, iotype, v_list, iostat, iomsg)
+ class(udt), intent(inout) :: dtv
+ integer, intent(in) :: unit
+ character(*), intent(in) :: iotype
+ integer, intent(in) :: v_list (:)
+ integer, intent(out) :: iostat
+ character(*), intent(inout) :: iomsg
+ character(10) :: typestring
+
+ iomsg = 'SUCCESS'
+ read (unit, '(a6)', iostat=iostat, iomsg=iomsg) typestring
+ typestring = trim(typestring)
+ select type (dtv)
+ type is (udt)
+ if (typestring.eq.' UDT: ') then
+ read (unit, fmt=*, iostat=iostat, iomsg=iomsg) dtv%myarray
+ else
+ iostat = 6000
+ iomsg = 'FAILURE'
+ end if
+ type is (more)
+ if (typestring.eq.' MORE: ') then
+ read (unit, fmt=*, iostat=iostat, iomsg=iomsg) dtv%myarray
+ else
+ iostat = 6000
+ iomsg = 'FAILUREwhat'
+ end if
+ end select
+ end subroutine user_defined_read
+
+ subroutine user_defined_write (dtv, unit, iotype, v_list, iostat, iomsg)
+ class(udt), intent(in) :: dtv
+ integer, intent(in) :: unit
+ character(*), intent(in) :: iotype
+ integer, intent(in) :: v_list (:)
+ integer, intent(out) :: iostat
+ character(*), intent(inout) :: iomsg
+ character(10) :: typestring
+ select type (dtv)
+ type is (udt)
+ write (unit, fmt=*, iostat=iostat, iomsg=iomsg) "UDT: "
+ write (unit, fmt=*, iostat=iostat, iomsg=iomsg) dtv%myarray
+ type is (more)
+ write (unit, fmt=*, iostat=iostat, iomsg=iomsg) "MORE: "
+ write (unit, fmt=*, iostat=iostat, iomsg=iomsg) dtv%myarray
+ end select
+ write (unit,*)
+ end subroutine user_defined_write
+ end module usertypes
+
+ program test1
+ use usertypes
+ type (udt) :: udt1
+ type (more) :: more1
+ class (more), allocatable :: somemore
+ integer :: thesize, i, ios
+ character(25):: iomsg
+
+ ! Create a file that contains some data for testing.
+ open (10, form='formatted', status='scratch')
+ write(10, '(a)') ' UDT: '
+ do i = 1, 15
+ write(10,'(i5)', advance='no') i
+ end do
+ write(10,*)
+ rewind(10)
+ udt1%myarray = 99
+ result_array = (/ (i, i = 1, 15) /)
+ more1%myarray = result_array
+ read (10, fmt='(dt)', advance='no', iomsg=iomsg) udt1
+ if (iomsg.ne.'SUCCESS') call abort
+ if (any(udt1%myarray.ne.result_array)) call abort
+ close(10)
+ open (10, form='formatted')
+ write (10, '(dt)') more1
+ rewind(10)
+ more1%myarray = 99
+ read (10, '(dt)', iostat=ios, iomsg=iomsg) more1
+ if (iomsg.ne.'SUCCESS') call abort
+ if (any(more1%myarray.ne.result_array)) call abort
+ close (10)
+ end program test1
Index: gcc/testsuite/gfortran.dg/dtio_5.f90
===================================================================
*** gcc/testsuite/gfortran.dg/dtio_5.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/dtio_5.f90 (working copy)
***************
*** 0 ****
--- 1,278 ----
+ ! { dg-do run }
+ !
+ ! This test is based on the second case in the PGInsider article at
+ ! https://www.pgroup.com/lit/articles/insider/v6n2a3.htm
+ !
+ ! The complete original code is at:
+ ! https://www.pgroup.com/lit/samples/pginsider/stack.f90
+ !
+ ! Thanks to Mark LeAir.
+ !
+ ! Copyright (c) 2015, NVIDIA CORPORATION. All rights reserved.
+ !
+ ! NVIDIA CORPORATION and its licensors retain all intellectual property
+ ! and proprietary rights in and to this software, related documentation
+ ! and any modifications thereto. Any use, reproduction, disclosure or
+ ! distribution of this software and related documentation without an express
+ ! license agreement from NVIDIA CORPORATION is strictly prohibited.
+ !
+
+ ! THIS CODE AND INFORMATION ARE PROVIDED "AS IS" WITHOUT
+ ! WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING BUT
+ ! NOT LIMITED TO THE IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR
+ ! FITNESS FOR A PARTICULAR PURPOSE.
+ !
+
+ module stack_mod
+
+ type, abstract :: stack
+ private
+ class(*), allocatable :: item ! an item on the stack
+ class(stack), pointer :: next=>null() ! next item on the stack
+ contains
+ procedure :: empty ! returns true if stack is empty
+ procedure :: delete ! empties the stack
+ end type stack
+
+ type, extends(stack) :: integer_stack
+ contains
+ procedure :: push => push_integer ! add integer item to stack
+ procedure :: pop => pop_integer ! remove integer item from stack
+ procedure :: compare => compare_integer ! compare with an integer array
+ end type integer_stack
+
+ type, extends(integer_stack) :: io_stack
+ contains
+ procedure,private :: wio_stack
+ procedure,private :: rio_stack
+ procedure,private :: dump_stack
+ generic :: write(unformatted) => wio_stack ! write stack item to file
+ generic :: read(unformatted) => rio_stack ! push item from file
+ generic :: write(formatted) => dump_stack ! print all items from stack
+ end type io_stack
+
+ contains
+
+ subroutine rio_stack (dtv, unit, iostat, iomsg)
+
+ ! read item from file and add it to stack
+
+ class(io_stack), intent(inout) :: dtv
+ integer, intent(in) :: unit
+ integer, intent(out) :: iostat
+ character(len=*), intent(inout) :: iomsg
+
+ integer :: item
+
+ read(unit,IOSTAT=iostat,IOMSG=iomsg) item
+
+ if (iostat .ne. 0) then
+ call dtv%push(item)
+ endif
+
+ end subroutine rio_stack
+
+ subroutine wio_stack(dtv, unit, iostat, iomsg)
+
+ ! pop an item from stack and write it to file
+
+ class(io_stack), intent(in) :: dtv
+ integer, intent(in) :: unit
+ integer, intent(out) :: iostat
+ character(len=*), intent(inout) :: iomsg
+ integer :: item
+
+ item = dtv%pop()
+ write(unit,IOSTAT=iostat,IOMSG=iomsg) item
+
+ end subroutine wio_stack
+
+ subroutine dump_stack(dtv, unit, iotype, v_list, iostat, iomsg)
+
+ ! Pop all items off stack and write them out to unit
+ ! Assumes default LISTDIRECTED output
+
+ class(io_stack), intent(in) :: dtv
+ integer, intent(in) :: unit
+ character(len=*), intent(in) :: iotype
+ integer, intent(in) :: v_list(:)
+ integer, intent(out) :: iostat
+ character(len=*), intent(inout) :: iomsg
+ character(len=80) :: buffer
+ integer :: item
+
+ if (iotype .ne. 'LISTDIRECTED') then
+ ! Error
+ iomsg = 'dump_stack: unsupported iotype'
+ iostat = 1
+ else
+ iostat = 0
+ do while( (.not. dtv%empty()) .and. (iostat .eq. 0) )
+ item = dtv%pop()
+ write(unit, '(I6/)',IOSTAT=iostat,IOMSG=iomsg) item
+ enddo
+ endif
+ end subroutine dump_stack
+
+ logical function empty(this)
+ class(stack) :: this
+ if (.not.associated(this%next)) then
+ empty = .true.
+ else
+ empty = .false.
+ end if
+ end function empty
+
+ subroutine push_integer(this,item)
+ class(integer_stack) :: this
+ integer :: item
+ type(integer_stack), allocatable :: new_item
+
+ allocate(new_item)
+ allocate(new_item%item, source=item)
+ new_item%next => this%next
+ allocate(this%next, source=new_item)
+ end subroutine push_integer
+
+ function pop_integer(this) result(item)
+ class(integer_stack) :: this
+ integer item
+
+ if (this%empty()) then
+ stop 'Error! pop_integer invoked on empty stack'
+ endif
+ select type(top=>this%next)
+ type is (integer_stack)
+ select type(i => top%item)
+ type is(integer)
+ item = i
+ class default
+ stop 'Error #1! pop_integer encountered non-integer stack item'
+ end select
+ this%next => top%next
+ deallocate(top)
+ class default
+ stop 'Error #2! pop_integer encountered non-integer_stack item'
+ end select
+ end function pop_integer
+
+ ! gfortran addition to check read/write
+ logical function compare_integer (this, array, error)
+ class(integer_stack), target :: this
+ class(stack), pointer :: ptr, next
+ integer :: array(:), i, j, error
+ compare_integer = .true.
+ ptr => this
+ do j = 0, size (array, 1)
+ if (compare_integer .eqv. .false.) return
+ select type (ptr)
+ type is (integer_stack)
+ select type(k => ptr%item)
+ type is(integer)
+ if (k .ne. array(j)) error = 1
+ class default
+ error = 2
+ compare_integer = .false.
+ end select
+ class default
+ if (j .ne. 0) then
+ error = 3
+ compare_integer = .false.
+ end if
+ end select
+ next => ptr%next
+ if (associated (next)) then
+ ptr => next
+ else if (j .ne. size (array, 1)) then
+ error = 4
+ compare_integer = .false.
+ end if
+ end do
+ end function
+
+ subroutine delete (this)
+ class(stack), target :: this
+ class(stack), pointer :: ptr1, ptr2
+ ptr1 => this%next
+ ptr2 => ptr1%next
+ do while (associated (ptr1))
+ deallocate (ptr1)
+ ptr1 => ptr2
+ if (associated (ptr1)) ptr2 => ptr1%next
+ end do
+ end subroutine
+
+ end module stack_mod
+
+ program stack_demo
+
+ use stack_mod
+ implicit none
+
+ integer i, k(10), error
+ class(io_stack), allocatable :: stk
+ allocate(stk)
+
+ k = [3,1,7,0,2,9,4,8,5,6]
+
+ ! step 1: set up an 'output' file > changed to 'scratch'
+
+ open(10, status='scratch', form='unformatted')
+
+ ! step 2: add values to stack
+
+ do i=1,10
+ ! write(*,*) 'Adding ',i,' to the stack'
+ call stk%push(k(i))
+ enddo
+
+ ! step 3: pop values from stack and write them to file
+
+ ! write(*,*)
+ ! write(*,*) 'Removing each item from stack and writing it to file.'
+ ! write(*,*)
+ do while(.not.stk%empty())
+ write(10) stk
+ enddo
+
+ ! step 4: close file and reopen it for read > changed to rewind.
+
+ rewind(10)
+
+ ! step 5: read values back into stack
+ ! write(*,*) 'Reading each value from file and adding it to stack:'
+ do while(.true.)
+ read(10,END=9999) i
+ ! write(*,*), 'Reading ',i,' from file. Adding it to stack'
+ call stk%push(i)
+ enddo
+
+ 9999 continue
+
+ ! step 6: Dump stack to standard out
+
+ ! write(*,*)
+ ! write(*,*), 'Removing every element from stack and writing it to screen:'
+ ! write(*,*) stk
+
+ ! gfortran addition to check read/write
+ if (.not. stk%compare (k, error)) then
+ select case (error)
+ case(1)
+ print *, "values do not match"
+ case(2)
+ print *, "non integer found in stack"
+ case(3)
+ print *, "type mismatch in stack"
+ case(4)
+ print *, "too few values in stack"
+ end select
+ call abort
+ end if
+
+ close(10)
+
+ ! Clean up - valgrind indicates no leaks.
+ call stk%delete
+ deallocate (stk)
+ end program stack_demo
Index: gcc/testsuite/gfortran.dg/dtio_6.f90
===================================================================
*** gcc/testsuite/gfortran.dg/dtio_6.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/dtio_6.f90 (working copy)
***************
*** 0 ****
--- 1,98 ----
+ ! { dg-do compile }
+ !
+ ! Tests the checks for interface compliance.
+ !
+ !
+ MODULE p
+ USE ISO_C_BINDING
+
+ TYPE :: person
+ CHARACTER (LEN=20) :: name
+ INTEGER(4) :: age
+ CONTAINS
+ procedure :: pwf ! { dg-error "Non-polymorphic passed-object" }
+ procedure :: pwuf
+ GENERIC :: WRITE(FORMATTED) => pwf
+ GENERIC :: WRITE(UNFORMATTED) => pwuf
+ END TYPE person
+ INTERFACE READ(FORMATTED)
+ MODULE PROCEDURE prf
+ END INTERFACE
+ INTERFACE READ(UNFORMATTED)
+ MODULE PROCEDURE pruf
+ END INTERFACE
+
+ TYPE :: seq_type
+ sequence
+ INTEGER(4) :: i
+ END TYPE seq_type
+ INTERFACE WRITE(FORMATTED)
+ MODULE PROCEDURE pwf_seq
+ END INTERFACE
+
+ TYPE, BIND(C) :: bindc_type
+ INTEGER(C_INT) :: i
+ END TYPE bindc_type
+
+ INTERFACE WRITE(FORMATTED)
+ MODULE PROCEDURE pwf_bindc
+ END INTERFACE
+
+ CONTAINS
+ SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg) ! { dg-error "must be of type CLASS" }
+ type(person), INTENT(IN) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ CHARACTER (LEN=*), INTENT(IN) :: iotype
+ INTEGER, INTENT(IN) :: vlist(:)
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ WRITE(unit, FMT = *, IOSTAT=iostat) dtv%name, dtv%age
+ END SUBROUTINE pwf
+
+ SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg) ! { dg-error "must be an ASSUMED SHAPE ARRAY" }
+ CLASS(person), INTENT(INOUT) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ CHARACTER (LEN=*), INTENT(IN) :: iotype
+ INTEGER, INTENT(IN) :: vlist
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age
+ END SUBROUTINE prf
+
+ SUBROUTINE pwuf (dtv,unit,iostat,iomsg) ! { dg-error "must have intent IN" }
+ CLASS(person), INTENT(INOUT) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ WRITE (UNIT=UNIT, FMT = *) DTV%name, DTV%age
+ END SUBROUTINE pwuf
+
+ SUBROUTINE pruf (dtv,unit,iostat,iomsg) ! { dg-error "must be of KIND = 4" }
+ CLASS(person), INTENT(INOUT) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ INTEGER(8), INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age
+ END SUBROUTINE pruf
+
+ SUBROUTINE pwf_seq (dtv,unit,iotype,vlist,iostat,iomsg) ! { dg-error "not extensible|DERIVED" }
+ class(seq_type), INTENT(IN) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ CHARACTER (LEN=*), INTENT(IN) :: iotype
+ INTEGER, INTENT(IN) :: vlist(:)
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ WRITE(unit, FMT = *, IOSTAT=iostat) dtv%i
+ END SUBROUTINE pwf_seq
+
+ SUBROUTINE pwf_bindc (dtv,unit,iotype,vlist,iostat,iomsg) ! { dg-error "not extensible|DERIVED" }
+ class(bindc_type), INTENT(IN) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ CHARACTER (LEN=*), INTENT(IN) :: iotype
+ INTEGER, INTENT(IN) :: vlist(:)
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ WRITE(unit, FMT = *, IOSTAT=iostat) dtv%i
+ END SUBROUTINE pwf_bindc
+
+ END MODULE p
Index: gcc/testsuite/gfortran.dg/dtio_7.f90
===================================================================
*** gcc/testsuite/gfortran.dg/dtio_7.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/dtio_7.f90 (working copy)
***************
*** 0 ****
--- 1,139 ----
+ ! { dg-do run }
+ !
+ ! Tests dtio transfer of arrays of derived types and classes
+ !
+ MODULE p
+ TYPE :: person
+ CHARACTER (LEN=20) :: name
+ INTEGER(4) :: age
+ CONTAINS
+ procedure :: pwf
+ procedure :: prf
+ GENERIC :: WRITE(FORMATTED) => pwf
+ GENERIC :: READ(FORMATTED) => prf
+ END TYPE person
+ type, extends(person) :: employee
+ character(20) :: job_title
+ end type
+ type, extends(person) :: officer
+ character(20) :: position
+ end type
+ type, extends(person) :: member
+ integer :: membership_number
+ end type
+ type :: club
+ type(employee), allocatable :: staff(:)
+ class(person), allocatable :: committee(:)
+ class(person), allocatable :: membership(:)
+ end type
+ CONTAINS
+ SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg)
+ CLASS(person), INTENT(IN) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ CHARACTER (LEN=*), INTENT(IN) :: iotype
+ INTEGER, INTENT(IN) :: vlist(:)
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ select type (dtv)
+ type is (employee)
+ WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Employee"
+ WRITE(unit, FMT = "(A20,I4,A20/)", IOSTAT=iostat) dtv%name, dtv%age, dtv%job_title
+ type is (officer)
+ WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Officer"
+ WRITE(unit, FMT = "(A20,I4,A20/)", IOSTAT=iostat) dtv%name, dtv%age, dtv%position
+ type is (member)
+ WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Member"
+ WRITE(unit, FMT = "(A20,I4,I4/)", IOSTAT=iostat) dtv%name, dtv%age, dtv%membership_number
+ class default
+ WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Ugggh!"
+ WRITE(unit, FMT = "(A20,I4,' '/)", IOSTAT=iostat) dtv%name, dtv%age
+ end select
+ END SUBROUTINE pwf
+
+ SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg)
+ CLASS(person), INTENT(INOUT) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ CHARACTER (LEN=*), INTENT(IN) :: iotype
+ INTEGER, INTENT(IN) :: vlist(:)
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ character (20) :: header, rname, jtitle, oposition
+ integer :: i
+ integer :: no
+ integer :: age
+ iostat = 0
+ select type (dtv)
+
+ type is (employee)
+ read (unit = unit, fmt = *) header
+ READ (UNIT = UNIT, FMT = "(A20,I4,A20)") rname, age, jtitle
+ if (trim (rname) .ne. dtv%name) iostat = 1
+ if (age .ne. dtv%age) iostat = 2
+ if (trim (jtitle) .ne. dtv%job_title) iostat = 3
+ if (iotype .ne. "DTstaff") iostat = 4
+
+ type is (officer)
+ read (unit = unit, fmt = *) header
+ READ (UNIT = UNIT, FMT = "(A20,I4,A20)") rname, age, oposition
+ if (trim (rname) .ne. dtv%name) iostat = 1
+ if (age .ne. dtv%age) iostat = 2
+ if (trim (oposition) .ne. dtv%position) iostat = 3
+ if (iotype .ne. "DTofficers") iostat = 4
+
+ type is (member)
+ read (unit = unit, fmt = *) header
+ READ (UNIT = UNIT, FMT = "(A20,I4,I4)") rname, age, no
+ if (trim (rname) .ne. dtv%name) iostat = 1
+ if (age .ne. dtv%age) iostat = 2
+ if (no .ne. dtv%membership_number) iostat = 3
+ if (iotype .ne. "DTmembers") iostat = 4
+
+ class default
+ call abort
+ end select
+ end subroutine
+ END MODULE p
+
+ PROGRAM test
+ USE p
+
+ type (club) :: social_club
+ TYPE (person) :: chairman
+ CLASS (person), allocatable :: president(:)
+ character (40) :: line
+ integer :: i, j
+
+ allocate (social_club%staff, source = [employee ("Bert",25,"Barman"), &
+ employee ("Joy",16,"Auditor")])
+
+ allocate (social_club%committee, source = [officer ("Hank",32, "Chair"), &
+ officer ("Ann", 29, "Secretary")])
+
+ allocate (social_club%membership, source = [member ("Dan",52,1), &
+ member ("Sue",39,2)])
+
+ chairman%name="Charlie"
+ chairman%age=62
+
+ open (7, status = "scratch")
+ write (7,*) social_club%staff ! Tests array of derived types
+ write (7,*) social_club%committee ! Tests class array
+ do i = 1, size (social_club%membership, 1)
+ write (7,*) social_club%membership(i) ! Tests class array elements
+ end do
+
+ rewind (7)
+ read (7, "(DT'staff')", iostat = i) social_club%staff
+ if (i .ne. 0) call abort
+
+ social_club%committee(2)%age = 33 ! Introduce an error
+
+ read (7, "(DT'officers')", iostat = i) social_club%committee
+ if (i .ne. 2) call abort ! Pick up error
+
+ do j = 1, size (social_club%membership, 1)
+ read (7, "(DT'members')", iostat = i) social_club%membership(j)
+ if (i .ne. 0) call abort
+ end do
+ close (7)
+ END PROGRAM test
Index: gcc/testsuite/gfortran.dg/dtio_8.f90
===================================================================
*** gcc/testsuite/gfortran.dg/dtio_8.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/dtio_8.f90 (working copy)
***************
*** 0 ****
--- 1,65 ----
+ ! { dg-do run }
+ !
+ ! Tests dtio transfer sequence types.
+ !
+ ! Note difficulty at end with comparisons at any level of optimization.
+ !
+ MODULE p
+ TYPE :: person
+ sequence
+ CHARACTER (LEN=20) :: name
+ INTEGER(4) :: age
+ END TYPE person
+ INTERFACE WRITE(UNFORMATTED)
+ MODULE PROCEDURE pwuf
+ END INTERFACE
+ INTERFACE READ(UNFORMATTED)
+ MODULE PROCEDURE pruf
+ END INTERFACE
+
+ CONTAINS
+
+ SUBROUTINE pwuf (dtv,unit,iostat,iomsg)
+ type(person), INTENT(IN) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ WRITE (UNIT=UNIT) DTV%name, DTV%age
+ END SUBROUTINE pwuf
+
+ SUBROUTINE pruf (dtv,unit,iostat,iomsg)
+ type(person), INTENT(INOUT) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ READ (UNIT = UNIT) dtv%name, dtv%age
+ END SUBROUTINE pruf
+
+ END MODULE p
+
+ PROGRAM test
+ USE p
+ TYPE (person) :: chairman
+ character(10) :: line
+
+ chairman%name="Charlie"
+ chairman%age=62
+
+ OPEN (UNIT=71, status = 'scratch', FORM='UNFORMATTED')
+ write (71) chairman
+ rewind (71)
+
+ chairman%name = "Charles"
+ chairman%age = 0
+
+ read (71) chairman
+ close (unit = 71)
+
+ ! Straight comparisons fail at any level of optimization.
+
+ write(line, "(A7)") chairman%name
+ if (trim (line) .ne. "Charlie") call abort
+ line = " "
+ write(line, "(I4)") chairman%age
+ if (trim (line) .eq. " 62") print *, trim(line)
+ END PROGRAM test
Index: gcc/testsuite/gfortran.dg/dtio_9.f90
===================================================================
*** gcc/testsuite/gfortran.dg/dtio_9.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/dtio_9.f90 (working copy)
***************
*** 0 ****
--- 1,66 ----
+ ! { dg-do run }
+ !
+ ! Tests dtio of transfer bind-C types.
+ !
+ ! Note difficulties with c_char at -O1. This is why no character field is used.
+ !
+ MODULE p
+ USE ISO_C_BINDING
+ TYPE, BIND(C) :: person
+ integer(c_int) :: id_no
+ INTEGER(c_int) :: age
+ END TYPE person
+ INTERFACE WRITE(UNFORMATTED)
+ MODULE PROCEDURE pwuf
+ END INTERFACE
+ INTERFACE READ(UNFORMATTED)
+ MODULE PROCEDURE pruf
+ END INTERFACE
+
+ CONTAINS
+
+ SUBROUTINE pwuf (dtv,unit,iostat,iomsg)
+ type(person), INTENT(IN) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ WRITE (UNIT=UNIT) DTV%id_no, DTV%age
+ END SUBROUTINE pwuf
+
+ SUBROUTINE pruf (dtv,unit,iostat,iomsg)
+ type(person), INTENT(INOUT) :: dtv
+ INTEGER, INTENT(IN) :: unit
+ INTEGER, INTENT(OUT) :: iostat
+ CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
+ READ (UNIT = UNIT) dtv%id_no, dtv%age
+ END SUBROUTINE pruf
+
+ END MODULE p
+
+ PROGRAM test
+ USE p
+ TYPE (person) :: chairman
+ CHARACTER (kind=c_char) :: cname(20)
+ integer (c_int) :: cage, cid_no
+ character(10) :: line
+
+ cid_no = 1
+ cage = 62
+ chairman%id_no = cid_no
+ chairman%age = cage
+
+ OPEN (UNIT=71, status = 'scratch', FORM='UNFORMATTED')
+ write (71) chairman
+ rewind (71)
+
+ chairman%id_no = 0
+ chairman%age = 0
+
+ read (71) chairman
+ close (unit = 71)
+
+ write(line, "(I4)") chairman%id_no
+ if (trim (line) .ne. " 1") call abort
+ write(line, "(I4)") chairman%age
+ if (trim (line) .ne. " 62") call abort
+ end program
Index: libgfortran/gfortran.map
===================================================================
*** libgfortran/gfortran.map (revision 239769)
--- libgfortran/gfortran.map (working copy)
*************** GFORTRAN_1.7 {
*** 1289,1294 ****
--- 1289,1299 ----
_gfortran_shape_2;
} GFORTRAN_1.6;
+ GFORTRAN_1.8 {
+ global:
+ _gfortran_transfer_derived;
+ } GFORTRAN_1.7;
+
F2C_1.0 {
global:
_gfortran_f2c_specific__abs_c4;
Index: libgfortran/io/format.c
===================================================================
*** libgfortran/io/format.c (revision 239769)
--- libgfortran/io/format.c (working copy)
*************** void
*** 261,271 ****
free_format_data (format_data *fmt)
{
fnode_array *fa, *fa_next;
!
if (fmt == NULL)
return;
for (fa = fmt->array.next; fa; fa = fa_next)
{
fa_next = fa->next;
--- 261,280 ----
free_format_data (format_data *fmt)
{
fnode_array *fa, *fa_next;
! fnode *fnp;
if (fmt == NULL)
return;
+ /* Free vlist descriptors in the fnode_array if one was allocated. */
+ for (fnp = fmt->array.array; fnp->format != FMT_NONE; fnp++)
+ if (fnp->format == FMT_DT)
+ {
+ if (GFC_DESCRIPTOR_DATA(fnp->u.udf.vlist))
+ free (GFC_DESCRIPTOR_DATA(fnp->u.udf.vlist));
+ free (fnp->u.udf.vlist);
+ }
+
for (fa = fmt->array.next; fa; fa = fa_next)
{
fa_next = fa->next;
*************** format_lex (format_data *fmt)
*** 545,550 ****
--- 554,562 ----
case 'C':
token = FMT_DC;
break;
+ case 'T':
+ token = FMT_DT;
+ break;
default:
token = FMT_D;
unget_char (fmt);
*************** parse_format_list (st_parameter_dt *dtp,
*** 806,811 ****
--- 818,824 ----
case FMT_EN:
case FMT_ES:
case FMT_D:
+ case FMT_DT:
case FMT_L:
case FMT_A:
case FMT_F:
*************** parse_format_list (st_parameter_dt *dtp,
*** 849,854 ****
--- 862,868 ----
/* In this state, t must currently be a data descriptor. Deal with
things that can/must follow the descriptor */
data_desc:
+
switch (t)
{
case FMT_L:
*************** parse_format_list (st_parameter_dt *dtp,
*** 997,1003 ****
--- 1011,1067 ----
}
break;
+ case FMT_DT:
+ *seen_dd = true;
+ get_fnode (fmt, &head, &tail, t);
+ tail->repeat = repeat;
+
+ t = format_lex (fmt);
+ /* Initialize the vlist to a zero size array. */
+ tail->u.udf.vlist= xmalloc (sizeof(gfc_array_i4));
+ GFC_DESCRIPTOR_DATA(tail->u.udf.vlist) = NULL;
+ GFC_DIMENSION_SET(tail->u.udf.vlist->dim[0],1, 0, 0);
+
+ if (t == FMT_STRING)
+ {
+ /* Get pointer to the optional format string. */
+ tail->u.udf.string = fmt->string;
+ tail->u.udf.string_len = fmt->value;
+ t = format_lex (fmt);
+ }
+ if (t == FMT_LPAREN)
+ {
+ /* Temporary buffer to hold the vlist values. */
+ GFC_INTEGER_4 temp[FARRAY_SIZE];
+ int i = 0;
+ loop:
+ t = format_lex (fmt);
+ if (t != FMT_POSINT)
+ {
+ fmt->error = posint_required;
+ goto finished;
+ }
+ /* Save the positive integer value. */
+ temp[i++] = fmt->value;
+ t = format_lex (fmt);
+ if (t == FMT_COMMA)
+ goto loop;
+ if (t == FMT_RPAREN)
+ {
+ /* We have parsed the complete vlist so initialize the
+ array descriptor and save it in the format node. */
+ gfc_array_i4 *vp = tail->u.udf.vlist;
+ GFC_DESCRIPTOR_DATA(vp) = xmalloc (i * sizeof(GFC_INTEGER_4));
+ GFC_DIMENSION_SET(vp->dim[0],1, i, 1);
+ memcpy (GFC_DESCRIPTOR_DATA(vp), temp, i * sizeof(GFC_INTEGER_4));
+ break;
+ }
+ fmt->error = unexpected_element;
+ goto finished;
+ }
+ fmt->saved_token = t;
+ break;
case FMT_H:
if (repeat > fmt->format_string_len)
{
*************** parse_format (st_parameter_dt *dtp)
*** 1219,1227 ****
format_data *fmt;
bool format_cache_ok, seen_data_desc = false;
! /* Don't cache for internal units and set an arbitrary limit on the size of
! format strings we will cache. (Avoids memory issues.) */
! format_cache_ok = !is_internal_unit (dtp);
/* Lookup format string to see if it has already been parsed. */
if (format_cache_ok)
--- 1283,1294 ----
format_data *fmt;
bool format_cache_ok, seen_data_desc = false;
! /* Don't cache for internal units and set an arbitrary limit on the
! size of format strings we will cache. (Avoids memory issues.)
! Also, the format_hash_table resides in the current_unit, so
! child_dtio procedures would overwrite the parent table */
! format_cache_ok = !is_internal_unit (dtp)
! && (dtp->u.p.current_unit->child_dtio == 0);
/* Lookup format string to see if it has already been parsed. */
if (format_cache_ok)
*************** parse_format (st_parameter_dt *dtp)
*** 1257,1262 ****
--- 1324,1333 ----
fmt->reversion_ok = 0;
fmt->saved_format = NULL;
+ /* Initialize the fnode_array. */
+
+ memset (&(fmt->array), 0, sizeof(fmt->array));
+
/* Allocate the first format node as the root of the tree. */
fmt->last = &fmt->array;
*************** next_format (st_parameter_dt *dtp)
*** 1392,1398 ****
if (!fmt->reversion_ok &&
(t == FMT_I || t == FMT_B || t == FMT_O || t == FMT_Z || t == FMT_F ||
t == FMT_E || t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_L ||
! t == FMT_A || t == FMT_D))
fmt->reversion_ok = 1;
return f;
}
--- 1463,1469 ----
if (!fmt->reversion_ok &&
(t == FMT_I || t == FMT_B || t == FMT_O || t == FMT_Z || t == FMT_F ||
t == FMT_E || t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_L ||
! t == FMT_A || t == FMT_D || t == FMT_DT))
fmt->reversion_ok = 1;
return f;
}
Index: libgfortran/io/format.h
===================================================================
*** libgfortran/io/format.h (revision 239769)
--- libgfortran/io/format.h (working copy)
*************** typedef enum
*** 38,44 ****
FMT_LPAREN, FMT_RPAREN, FMT_X, FMT_S, FMT_SS, FMT_SP, FMT_STRING,
FMT_BADSTRING, FMT_P, FMT_I, FMT_B, FMT_BN, FMT_BZ, FMT_O, FMT_Z, FMT_F,
FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_DC,
! FMT_DP, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ
}
format_token;
--- 38,44 ----
FMT_LPAREN, FMT_RPAREN, FMT_X, FMT_S, FMT_SS, FMT_SP, FMT_STRING,
FMT_BADSTRING, FMT_P, FMT_I, FMT_B, FMT_BN, FMT_BZ, FMT_O, FMT_Z, FMT_F,
FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_DC,
! FMT_DP, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT
}
format_token;
*************** struct fnode
*** 74,79 ****
--- 74,87 ----
}
integer;
+ struct
+ {
+ char *string;
+ int string_len;
+ gfc_array_i4 *vlist;
+ }
+ udf; /* User Defined Format. */
+
int w;
int k;
int r;
Index: libgfortran/io/io.h
===================================================================
*** libgfortran/io/io.h (revision 239769)
--- libgfortran/io/io.h (working copy)
*************** typedef struct array_loop_spec
*** 94,99 ****
--- 94,123 ----
}
array_loop_spec;
+ /* User defined input/output iomsg length. */
+
+ #define IOMSG_LEN 256
+
+ /* Subroutine formatted_dtio (struct, unit, iotype, v_list, iostat,
+ iomsg, (_iotype), (_iomsg)) */
+ typedef void (*formatted_dtio)(void *, GFC_INTEGER_4 *, char *, gfc_array_i4 *,
+ GFC_INTEGER_4 *, char *,
+ gfc_charlen_type, gfc_charlen_type);
+
+ /* Subroutine unformatted_dtio (struct, unit, iostat, iomsg, (_iomsg)) */
+ typedef void (*unformatted_dtio)(void *, GFC_INTEGER_4 *, GFC_INTEGER_4 *,
+ char *, gfc_charlen_type);
+
+ /* The dtio calls for namelist require a CLASS object to be built. */
+ typedef struct gfc_class
+ {
+ void *data;
+ void *vptr;
+ index_type len;
+ }
+ gfc_class;
+
+
/* A structure to build a hash table for format data. */
#define FORMAT_HASH_SIZE 16
*************** typedef struct namelist_type
*** 136,141 ****
--- 160,171 ----
/* Address for the start of the object's data. */
void * mem_pos;
+ /* Address of specific DTIO subroutine. */
+ void * dtio_sub;
+
+ /* Address of vtable if dtio_sub non-null. */
+ void * vtable;
+
/* Flag to show that a read is to be attempted for this node. */
int touched;
*************** typedef struct st_parameter_dt
*** 462,468 ****
/* Used for ungetc() style functionality. Possible values
are an unsigned char, EOF, or EOF - 1 used to mark the
field as not valid. */
! int last_char;
char nml_delim;
int repeat_count;
--- 492,498 ----
/* Used for ungetc() style functionality. Possible values
are an unsigned char, EOF, or EOF - 1 used to mark the
field as not valid. */
! int last_char; /* No longer used, moved to gfc_unit. */
char nml_delim;
int repeat_count;
*************** typedef struct st_parameter_dt
*** 484,489 ****
--- 514,521 ----
largest kind. */
char value[32];
GFC_IO_INT size_used;
+ formatted_dtio fdtio_ptr;
+ unformatted_dtio ufdtio_ptr;
} p;
/* This pad size must be equal to the pad_size declared in
trans-io.c (gfc_build_io_library_fndecls). The above structure
*************** typedef struct gfc_unit
*** 607,612 ****
--- 639,648 ----
/* Function pointer, points to list_read worker functions. */
int (*next_char_fn_ptr) (st_parameter_dt *);
void (*push_char_fn_ptr) (st_parameter_dt *, int);
+
+ /* DTIO Parent/Child procedure, 0 = parent, >0 = child level. */
+ int child_dtio;
+ int last_char;
}
gfc_unit;
*************** internal_proto(read_radix);
*** 728,733 ****
--- 764,775 ----
extern void read_decimal (st_parameter_dt *, const fnode *, char *, int);
internal_proto(read_decimal);
+ extern void read_user_defined (st_parameter_dt *, void *);
+ internal_proto(read_user_defined);
+
+ extern void read_user_defined (st_parameter_dt *, void *);
+ internal_proto(read_user_defined);
+
/* list_read.c */
extern void list_formatted_read (st_parameter_dt *, bt, void *, int, size_t,
*************** internal_proto(write_x);
*** 790,795 ****
--- 832,843 ----
extern void write_z (st_parameter_dt *, const fnode *, const char *, int);
internal_proto(write_z);
+ extern void write_user_defined (st_parameter_dt *, void *);
+ internal_proto(write_user_defined);
+
+ extern void write_user_defined (st_parameter_dt *, void *);
+ internal_proto(write_user_defined);
+
extern void list_formatted_write (st_parameter_dt *, bt, void *, int, size_t,
size_t);
internal_proto(list_formatted_write);
Index: libgfortran/io/list_read.c
===================================================================
*** libgfortran/io/list_read.c (revision 239769)
--- libgfortran/io/list_read.c (working copy)
*************** push_char_default (st_parameter_dt *dtp,
*** 84,90 ****
if (dtp->u.p.saved_string == NULL)
{
! // Plain malloc should suffice here, zeroing not needed?
dtp->u.p.saved_string = xcalloc (SCRATCH_SIZE, 1);
dtp->u.p.saved_length = SCRATCH_SIZE;
dtp->u.p.saved_used = 0;
--- 84,90 ----
if (dtp->u.p.saved_string == NULL)
{
! /* Plain malloc should suffice here, zeroing not needed? */
dtp->u.p.saved_string = xcalloc (SCRATCH_SIZE, 1);
dtp->u.p.saved_length = SCRATCH_SIZE;
dtp->u.p.saved_used = 0;
*************** check_buffers (st_parameter_dt *dtp)
*** 170,180 ****
int c;
c = '\0';
! if (dtp->u.p.last_char != EOF - 1)
{
dtp->u.p.at_eol = 0;
! c = dtp->u.p.last_char;
! dtp->u.p.last_char = EOF - 1;
goto done;
}
--- 170,180 ----
int c;
c = '\0';
! if (dtp->u.p.current_unit->last_char != EOF - 1)
{
dtp->u.p.at_eol = 0;
! c = dtp->u.p.current_unit->last_char;
! dtp->u.p.current_unit->last_char = EOF - 1;
goto done;
}
*************** utf_done:
*** 369,375 ****
static void
unget_char (st_parameter_dt *dtp, int c)
{
! dtp->u.p.last_char = c;
}
--- 369,375 ----
static void
unget_char (st_parameter_dt *dtp, int c)
{
! dtp->u.p.current_unit->last_char = c;
}
*************** eat_spaces (st_parameter_dt *dtp)
*** 385,391 ****
This is an optimization unique to character arrays with large
character lengths (PR38199). This code eliminates numerous calls
to next_character. */
! if (is_array_io (dtp) && (dtp->u.p.last_char == EOF - 1))
{
gfc_offset offset = stell (dtp->u.p.current_unit->s);
gfc_offset i;
--- 385,391 ----
This is an optimization unique to character arrays with large
character lengths (PR38199). This code eliminates numerous calls
to next_character. */
! if (is_array_io (dtp) && (dtp->u.p.current_unit->last_char == EOF - 1))
{
gfc_offset offset = stell (dtp->u.p.current_unit->s);
gfc_offset i;
*************** list_formatted_read_scalar (st_parameter
*** 2167,2172 ****
--- 2167,2212 ----
if (dtp->u.p.repeat_count > 0)
memcpy (dtp->u.p.value, p, size);
break;
+ case BT_CLASS:
+ {
+ int unit = dtp->u.p.current_unit->unit_number;
+ char iotype[] = "LISTDIRECTED";
+ gfc_charlen_type iotype_len = 12;
+ char tmp_iomsg[IOMSG_LEN] = "";
+ char *child_iomsg;
+ gfc_charlen_type child_iomsg_len;
+ int noiostat;
+ int *child_iostat = NULL;
+ gfc_array_i4 vlist;
+
+ GFC_DESCRIPTOR_DATA(&vlist) = NULL;
+ GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
+
+ /* Set iostat, intent(out). */
+ noiostat = 0;
+ child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
+ dtp->common.iostat : &noiostat;
+
+ /* Set iomsge, intent(inout). */
+ if (dtp->common.flags & IOPARM_HAS_IOMSG)
+ {
+ child_iomsg = dtp->common.iomsg;
+ child_iomsg_len = dtp->common.iomsg_len;
+ }
+ else
+ {
+ child_iomsg = tmp_iomsg;
+ child_iomsg_len = IOMSG_LEN;
+ }
+
+ /* Call the user defined formatted READ procedure. */
+ dtp->u.p.current_unit->child_dtio++;
+ dtp->u.p.fdtio_ptr (p, &unit, iotype, &vlist,
+ child_iostat, child_iomsg,
+ iotype_len, child_iomsg_len);
+ dtp->u.p.current_unit->child_dtio--;
+ }
+ break;
default:
internal_error (&dtp->common, "Bad type for list read");
}
*************** get_name:
*** 3206,3211 ****
--- 3246,3298 ----
goto nml_err_ret;
}
+ else if (nl->dtio_sub != NULL)
+ {
+ int unit = dtp->u.p.current_unit->unit_number;
+ char iotype[] = "NAMELIST";
+ gfc_charlen_type iotype_len = 8;
+ char tmp_iomsg[IOMSG_LEN] = "";
+ char *child_iomsg;
+ gfc_charlen_type child_iomsg_len;
+ int noiostat;
+ int *child_iostat = NULL;
+ gfc_array_i4 vlist;
+ gfc_class list_obj;
+ formatted_dtio dtio_ptr = (formatted_dtio)nl->dtio_sub;
+
+ GFC_DESCRIPTOR_DATA(&vlist) = NULL;
+ GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
+
+ list_obj.data = (void *)nl->mem_pos;
+ list_obj.vptr = nl->vtable;
+ list_obj.len = 0;
+
+ /* Set iostat, intent(out). */
+ noiostat = 0;
+ child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
+ dtp->common.iostat : &noiostat;
+
+ /* Set iomsg, intent(inout). */
+ if (dtp->common.flags & IOPARM_HAS_IOMSG)
+ {
+ child_iomsg = dtp->common.iomsg;
+ child_iomsg_len = dtp->common.iomsg_len;
+ }
+ else
+ {
+ child_iomsg = tmp_iomsg;
+ child_iomsg_len = IOMSG_LEN;
+ }
+
+ /* Call the user defined formatted READ procedure. */
+ dtp->u.p.current_unit->child_dtio++;
+ dtio_ptr ((void *)&list_obj, &unit, iotype, &vlist,
+ child_iostat, child_iomsg,
+ iotype_len, child_iomsg_len);
+ dtp->u.p.current_unit->child_dtio--;
+
+ return true;
+ }
/* Get the length, data length, base pointer and rank of the variable.
Set the default loop specification first. */
Index: libgfortran/io/transfer.c
===================================================================
*** libgfortran/io/transfer.c (revision 239769)
--- libgfortran/io/transfer.c (working copy)
*************** extern void transfer_array_write (st_par
*** 122,127 ****
--- 122,136 ----
gfc_charlen_type);
export_proto(transfer_array_write);
+ /* User defined derived type input/output. */
+ extern void
+ transfer_derived (st_parameter_dt *dtp, void *dtio_source, void *dtio_proc);
+ export_proto(transfer_derived);
+
+ extern void
+ transfer_derived_write (st_parameter_dt *dtp, void *dtio_source, void *dtio_proc);
+ export_proto(transfer_derived_write);
+
static void us_read (st_parameter_dt *, int);
static void us_write (st_parameter_dt *, int);
static void next_record_r_unf (st_parameter_dt *, int);
*************** static void
*** 988,993 ****
--- 997,1036 ----
unformatted_read (st_parameter_dt *dtp, bt type,
void *dest, int kind, size_t size, size_t nelems)
{
+ if (type == BT_CLASS)
+ {
+ int unit = dtp->u.p.current_unit->unit_number;
+ char tmp_iomsg[IOMSG_LEN] = "";
+ char *child_iomsg;
+ gfc_charlen_type child_iomsg_len;
+ int noiostat;
+ int *child_iostat = NULL;
+
+ /* Set iostat, intent(out). */
+ noiostat = 0;
+ child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
+ dtp->common.iostat : &noiostat;
+
+ /* Set iomsg, intent(inout). */
+ if (dtp->common.flags & IOPARM_HAS_IOMSG)
+ {
+ child_iomsg = dtp->common.iomsg;
+ child_iomsg_len = dtp->common.iomsg_len;
+ }
+ else
+ {
+ child_iomsg = tmp_iomsg;
+ child_iomsg_len = IOMSG_LEN;
+ }
+
+ /* Call the user defined unformatted READ procedure. */
+ dtp->u.p.current_unit->child_dtio++;
+ dtp->u.p.ufdtio_ptr (dest, &unit, child_iostat, child_iomsg,
+ child_iomsg_len);
+ dtp->u.p.current_unit->child_dtio--;
+ return;
+ }
+
if (type == BT_CHARACTER)
size *= GFC_SIZE_OF_CHAR_KIND(kind);
read_block_direct (dtp, dest, size * nelems);
*************** unformatted_read (st_parameter_dt *dtp,
*** 1016,1027 ****
/* Master function for unformatted writes. NOTE: For kind=10 the size is 16
bytes on 64 bit machines. The unused bytes are not initialized and never
used, which can show an error with memory checking analyzers like
! valgrind. */
static void
unformatted_write (st_parameter_dt *dtp, bt type,
void *source, int kind, size_t size, size_t nelems)
{
if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
|| kind == 1)
{
--- 1059,1104 ----
/* Master function for unformatted writes. NOTE: For kind=10 the size is 16
bytes on 64 bit machines. The unused bytes are not initialized and never
used, which can show an error with memory checking analyzers like
! valgrind. We us BT_CLASS to denote a User Defined I/O call. */
static void
unformatted_write (st_parameter_dt *dtp, bt type,
void *source, int kind, size_t size, size_t nelems)
{
+ if (type == BT_CLASS)
+ {
+ int unit = dtp->u.p.current_unit->unit_number;
+ char tmp_iomsg[IOMSG_LEN] = "";
+ char *child_iomsg;
+ gfc_charlen_type child_iomsg_len;
+ int noiostat;
+ int *child_iostat = NULL;
+
+ /* Set iostat, intent(out). */
+ noiostat = 0;
+ child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
+ dtp->common.iostat : &noiostat;
+
+ /* Set iomsg, intent(inout). */
+ if (dtp->common.flags & IOPARM_HAS_IOMSG)
+ {
+ child_iomsg = dtp->common.iomsg;
+ child_iomsg_len = dtp->common.iomsg_len;
+ }
+ else
+ {
+ child_iomsg = tmp_iomsg;
+ child_iomsg_len = IOMSG_LEN;
+ }
+
+ /* Call the user defined unformatted WRITE procedure. */
+ dtp->u.p.current_unit->child_dtio++;
+ dtp->u.p.ufdtio_ptr (source, &unit, child_iostat, child_iomsg,
+ child_iomsg_len);
+ dtp->u.p.current_unit->child_dtio--;
+ return;
+ }
+
if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
|| kind == 1)
{
*************** type_name (bt type)
*** 1099,1104 ****
--- 1176,1184 ----
case BT_COMPLEX:
p = "COMPLEX";
break;
+ case BT_CLASS:
+ p = "CLASS or DERIVED";
+ break;
default:
internal_error (NULL, "type_name(): Bad type");
}
*************** formatted_transfer_scalar_read (st_param
*** 1322,1327 ****
--- 1402,1466 ----
read_f (dtp, f, p, kind);
break;
+ case FMT_DT:
+ if (n == 0)
+ goto need_read_data;
+ if (require_type (dtp, BT_CLASS, type, f))
+ return;
+ int unit = dtp->u.p.current_unit->unit_number;
+ char dt[] = "DT";
+ char tmp_iomsg[IOMSG_LEN] = "";
+ char *child_iomsg;
+ gfc_charlen_type child_iomsg_len;
+ int noiostat;
+ int *child_iostat = NULL;
+ char *iotype = f->u.udf.string;
+ gfc_charlen_type iotype_len = f->u.udf.string_len;
+
+ /* Build the iotype string. */
+ if (iotype_len == 0)
+ {
+ iotype_len = 2;
+ iotype = dt;
+ }
+ else
+ {
+ iotype_len += 2;
+ iotype = xmalloc (iotype_len);
+ iotype[0] = dt[0];
+ iotype[1] = dt[1];
+ memcpy (iotype + 2, f->u.udf.string, f->u.udf.string_len);
+ }
+
+ /* Set iostat, intent(out). */
+ noiostat = 0;
+ child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
+ dtp->common.iostat : &noiostat;
+
+ /* Set iomsg, intent(inout). */
+ if (dtp->common.flags & IOPARM_HAS_IOMSG)
+ {
+ child_iomsg = dtp->common.iomsg;
+ child_iomsg_len = dtp->common.iomsg_len;
+ }
+ else
+ {
+ child_iomsg = tmp_iomsg;
+ child_iomsg_len = IOMSG_LEN;
+ }
+
+ /* Call the user defined formatted READ procedure. */
+ dtp->u.p.current_unit->child_dtio++;
+ dtp->u.p.fdtio_ptr (p, &unit, iotype, f->u.udf.vlist,
+ child_iostat, child_iomsg,
+ iotype_len, child_iomsg_len);
+ dtp->u.p.current_unit->child_dtio--;
+
+ if (f->u.udf.string_len != 0)
+ free (iotype);
+ /* Note: vlist is freed in free_format_data. */
+ break;
+
case FMT_E:
if (n == 0)
goto need_read_data;
*************** formatted_transfer_scalar_write (st_para
*** 1630,1636 ****
&& ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O
|| t == FMT_Z || t == FMT_F || t == FMT_E
|| t == FMT_EN || t == FMT_ES || t == FMT_G
! || t == FMT_L || t == FMT_A || t == FMT_D))
|| t == FMT_STRING))
{
if (dtp->u.p.skips > 0)
--- 1769,1776 ----
&& ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O
|| t == FMT_Z || t == FMT_F || t == FMT_E
|| t == FMT_EN || t == FMT_ES || t == FMT_G
! || t == FMT_L || t == FMT_A || t == FMT_D
! || t == FMT_DT))
|| t == FMT_STRING))
{
if (dtp->u.p.skips > 0)
*************** formatted_transfer_scalar_write (st_para
*** 1733,1738 ****
--- 1873,1935 ----
write_d (dtp, f, p, kind);
break;
+ case FMT_DT:
+ if (n == 0)
+ goto need_data;
+ int unit = dtp->u.p.current_unit->unit_number;
+ char dt[] = "DT";
+ char tmp_iomsg[IOMSG_LEN] = "";
+ char *child_iomsg;
+ gfc_charlen_type child_iomsg_len;
+ int noiostat;
+ int *child_iostat = NULL;
+ char *iotype = f->u.udf.string;
+ gfc_charlen_type iotype_len = f->u.udf.string_len;
+
+ /* Build the iotype string. */
+ if (iotype_len == 0)
+ {
+ iotype_len = 2;
+ iotype = dt;
+ }
+ else
+ {
+ iotype_len += 2;
+ iotype = xmalloc (iotype_len);
+ iotype[0] = dt[0];
+ iotype[1] = dt[1];
+ memcpy (iotype + 2, f->u.udf.string, f->u.udf.string_len);
+ }
+
+ /* Set iostat, intent(out). */
+ noiostat = 0;
+ child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
+ dtp->common.iostat : &noiostat;
+
+ /* Set iomsg, intent(inout). */
+ if (dtp->common.flags & IOPARM_HAS_IOMSG)
+ {
+ child_iomsg = dtp->common.iomsg;
+ child_iomsg_len = dtp->common.iomsg_len;
+ }
+ else
+ {
+ child_iomsg = tmp_iomsg;
+ child_iomsg_len = IOMSG_LEN;
+ }
+
+ /* Call the user defined formatted WRITE procedure. */
+ dtp->u.p.current_unit->child_dtio++;
+ dtp->u.p.fdtio_ptr (p, &unit, iotype, f->u.udf.vlist,
+ child_iostat, child_iomsg,
+ iotype_len, child_iomsg_len);
+ dtp->u.p.current_unit->child_dtio--;
+
+ if (f->u.udf.string_len != 0)
+ free (iotype);
+ /* Note: vlist is freed in free_format_data. */
+ break;
+
case FMT_E:
if (n == 0)
goto need_data;
*************** transfer_array_write (st_parameter_dt *d
*** 2198,2203 ****
--- 2395,2419 ----
transfer_array (dtp, desc, kind, charlen);
}
+
+ /* User defined input/output iomsg. */
+
+ #define IOMSG_LEN 256
+
+ void
+ transfer_derived (st_parameter_dt *parent, void *dtio_source, void *dtio_proc)
+ {
+ if (parent->u.p.current_unit)
+ {
+ if (parent->u.p.current_unit->flags.form == FORM_UNFORMATTED)
+ parent->u.p.ufdtio_ptr = (unformatted_dtio) dtio_proc;
+ else
+ parent->u.p.fdtio_ptr = (formatted_dtio) dtio_proc;
+ }
+ parent->u.p.transfer (parent, BT_CLASS, dtio_source, 0, 0, 1);
+ }
+
+
/* Preposition a sequential unformatted file while reading. */
static void
*************** data_transfer_init (st_parameter_dt *dtp
*** 2384,2389 ****
--- 2600,2606 ----
dtp->u.p.size_used = 0; /* Initialize the count. */
dtp->u.p.current_unit = get_unit (dtp, 1);
+
if (dtp->u.p.current_unit->s == NULL)
{ /* Open the unit with some default flags. */
st_parameter_open opp;
*************** data_transfer_init (st_parameter_dt *dtp
*** 2542,2548 ****
"EOF marker, possibly use REWIND or BACKSPACE");
return;
}
-
}
/* Process the ADVANCE option. */
--- 2759,2764 ----
*************** data_transfer_init (st_parameter_dt *dtp
*** 2834,2840 ****
{
if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
{
! dtp->u.p.last_char = EOF - 1;
dtp->u.p.transfer = list_formatted_read;
}
else
--- 3050,3057 ----
{
if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
{
! if (dtp->u.p.current_unit->child_dtio == 0)
! dtp->u.p.current_unit->last_char = EOF - 1;
dtp->u.p.transfer = list_formatted_read;
}
else
*************** finalize_transfer (st_parameter_dt *dtp)
*** 3540,3545 ****
--- 3757,3774 ----
{
GFC_INTEGER_4 cf = dtp->common.flags;
+ if ((dtp->u.p.ionml != NULL)
+ && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
+ {
+ if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
+ namelist_read (dtp);
+ else
+ namelist_write (dtp);
+ }
+
+ if (dtp->u.p.current_unit && (dtp->u.p.current_unit->child_dtio > 0))
+ return;
+
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
*dtp->size = dtp->u.p.size_used;
*************** finalize_transfer (st_parameter_dt *dtp)
*** 3556,3570 ****
goto done;
}
- if ((dtp->u.p.ionml != NULL)
- && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
- {
- if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
- namelist_read (dtp);
- else
- namelist_write (dtp);
- }
-
dtp->u.p.transfer = NULL;
if (dtp->u.p.current_unit == NULL)
goto done;
--- 3785,3790 ----
*************** st_write_done (st_parameter_dt *dtp)
*** 3760,3766 ****
/* Deal with endfile conditions associated with sequential files. */
if (dtp->u.p.current_unit != NULL
! && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
switch (dtp->u.p.current_unit->endfile)
{
case AT_ENDFILE: /* Remain at the endfile record. */
--- 3980,3987 ----
/* Deal with endfile conditions associated with sequential files. */
if (dtp->u.p.current_unit != NULL
! && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
! && dtp->u.p.current_unit->child_dtio == 0)
switch (dtp->u.p.current_unit->endfile)
{
case AT_ENDFILE: /* Remain at the endfile record. */
*************** st_wait (st_parameter_wait *wtp __attrib
*** 3808,3821 ****
in a linked list of namelist_info types. */
extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
! GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
export_proto(st_set_nml_var);
void
st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
GFC_INTEGER_4 len, gfc_charlen_type string_length,
! GFC_INTEGER_4 dtype)
{
namelist_info *t1 = NULL;
namelist_info *nml;
--- 4029,4043 ----
in a linked list of namelist_info types. */
extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
! GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4,
! void *, void *);
export_proto(st_set_nml_var);
void
st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
GFC_INTEGER_4 len, gfc_charlen_type string_length,
! GFC_INTEGER_4 dtype, void *dtio_sub, void *vtable)
{
namelist_info *t1 = NULL;
namelist_info *nml;
*************** st_set_nml_var (st_parameter_dt *dtp, vo
*** 3824,3829 ****
--- 4046,4053 ----
nml = (namelist_info*) xmalloc (sizeof (namelist_info));
nml->mem_pos = var_addr;
+ nml->dtio_sub = dtio_sub;
+ nml->vtable = vtable;
nml->var_name = (char*) xmalloc (var_name_len + 1);
memcpy (nml->var_name, var_name, var_name_len);
Index: libgfortran/io/unit.c
===================================================================
*** libgfortran/io/unit.c (revision 239769)
--- libgfortran/io/unit.c (working copy)
*************** retry:
*** 348,354 ****
}
found:
! if (p != NULL)
{
/* Fast path. */
if (! __gthread_mutex_trylock (&p->lock))
--- 348,354 ----
}
found:
! if (p != NULL && (p->child_dtio == 0))
{
/* Fast path. */
if (! __gthread_mutex_trylock (&p->lock))
*************** found:
*** 363,369 ****
__gthread_mutex_unlock (&unit_lock);
! if (p != NULL)
{
__gthread_mutex_lock (&p->lock);
if (p->closed)
--- 363,369 ----
__gthread_mutex_unlock (&unit_lock);
! if (p != NULL && (p->child_dtio == 0))
{
__gthread_mutex_lock (&p->lock);
if (p->closed)
Index: libgfortran/io/unix.c
===================================================================
*** libgfortran/io/unix.c (revision 239769)
--- libgfortran/io/unix.c (working copy)
*************** tempfile_open (const char *tempdir, char
*** 1121,1127 ****
)
slash = "";
! // Take care that the template is longer in the mktemp() branch.
char * template = xmalloc (tempdirlen + 23);
#ifdef HAVE_MKSTEMP
--- 1121,1127 ----
)
slash = "";
! /* Take care that the template is longer in the mktemp() branch. */
char * template = xmalloc (tempdirlen + 23);
#ifdef HAVE_MKSTEMP
Index: libgfortran/io/write.c
===================================================================
*** libgfortran/io/write.c (revision 239769)
--- libgfortran/io/write.c (working copy)
*************** list_formatted_write_scalar (st_paramete
*** 1710,1715 ****
--- 1710,1755 ----
case BT_COMPLEX:
write_complex (dtp, p, kind, size);
break;
+ case BT_CLASS:
+ {
+ int unit = dtp->u.p.current_unit->unit_number;
+ char iotype[] = "LISTDIRECTED";
+ gfc_charlen_type iotype_len = 12;
+ char tmp_iomsg[IOMSG_LEN] = "";
+ char *child_iomsg;
+ gfc_charlen_type child_iomsg_len;
+ int noiostat;
+ int *child_iostat = NULL;
+ gfc_array_i4 vlist;
+
+ GFC_DESCRIPTOR_DATA(&vlist) = NULL;
+ GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
+
+ /* Set iostat, intent(out). */
+ noiostat = 0;
+ child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
+ dtp->common.iostat : &noiostat;
+
+ /* Set iomsge, intent(inout). */
+ if (dtp->common.flags & IOPARM_HAS_IOMSG)
+ {
+ child_iomsg = dtp->common.iomsg;
+ child_iomsg_len = dtp->common.iomsg_len;
+ }
+ else
+ {
+ child_iomsg = tmp_iomsg;
+ child_iomsg_len = IOMSG_LEN;
+ }
+
+ /* Call the user defined formatted WRITE procedure. */
+ dtp->u.p.current_unit->child_dtio++;
+ dtp->u.p.fdtio_ptr (p, &unit, iotype, &vlist,
+ child_iostat, child_iomsg,
+ iotype_len, child_iomsg_len);
+ dtp->u.p.current_unit->child_dtio--;
+ }
+ break;
default:
internal_error (&dtp->common, "list_formatted_write(): Bad type");
}
*************** nml_write_obj (st_parameter_dt *dtp, nam
*** 1985,1991 ****
break;
case BT_DERIVED:
!
/* To treat a derived type, we need to build two strings:
ext_name = the name, including qualifiers that prepends
component names in the output - passed to
--- 2025,2031 ----
break;
case BT_DERIVED:
! case BT_CLASS:
/* To treat a derived type, we need to build two strings:
ext_name = the name, including qualifiers that prepends
component names in the output - passed to
*************** nml_write_obj (st_parameter_dt *dtp, nam
*** 1995,2000 ****
--- 2035,2086 ----
components. */
/* First ext_name => get length of all possible components */
+ if (obj->dtio_sub != NULL)
+ {
+ int unit = dtp->u.p.current_unit->unit_number;
+ char iotype[] = "NAMELIST";
+ gfc_charlen_type iotype_len = 8;
+ char tmp_iomsg[IOMSG_LEN] = "";
+ char *child_iomsg;
+ gfc_charlen_type child_iomsg_len;
+ int noiostat;
+ int *child_iostat = NULL;
+ gfc_array_i4 vlist;
+ gfc_class list_obj;
+ formatted_dtio dtio_ptr = (formatted_dtio)obj->dtio_sub;
+
+ GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
+
+ list_obj.data = p;
+ list_obj.vptr = obj->vtable;
+ list_obj.len = 0;
+
+ /* Set iostat, intent(out). */
+ noiostat = 0;
+ child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
+ dtp->common.iostat : &noiostat;
+
+ /* Set iomsg, intent(inout). */
+ if (dtp->common.flags & IOPARM_HAS_IOMSG)
+ {
+ child_iomsg = dtp->common.iomsg;
+ child_iomsg_len = dtp->common.iomsg_len;
+ }
+ else
+ {
+ child_iomsg = tmp_iomsg;
+ child_iomsg_len = IOMSG_LEN;
+ }
+ namelist_write_newline (dtp);
+ /* Call the user defined formatted WRITE procedure. */
+ dtp->u.p.current_unit->child_dtio++;
+ dtio_ptr ((void *)&list_obj, &unit, iotype, &vlist,
+ child_iostat, child_iomsg,
+ iotype_len, child_iomsg_len);
+ dtp->u.p.current_unit->child_dtio--;
+
+ goto obj_loop;
+ }
base_name_len = base_name ? strlen (base_name) : 0;
base_var_name_len = base ? strlen (base->var_name) : 0;
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: Ping : [Patch, fortran] PR48298 - [F03] User-Defined Derived-Type IO (DTIO)
2016-08-27 18:50 Ping : [Patch, fortran] PR48298 - [F03] User-Defined Derived-Type IO (DTIO) Paul Richard Thomas
@ 2016-08-27 20:15 ` Janne Blomqvist
2016-08-28 20:39 ` Damian Rouson
` (2 more replies)
2016-08-30 10:58 ` Paul Richard Thomas
1 sibling, 3 replies; 10+ messages in thread
From: Janne Blomqvist @ 2016-08-27 20:15 UTC (permalink / raw)
To: Paul Richard Thomas
Cc: fortran, gcc-patches, jerry DeLisle, Damian Rouson, Ian Chivers,
Jane Sleightholme
On Sat, Aug 27, 2016 at 9:50 PM, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
> Although we have said that we would commit on Monday if no review is
> forthcoming, we would very much prefer that somebody takes a look. We
> understand perfectly that a 4052 line patch is rather daunting.
> However, even a cursory scan of the patch would be helpful.
To be honest, I had a nagging suspicion that DTIO would remain forever
on the TODO list, but as you and Jerry have pulled it off, my hat is
off to you!
Anyway, a small nit I found was the function st_set_nml_var in
libgfortran. This is an exported function, and thus part of the ABI.
So you cannot add arguments to it, as that would break backwards
compatibility. I suggest you make a new function (say,
st_set_nml_var2, or whatever), and make the old one a simple wrapper
that calls the new one with the additional arguments set to null.
(Unfortunately I haven't looked thoroughly at the entire patch, so I
cannot say this is a complete review. Sorry!)
(Trying to send again as my previous message was caught by the mailing
list spam filters. Lets see if this one is more successful).
--
Janne Blomqvist
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: Ping : [Patch, fortran] PR48298 - [F03] User-Defined Derived-Type IO (DTIO)
2016-08-27 20:15 ` Janne Blomqvist
@ 2016-08-28 20:39 ` Damian Rouson
2016-08-29 8:16 ` Andre Vehreschild
2016-08-29 18:15 ` Toon Moene
2 siblings, 0 replies; 10+ messages in thread
From: Damian Rouson @ 2016-08-28 20:39 UTC (permalink / raw)
To: Janne Blomqvist, Paul Richard Thomas
Cc: Jane Sleightholme, jerry DeLisle, fortran, Ian Chivers, gcc-patches
On August 27, 2016 at 1:15:51 PM, Janne Blomqvist (blomqvist.janne@gmail.com(mailto:blomqvist.janne@gmail.com)) wrote:
>
> Anyway, a small nit I found was the function st_set_nml_var in
> libgfortran. This is an exported function, and thus part of the ABI.
> So you cannot add arguments to it, as that would break backwards
> compatibility. I suggest you make a new function (say,
> st_set_nml_var2, or whatever), and make the old one a simple wrapper
> that calls the new one with the additional arguments set to null.
>
As another small nit, I hope the chosen name is more descriptive than one
obtained by appending “2” to the name. :)
Damian
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: Ping : [Patch, fortran] PR48298 - [F03] User-Defined Derived-Type IO (DTIO)
2016-08-27 20:15 ` Janne Blomqvist
2016-08-28 20:39 ` Damian Rouson
@ 2016-08-29 8:16 ` Andre Vehreschild
2016-08-29 8:47 ` Janne Blomqvist
2016-08-29 18:15 ` Toon Moene
2 siblings, 1 reply; 10+ messages in thread
From: Andre Vehreschild @ 2016-08-29 8:16 UTC (permalink / raw)
To: Janne Blomqvist
Cc: Paul Richard Thomas, fortran, gcc-patches, jerry DeLisle,
Damian Rouson, Ian Chivers, Jane Sleightholme
Hi all,
> Anyway, a small nit I found was the function st_set_nml_var in
> libgfortran. This is an exported function, and thus part of the ABI.
> So you cannot add arguments to it, as that would break backwards
> compatibility.
Please explain the above. I was of the opinion, that when we change
something significantly the global ABI version gets bumped. Given that
we are doing gcc-7 currently and there have been some changes, that ABI
version should have been bumped already with respect to gcc-6. IMO the
library can't be linked to old objects that use the original
st_set_nml_var() signature anyway. So when there are no other users of
st_set... then why not replace the function signature by a more
suitable one? Or is this function still in use?
I am asking that stupid question mostly, because during extending
coarray stuff to support allocatable components in derived typed
coarrays the API of the caf-library has to be modified and carrying
along the old signatures just causes useless garbage being carried
forward. (Opencoarrays is working on supporting the same renovated API.
Other users of that API are not known to me.) So what is the best way
to resolve this?
- Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: Ping : [Patch, fortran] PR48298 - [F03] User-Defined Derived-Type IO (DTIO)
2016-08-29 8:16 ` Andre Vehreschild
@ 2016-08-29 8:47 ` Janne Blomqvist
2016-08-29 10:15 ` Paul Richard Thomas
0 siblings, 1 reply; 10+ messages in thread
From: Janne Blomqvist @ 2016-08-29 8:47 UTC (permalink / raw)
To: Andre Vehreschild
Cc: Paul Richard Thomas, fortran, gcc-patches, jerry DeLisle,
Damian Rouson, Ian Chivers, Jane Sleightholme
On Mon, Aug 29, 2016 at 11:15 AM, Andre Vehreschild <vehre@gmx.de> wrote:
> Hi all,
>
>> Anyway, a small nit I found was the function st_set_nml_var in
>> libgfortran. This is an exported function, and thus part of the ABI.
>> So you cannot add arguments to it, as that would break backwards
>> compatibility.
>
> Please explain the above. I was of the opinion, that when we change
> something significantly the global ABI version gets bumped. Given that
> we are doing gcc-7 currently and there have been some changes, that ABI
> version should have been bumped already with respect to gcc-6.
We strive very(?) hard to retain ABI compatibility for libgfortran, as
having to recompile everything is a huge PITA for our users. As a
result we have been able avoid bumping the SO major version number
since GCC 4.3 IIRC.
There is a long laundry-list of cleanups that could be done once we do
bump the SO major version:
https://gcc.gnu.org/wiki/LibgfortranAbiCleanup
Probably when (if?) the new array descriptor is merged we have to do
said bump, as that one is used everywhere and retaining compatibility
with the old descriptor seems to be a huge undertaking.
> I am asking that stupid question mostly, because during extending
> coarray stuff to support allocatable components in derived typed
> coarrays the API of the caf-library has to be modified and carrying
> along the old signatures just causes useless garbage being carried
> forward. (Opencoarrays is working on supporting the same renovated API.
> Other users of that API are not known to me.) So what is the best way
> to resolve this?
I haven't involved myself in the coarray stuff, but AFAIU the corray
lib hasn't been considered stable, in order that the developers can
more quickly iterate on the design without having to be bogged down by
ABI compatibility considerations.
--
Janne Blomqvist
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: Ping : [Patch, fortran] PR48298 - [F03] User-Defined Derived-Type IO (DTIO)
2016-08-29 8:47 ` Janne Blomqvist
@ 2016-08-29 10:15 ` Paul Richard Thomas
2016-08-30 15:01 ` Janne Blomqvist
0 siblings, 1 reply; 10+ messages in thread
From: Paul Richard Thomas @ 2016-08-29 10:15 UTC (permalink / raw)
To: Janne Blomqvist
Cc: Andre Vehreschild, fortran, gcc-patches, jerry DeLisle,
Damian Rouson, Ian Chivers, Jane Sleightholme
Hi Janne, Andre, Jerry and All,
I am perfectly happy to adopt Janne's suggestion for
st_set_(dtio_)nml_var. Do the changes to the IO structures have any
impact? These are in:
fnode, st_parameter_dt & gfc_unit
I don't think that these should be visible but I want expert opinion
before making that assumption :-)
Cheers
Paul
On 29 August 2016 at 10:46, Janne Blomqvist <blomqvist.janne@gmail.com> wrote:
> On Mon, Aug 29, 2016 at 11:15 AM, Andre Vehreschild <vehre@gmx.de> wrote:
>> Hi all,
>>
>>> Anyway, a small nit I found was the function st_set_nml_var in
>>> libgfortran. This is an exported function, and thus part of the ABI.
>>> So you cannot add arguments to it, as that would break backwards
>>> compatibility.
>>
>> Please explain the above. I was of the opinion, that when we change
>> something significantly the global ABI version gets bumped. Given that
>> we are doing gcc-7 currently and there have been some changes, that ABI
>> version should have been bumped already with respect to gcc-6.
>
> We strive very(?) hard to retain ABI compatibility for libgfortran, as
> having to recompile everything is a huge PITA for our users. As a
> result we have been able avoid bumping the SO major version number
> since GCC 4.3 IIRC.
>
> There is a long laundry-list of cleanups that could be done once we do
> bump the SO major version:
> https://gcc.gnu.org/wiki/LibgfortranAbiCleanup
>
> Probably when (if?) the new array descriptor is merged we have to do
> said bump, as that one is used everywhere and retaining compatibility
> with the old descriptor seems to be a huge undertaking.
>
>> I am asking that stupid question mostly, because during extending
>> coarray stuff to support allocatable components in derived typed
>> coarrays the API of the caf-library has to be modified and carrying
>> along the old signatures just causes useless garbage being carried
>> forward. (Opencoarrays is working on supporting the same renovated API.
>> Other users of that API are not known to me.) So what is the best way
>> to resolve this?
>
> I haven't involved myself in the coarray stuff, but AFAIU the corray
> lib hasn't been considered stable, in order that the developers can
> more quickly iterate on the design without having to be bogged down by
> ABI compatibility considerations.
>
> --
> Janne Blomqvist
--
The difference between genius and stupidity is; genius has its limits.
Albert Einstein
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: Ping : [Patch, fortran] PR48298 - [F03] User-Defined Derived-Type IO (DTIO)
2016-08-27 20:15 ` Janne Blomqvist
2016-08-28 20:39 ` Damian Rouson
2016-08-29 8:16 ` Andre Vehreschild
@ 2016-08-29 18:15 ` Toon Moene
2 siblings, 0 replies; 10+ messages in thread
From: Toon Moene @ 2016-08-29 18:15 UTC (permalink / raw)
To: gcc-patches, fortran
On 08/27/2016 10:15 PM, Janne Blomqvist wrote:
> On Sat, Aug 27, 2016 at 9:50 PM, Paul Richard Thomas
> <paul.richard.thomas@gmail.com> wrote:
>> Although we have said that we would commit on Monday if no review is
>> forthcoming, we would very much prefer that somebody takes a look. We
>> understand perfectly that a 4052 line patch is rather daunting.
>> However, even a cursory scan of the patch would be helpful.
>
> To be honest, I had a nagging suspicion that DTIO would remain forever
> on the TODO list, but as you and Jerry have pulled it off, my hat is
> off to you!
At the last Fortran Standardization Committee meeting (Boulder, June) I
opined that UDDTIO might be an unsolved F2003 issue in gfortran
eternally, because there is no real *pressure* for a free compiler to be
Standard Conformant.
Now the last major item on the F2003 list is "parameterized derived
types". Compiler writers on the committee tell me that you need to
overhaul most of the front end (and parts of the run-time library) to
get that correct ...
Thanks Paul et al. for working on this daunting task !
Kind regards,
--
Toon Moene - e-mail: toon@moene.org - phone: +31 346 214290
Saturnushof 14, 3738 XG Maartensdijk, The Netherlands
At home: http://moene.org/~toon/; weather: http://moene.org/~hirlam/
Progress of GNU Fortran: http://gcc.gnu.org/wiki/GFortran#news
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: Ping : [Patch, fortran] PR48298 - [F03] User-Defined Derived-Type IO (DTIO)
2016-08-27 18:50 Ping : [Patch, fortran] PR48298 - [F03] User-Defined Derived-Type IO (DTIO) Paul Richard Thomas
2016-08-27 20:15 ` Janne Blomqvist
@ 2016-08-30 10:58 ` Paul Richard Thomas
1 sibling, 0 replies; 10+ messages in thread
From: Paul Richard Thomas @ 2016-08-30 10:58 UTC (permalink / raw)
To: fortran, gcc-patches
Cc: jerry DeLisle, Damian Rouson, Ian Chivers, Jane Sleightholme
Dear All,
Janne's proposed change to namelist transfer has been implemented.
This avoids ABI brekage.
Please find the ChangeLogs below and the new patch attached.
Bootstraps and regtests on FC21/x86_64.
I will commit tomorrow morning if there are no objections in the meantime.
Best regards
Paul
2016-08-23 Paul Thomas <pault@gcc.gnu.org>
Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/48298
* decl.c (access_attr_decl): Include case INTERFACE_DTIO as
appropriate.
* gfortran.h : Add INTRINSIC_FORMATTED and
INTRINSIC_UNFORMATTED to gfc_intrinsic_op. Add INTERFACE_DTIO
to interface type. Add new enum 'dtio_codes'. Add bitfield
'has_dtio_procs' to symbol_attr. Add prototypes
'gfc_check_dtio_interfaces' and 'gfc_find_specific_dtio_proc'.
* interface.c (dtio_op): New function.
(gfc_match_generic_spec): Match generic DTIO interfaces.
(gfc_match_interface): Treat DTIO interfaces in the same way as
(gfc_current_interface_head): Add INTERFACE_DTIO appropriately.
(check_dtio_arg_TKR_intent): New function.
(check_dtio_interface1): New function.
(gfc_check_dtio_interfaces): New function.
(gfc_find_specific_dtio_proc): New function.
* io.c : Add FMT_DT to format_token.
(format_lex): Handle DTIO formatting.
* match.c (gfc_op2string): Add DTIO operators.
* resolve.c (derived_inaccessible): Ignore pointer components
to enclosing derived type.
(resolve_transfer): Resolve transfers that involve DTIO.
procedures. Find the specific subroutine for the transfer and
use its existence to over-ride some of the constraints on
derived types. If the transfer is recursive, require that the
subroutine be so qualified.
(dtio_procs_present): New function.
(resolve_fl_namelist): Remove inhibition of polymorphic objects
in namelists if DTIO read and write subroutines exist. Likewise
for derived types.
(resolve_types): Invoke 'gfc_verify_dtio_procedures'.
* symbol.c : Set 'dtio_procs' using 'minit'.
* trans-decl.c (gfc_finish_var_decl): If a derived-type/class
object is associated with DTIO procedures, make it TREE_STATIC.
* trans-expr.c (gfc_get_vptr_from_expr): If the expression
drills down to a PARM_DECL, extract the vptr correctly.
(gfc_conv_derived_to_class): Check 'info' in the test for
'useflags'. If the se expression exists and is a pointer, use
it as the class _data.
* trans-io.c : Add IOCALL_X_DERIVED to iocall and the function
prototype. Likewise for IOCALL_SET_NML_DTIO_VAL.
(set_parameter_tree): Renamed from 'set_parameter_const', now
returns void and has new tree argument. Calls modified to match
new interface.
(transfer_namelist_element): Transfer DTIO procedure pointer
and vpointer using the new function IOCALL_SET_NML_DTIO_VAL.
(get_dtio_proc): New function.
(transfer_expr): Add new argument for the vptr field of class
objects. Add the code to call the specific DTIO proc, convert
derived types to class and call IOCALL_X_DERIVED.
(trans_transfer): Add BT_CLASS to structures for treatment by
the scalarizer. Obtain the vptr for the dynamic type, both for
scalar and array transfer.
2016-08-23 Jerry DeLisle <jvdelisle@gcc.gnu.org>
Paul Thomas <pault@gcc.gnu.org>
PR libgfortran/48298
* gfortran.map : Flag _st_set_nml_dtio_var and
_gfortran_transfer_derived.
* io/format.c (format_lex): Detect DTIO formatting.
(parse_format_list): Parse the DTIO format.
(next_format): Include FMT_DT.
* io/format.h : Likewise. Add structure 'udf' to structure
'fnode' to carry the IOTYPE string and the 'vlist'.
* io/io.h : Add prototypes for the two types of DTIO subroutine
and a typedef for gfc_class. Also, add to 'namelist_type'
fields for the pointer to the DTIO procedure and the vtable.
Add fields to struct st_parameter_dt for pointers to the two
types of DTIO subroutine. Add to gfc_unit DTIO specific fields.
(internal_proto): Add prototype for 'read_user_defined' and
'write_user_defined'.
* io/list_read.c (check_buffers): Use the 'current_unit' field.
(unget_char): Likewise.
(eat_spaces): Likewise.
(list_formatted_read_scalar): For case BT_CLASS, call the DTIO
procedure.
(nml_get_obj_data): Likewise when DTIO procedure is present,.
* io/transfer.c : Export prototypes for 'transfer_derived' and
'transfer_derived_write'.
(unformatted_read): For case BT_CLASS, call the DTIO procedure.
(unformatted_write): Likewise.
(formatted_transfer_scalar_read): Likewise.
(formatted_transfer_scalar_write: Likewise.
(transfer_derived): New function.
(data_transfer_init): Set last_char if no child_dtio.
(finalize_transfer): Return if child_dtio set.
(st_write_done): Add condition for child_dtio not set.
Add extra arguments for st_set_nml_var prototype.
(set_nml_var): New function that contains the contents of the
old version of st_set_nml_var. Also sets the 'dtio_sub' and
'vtable' fields of the 'nml' structure.
(st_set_nml_var): Now just calls set_nml_var with 'dtio_sub'
and 'vtable' NULL.
(st_set_nml_dtio_var): New function that calls set_nml_var.
* io/unit.c (get_external_unit): If the found unit child_dtio
is non zero, don't do any mutex locking/unlocking. Just
return the unit.
* io/unix.c (tempfile_open): Revert to C style comment.
* io/write.c (list_formatted_write_scalar): Do the DTIO call.
(nml_write_obj): Add BT_CLASS and do the DTIO call.
2016-08-23 Jerry DeLisle <jvdelisle@gcc.gnu.org>
Paul Thomas <pault@gcc.gnu.org>
PR fortran/48298
* gfortran.dg/dtio_1.f90: New test.
* gfortran.dg/dtio_2.f90: New test.
* gfortran.dg/dtio_3.f90: New test.
* gfortran.dg/dtio_4.f90: New test.
* gfortran.dg/dtio_5.f90: New test.
* gfortran.dg/dtio_6.f90: New test.
* gfortran.dg/dtio_7.f90: New test.
* gfortran.dg/dtio_8.f90: New test.
* gfortran.dg/dtio_9.f90: New test.
* gfortran.dg/dtio_10.f90: New test.
On 27 August 2016 at 20:50, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
> Dear All,
>
> Please find attached the complete patch for DTIO, including the fix
> for the mutex_lock problem and all the testcases.
>
> Although we have said that we would commit on Monday if no review is
> forthcoming, we would very much prefer that somebody takes a look. We
> understand perfectly that a 4052 line patch is rather daunting.
> However, even a cursory scan of the patch would be helpful.
>
> Many thanks to Dominique for giving the patch a whirl. This almost
> certainly helped keep our blood pressure more or less level :-)
>
> Best regards
>
> Paul and Jerry
>
>
> On 22 August 2016 at 14:32, Paul Richard Thomas
> <paul.richard.thomas@gmail.com> wrote:
>> Dear All,
>>
>> The attached patch implements the above DTIO feature. This is the
>> penultimate F2003 feature to be implemented in gfortran. (The last is
>> Parameterized Derived-Types, which look to be difficult to judge by
>> the remarks coming from other vendors).
>>
>> Although fairly long, the patch is straightforward. It includes some
>> whitespace corrections, which are not remarked upon in the ChangeLogs.
>>
>> There are four known issues, for which PRs will be raised:
>> 1) DTIO to internal units is not implemented;
>> 2) Inquire length is not implemented;
>> 3) Size = in READ statements is not implemented; and
>> 4) There is a mystery optimization bug, at all levels of optimization,
>> which causes IF statements to disappear in some of the testcases. This
>> has been masked by the chunk in trans-decl.c that forces derived-type
>> and class objects with associated DTIO procedures to be TREE_STATIC.
>>
>> The testcases dtio_[3,4].f90 are on their way. We had set ourselves
>> the target of today to submit but the issue #4 derailed the
>> preparation of these testcases. These will be posted as soon as
>> possible.
>>
>> Bootstrapped and regtested on FC21/x86_64 - OK for trunk?
>>
>> Given that DTIO is only triggered by the specific typebound or generic
>> interfaces, we intend to commit the patch in one week from today if no
>> review is forthcoming.
>>
>> Paul and Jerry
>>
>> 2016-08-22 Paul Thomas <pault@gcc.gnu.org>
>> Jerry DeLisle <jvdelisle@gcc.gnu.org>
>>
>> PR fortran/48298
>>
>> * decl.c (access_attr_decl): Include case INTERFACE_DTIO as
>> appropriate.
>> * gfortran.h : Add INTRINSIC_FORMATTED and
>> INTRINSIC_UNFORMATTED to gfc_intrinsic_op. Add INTERFACE_DTIO
>> to interface type. Add new enum 'dtio_codes'. Add bitfield
>> 'has_dtio_procs' to symbol_attr. Add prototypes
>> 'gfc_check_dtio_interfaces' and 'gfc_find_specific_dtio_proc'.
>> * interface.c (dtio_op): New function.
>> (gfc_match_generic_spec): Match generic DTIO interfaces.
>> (gfc_match_interface): Treat DTIO interfaces in the same way as
>> (gfc_current_interface_head): Add INTERFACE_DTIO appropriately.
>> (check_dtio_arg_TKR_intent): New function.
>> (check_dtio_interface1): New function.
>> (gfc_check_dtio_interfaces): New function.
>> (gfc_find_specific_dtio_proc): New function.
>> * io.c : Add FMT_DT to format_token.
>> (format_lex): Handle DTIO formatting.
>> * match.c (gfc_op2string): Add DTIO operators.
>> * resolve.c (derived_inaccessible): Ignore pointer components
>> to enclosing derived type.
>> (resolve_transfer): Resolve transfers that involve DTIO.
>> procedures. Find the specific subroutine for the transfer and
>> use its existence to over-ride some of the constraints on
>> derived types.
>> (dtio_procs_present): New function.
>> (resolve_fl_namelist): Remove inhibition of polymorphic objects
>> in namelists if DTIO read and write subroutines exist. Likewise
>> for derived types.
>> (resolve_types): Invoke 'gfc_verify_dtio_procedures'.
>> * symbol.c : Set 'dtio_procs' using 'minit'.
>> * trans-decl.c (gfc_finish_var_decl): If a derived-type/class
>> object is associated with DTIO procedures, make it TREE_STATIC.
>> * trans-expr.c (gfc_conv_derived_to_class): Check 'info' in the
>> test for 'useflags'. If the se expression exists and is a
>> pointer, use it as the class _data.
>> * trans-io.c : Add IOCALL_X_DERIVED to iocall and the function
>> prototype. Add two new arguments to IOCALL_SET_NML_VAL.
>> (set_parameter_tree): Renamed from 'set_parameter_const', now
>> returns void and has new tree argument. Calls modified to match
>> new interface.
>> (transfer_namelist_element): Transfer DTIO procedure pointer
>> and the table to the vpointer, using the two new arguments of
>> IOCALL_SET_NML_VAL.
>> (get_dtio_proc): New function.
>> (transfer_expr): Add new argument for the vptr field of class
>> objects. Add the code to call the specific DTIO proc, convert
>> derived types to class and call IOCALL_X_DERIVED.
>> (trans_transfer): Add BT_CLASS to structures for treatment by
>> the scalarizer. Obtain the vptr for the dynamic type, both for
>> scalar and array transfer.
>>
>> 2016-08-22 Jerry DeLisle <jvdelisle@gcc.gnu.org>
>> Paul Thomas <pault@gcc.gnu.org>
>>
>> PR libgfortran/48298
>> * gfortran.map : Flag _gfortran_transfer_derived.
>> * io/format.c (format_lex): Detect DTIO formatting.
>> (parse_format_list): Parse the DTIO format.
>> (next_format): Include FMT_DT.
>> * io/format.h : Likewise. Add structure 'udf' to structure
>> 'fnode' to carry the IOTYPE string and the 'vlist'.
>> * io/io.h : Add prototypes for the two types of DTIO subroutine
>> and a typedef for gfc_class. Also, add to 'namelist_type'
>> fields for the pointer to the DTIO procedure and the vtable.
>> Add fields to struct st_parameter_dt for pointers to the two
>> types of DTIO subroutine. Add to gfc_unit DTIO specific fields.
>> (internal_proto): Add prototype for 'read_user_defined' and
>> 'write_user_defined'.
>> * io/list_read.c (check_buffers): Use the 'current_unit' field.
>> (unget_char): Likewise.
>> (eat_spaces): Likewise.
>> (list_formatted_read_scalar): For case BT_CLASS, call the DTIO
>> procedure.
>> (nml_get_obj_data): Likewise when DTIO procedure is present.
>> * io/transfer.c : Export prototypes for 'transfer_derived' and
>> 'transfer_derived_write'.
>> (unformatted_read): For case BT_CLASS, call the DTIO procedure.
>> (unformatted_write): Likewise.
>> (formatted_transfer_scalar_read): Likewise.
>> (formatted_transfer_scalar_write: Likewise.
>> (transfer_derived): New function.
>> (data_transfer_init): Set last_char if no child_dtio.
>> (finalize_transfer): Return if child_dtio set.
>> (st_write_done): Add condition for child_dtio not set.
>> Add extra arguments for st_set_nml_var prototype.
>> (st_set_nml_var): Set the 'dtio_sub' and 'vtable' fields of the
>> 'nml' structure.
>> * io/unix.c (tempfile_open): Revert to C style comment.
>> * io/write.c (list_formatted_write_scalar): Do the DTIO call.
>> (nml_write_obj): Add BT_CLASS and do the DTIO call.
>>
>> 2016-08-22 Jerry DeLisle <jvdelisle@gcc.gnu.org>
>> Paul Thomas <pault@gcc.gnu.org>
>>
>> PR fortran/48298
>> * gfortran.dg/dtio_1.f90: New test.
>> * gfortran.dg/dtio_2.f90: New test.
>> * gfortran.dg/dtio_5.f90: New test.
>> * gfortran.dg/dtio_6.f90: New test.
>> * gfortran.dg/dtio_7.f90: New test.
>> * gfortran.dg/dtio_8.f90: New test.
>> * gfortran.dg/dtio_9.f90: New test.
>> * gfortran.dg/dtio_10.f90: New test.
>
>
>
> --
> The difference between genius and stupidity is; genius has its limits.
>
> Albert Einstein
--
The difference between genius and stupidity is; genius has its limits.
Albert Einstein
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: Ping : [Patch, fortran] PR48298 - [F03] User-Defined Derived-Type IO (DTIO)
2016-08-29 10:15 ` Paul Richard Thomas
@ 2016-08-30 15:01 ` Janne Blomqvist
2016-08-30 17:28 ` Jerry DeLisle
0 siblings, 1 reply; 10+ messages in thread
From: Janne Blomqvist @ 2016-08-30 15:01 UTC (permalink / raw)
To: Paul Richard Thomas
Cc: Andre Vehreschild, fortran, gcc-patches, jerry DeLisle,
Damian Rouson, Ian Chivers, Jane Sleightholme
On Mon, Aug 29, 2016 at 1:15 PM, Paul Richard Thomas
<paul.richard.thomas@gmail.com> wrote:
> Hi Janne, Andre, Jerry and All,
>
> I am perfectly happy to adopt Janne's suggestion for
> st_set_(dtio_)nml_var. Do the changes to the IO structures have any
> impact? These are in:
>
> fnode, st_parameter_dt & gfc_unit
>
> I don't think that these should be visible but I want expert opinion
> before making that assumption :-)
fnode and gfc_unit are private to libgfortran, so these can be changed
in any way you see fit.
st_parameter_dt, however, is more complex. It is allocated by the
frontend on the stack, with some empty space to be used as scratch
space by the library (the st_parameter_dt.u member). So you're free to
do whatever you want with the private part, as long as you keep the
size of the u.p struct smaller than u.pad (which should happen
automagically unless you have mangled check_st_parameter_dt somehow).
Otherwise I don't think you should go and touch st_parameter_dt.
This design is somewhat unfortunate, in that it quite severely
restricts the recursion depth of any function potentially doing I/O.
Say, you have a recursive function that writes something if some
condition is met. Any function potentially doing I/O bumps up the
stack by almost 1kB.. I'm thinking a simpler design for handling the
large number of optional I/O specifiers could be something like having
3 arguments, an array of keys, an array of values, and a scalar
telling how many elements the key/value arrays have. That way only the
specifiers that are actually specified would need to have space
allocated and be transferred. And then instead of a having the
frontend allocate a large scratch space on the stack, the library
could use a TLS variable to look it up.
But anyway, talk is cheap, and I'm unlikely to have time to implement
the above any time soon... :(
>
> Cheers
>
>
> Paul
>
> On 29 August 2016 at 10:46, Janne Blomqvist <blomqvist.janne@gmail.com> wrote:
>> On Mon, Aug 29, 2016 at 11:15 AM, Andre Vehreschild <vehre@gmx.de> wrote:
>>> Hi all,
>>>
>>>> Anyway, a small nit I found was the function st_set_nml_var in
>>>> libgfortran. This is an exported function, and thus part of the ABI.
>>>> So you cannot add arguments to it, as that would break backwards
>>>> compatibility.
>>>
>>> Please explain the above. I was of the opinion, that when we change
>>> something significantly the global ABI version gets bumped. Given that
>>> we are doing gcc-7 currently and there have been some changes, that ABI
>>> version should have been bumped already with respect to gcc-6.
>>
>> We strive very(?) hard to retain ABI compatibility for libgfortran, as
>> having to recompile everything is a huge PITA for our users. As a
>> result we have been able avoid bumping the SO major version number
>> since GCC 4.3 IIRC.
>>
>> There is a long laundry-list of cleanups that could be done once we do
>> bump the SO major version:
>> https://gcc.gnu.org/wiki/LibgfortranAbiCleanup
>>
>> Probably when (if?) the new array descriptor is merged we have to do
>> said bump, as that one is used everywhere and retaining compatibility
>> with the old descriptor seems to be a huge undertaking.
>>
>>> I am asking that stupid question mostly, because during extending
>>> coarray stuff to support allocatable components in derived typed
>>> coarrays the API of the caf-library has to be modified and carrying
>>> along the old signatures just causes useless garbage being carried
>>> forward. (Opencoarrays is working on supporting the same renovated API.
>>> Other users of that API are not known to me.) So what is the best way
>>> to resolve this?
>>
>> I haven't involved myself in the coarray stuff, but AFAIU the corray
>> lib hasn't been considered stable, in order that the developers can
>> more quickly iterate on the design without having to be bogged down by
>> ABI compatibility considerations.
>>
>> --
>> Janne Blomqvist
>
>
>
> --
> The difference between genius and stupidity is; genius has its limits.
>
> Albert Einstein
--
Janne Blomqvist
^ permalink raw reply [flat|nested] 10+ messages in thread
* Re: Ping : [Patch, fortran] PR48298 - [F03] User-Defined Derived-Type IO (DTIO)
2016-08-30 15:01 ` Janne Blomqvist
@ 2016-08-30 17:28 ` Jerry DeLisle
0 siblings, 0 replies; 10+ messages in thread
From: Jerry DeLisle @ 2016-08-30 17:28 UTC (permalink / raw)
To: Janne Blomqvist, Paul Richard Thomas
Cc: Andre Vehreschild, fortran, gcc-patches, Damian Rouson,
Ian Chivers, Jane Sleightholme
On 08/30/2016 08:00 AM, Janne Blomqvist wrote:
> On Mon, Aug 29, 2016 at 1:15 PM, Paul Richard Thomas
> <Paul.Richard.thomas@gmail.com> wrote:
>> Hi Janne, Andre, Jerry and All,
>>
>> I am perfectly happy to adopt Janne's suggestion for
>> st_set_(dtio_)nml_var. Do the changes to the IO structures have any
>> impact? These are in:
>>
>> fnode, st_parameter_dt & gfc_unit
>>
>> I don't think that these should be visible but I want expert opinion
>> before making that assumption :-)
>
> fnode and gfc_unit are private to libgfortran, so these can be changed
> in any way you see fit.
>
> st_parameter_dt, however, is more complex. It is allocated by the
> frontend on the stack, with some empty space to be used as scratch
> space by the library (the st_parameter_dt.u member). So you're free to
> do whatever you want with the private part, as long as you keep the
> size of the u.p struct smaller than u.pad (which should happen
> automagically unless you have mangled check_st_parameter_dt somehow).
> Otherwise I don't think you should go and touch st_parameter_dt.
>
> This design is somewhat unfortunate, in that it quite severely
> restricts the recursion depth of any function potentially doing I/O.
> Say, you have a recursive function that writes something if some
> condition is met. Any function potentially doing I/O bumps up the
> stack by almost 1kB.. I'm thinking a simpler design for handling the
> large number of optional I/O specifiers could be something like having
> 3 arguments, an array of keys, an array of values, and a scalar
> telling how many elements the key/value arrays have. That way only the
> specifiers that are actually specified would need to have space
> allocated and be transferred. And then instead of a having the
> frontend allocate a large scratch space on the stack, the library
> could use a TLS variable to look it up.
>
> But anyway, talk is cheap, and I'm unlikely to have time to implement
> the above any time soon... :(
>
Yes, and others have talked about this. I am not ready to make the plunge there
yet either. So, we have touched sr_parameter_dt carefully and not to exceed pad.
I have been down this road many times.
Jerry
^ permalink raw reply [flat|nested] 10+ messages in thread
end of thread, other threads:[~2016-08-30 17:28 UTC | newest]
Thread overview: 10+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2016-08-27 18:50 Ping : [Patch, fortran] PR48298 - [F03] User-Defined Derived-Type IO (DTIO) Paul Richard Thomas
2016-08-27 20:15 ` Janne Blomqvist
2016-08-28 20:39 ` Damian Rouson
2016-08-29 8:16 ` Andre Vehreschild
2016-08-29 8:47 ` Janne Blomqvist
2016-08-29 10:15 ` Paul Richard Thomas
2016-08-30 15:01 ` Janne Blomqvist
2016-08-30 17:28 ` Jerry DeLisle
2016-08-29 18:15 ` Toon Moene
2016-08-30 10:58 ` Paul Richard Thomas
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).