git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

[multiple changes] 

2016-08-31  Paul Thomas  <pault@gcc.gnu.org>
	Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/48298

	* decl.c (access_attr_decl): Include case INTERFACE_DTIO as
	appropriate.
	* gfortran.h : Add INTRINSIC_FORMATTED and
	INTRINSIC_UNFORMATTED to gfc_intrinsic_op. Add INTERFACE_DTIO
	to interface type. Add new enum 'dtio_codes'. Add bitfield
	'has_dtio_procs' to symbol_attr. Add prototypes
	'gfc_check_dtio_interfaces' and 'gfc_find_specific_dtio_proc'.
	* interface.c (dtio_op): New function.
	(gfc_match_generic_spec): Match generic DTIO interfaces.
	(gfc_match_interface): Treat DTIO interfaces in the same way as
	(gfc_current_interface_head): Add INTERFACE_DTIO appropriately.
	(check_dtio_arg_TKR_intent): New function.
	(check_dtio_interface1): New function.
	(gfc_check_dtio_interfaces): New function.
	(gfc_find_specific_dtio_proc): New function.
	* io.c : Add FMT_DT to format_token.
	(format_lex): Handle DTIO formatting.
	* match.c (gfc_op2string): Add DTIO operators.
	* resolve.c (derived_inaccessible): Ignore pointer components
	to enclosing derived type.
	(resolve_transfer): Resolve transfers that involve DTIO.
	procedures. Find the specific subroutine for the transfer and
	use its existence to over-ride some of the constraints on
	derived types. If the transfer is recursive, require that the
	subroutine be so qualified.
	(dtio_procs_present): New function.
	(resolve_fl_namelist): Remove inhibition of polymorphic objects
	in namelists if DTIO read and write subroutines exist. Likewise
	for derived types.
	(resolve_types): Invoke 'gfc_verify_dtio_procedures'.
	* symbol.c : Set 'dtio_procs' using 'minit'.
	* trans-decl.c (gfc_finish_var_decl): If a derived-type/class
	object is associated with DTIO procedures, make it TREE_STATIC.
	* trans-expr.c (gfc_get_vptr_from_expr): If the expression
	drills down to a PARM_DECL, extract the vptr correctly.
	(gfc_conv_derived_to_class): Check 'info' in the test for
	'useflags'. If the se expression exists and is a pointer, use
	it as the class _data.
	* trans-io.c : Add IOCALL_X_DERIVED to iocall and the function
	prototype. Likewise for IOCALL_SET_NML_DTIO_VAL.
	(set_parameter_tree): Renamed from 'set_parameter_const', now
	returns void and has new tree argument. Calls modified to match
	new interface.
	(transfer_namelist_element): Transfer DTIO procedure pointer
	and vpointer using the new function IOCALL_SET_NML_DTIO_VAL.
	(get_dtio_proc): New function.
	(transfer_expr): Add new argument for the vptr field of class
	objects. Add the code to call the specific DTIO proc, convert
	derived types to class and call IOCALL_X_DERIVED.
	(trans_transfer): Add BT_CLASS to structures for treatment by
	the scalarizer. Obtain the vptr for the dynamic type, both for
	scalar and array transfer.

2016-08-31  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
	Paul Thomas  <pault@gcc.gnu.org>

	PR libgfortran/48298
	* gfortran.map : Flag _st_set_nml_dtio_var and
	_gfortran_transfer_derived.
	* io/format.c (format_lex): Detect DTIO formatting.
	(parse_format_list): Parse the DTIO format.
	(next_format): Include FMT_DT.
	* io/format.h : Likewise. Add structure 'udf' to structure
	'fnode' to carry the IOTYPE string and the 'vlist'.
	* io/io.h : Add prototypes for the two types of DTIO subroutine
	and a typedef for gfc_class. Also, add to 'namelist_type'
	fields for the pointer to the DTIO procedure and the vtable.
	Add fields to struct st_parameter_dt for pointers to the two
	types of DTIO subroutine. Add to gfc_unit DTIO specific fields.
	(internal_proto): Add prototype for 'read_user_defined' and
	'write_user_defined'.
	* io/list_read.c (check_buffers): Use the 'current_unit' field.
	(unget_char): Likewise.
	(eat_spaces): Likewise.
	(list_formatted_read_scalar): For case BT_CLASS, call the DTIO
	procedure.
	(nml_get_obj_data): Likewise when DTIO procedure is present,.
	* io/transfer.c : Export prototypes for 'transfer_derived' and
	'transfer_derived_write'.
	(unformatted_read): For case BT_CLASS, call the DTIO procedure.
	(unformatted_write): Likewise.
	(formatted_transfer_scalar_read): Likewise.
	(formatted_transfer_scalar_write: Likewise.
	(transfer_derived): New function.
	(data_transfer_init): Set last_char if no child_dtio.
	(finalize_transfer): Return if child_dtio set.
	(st_write_done): Add condition for child_dtio not set.
	Add extra arguments for st_set_nml_var prototype.
	(set_nml_var): New function that contains the contents of the
	old version of st_set_nml_var. Also sets the 'dtio_sub' and
	'vtable' fields of the 'nml' structure.
	(st_set_nml_var): Now just calls set_nml_var with 'dtio_sub'
	and 'vtable' NULL.
	(st_set_nml_dtio_var): New function that calls set_nml_var.
	* io/unit.c (get_external_unit): If the found unit child_dtio
	is non zero, don't do any mutex locking/unlocking.  Just
	return the unit.
	* io/unix.c (tempfile_open): Revert to C style comment.
	* io/write.c (list_formatted_write_scalar): Do the DTIO call.
	(nml_write_obj): Add BT_CLASS and do the DTIO call.

2016-08-31  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
	Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/48298
	* gfortran.dg/dtio_1.f90: New test.
	* gfortran.dg/dtio_2.f90: New test.
	* gfortran.dg/dtio_3.f90: New test.
	* gfortran.dg/dtio_4.f90: New test.
	* gfortran.dg/dtio_5.f90: New test.
	* gfortran.dg/dtio_6.f90: New test.
	* gfortran.dg/dtio_7.f90: New test.
	* gfortran.dg/dtio_8.f90: New test.
	* gfortran.dg/dtio_9.f90: New test.
	* gfortran.dg/dtio_10.f90: New test.

From-SVN: r239880
This commit is contained in:
Paul Thomas 2016-08-31 05:36:22 +00:00
parent b816477a5a
commit e73d3ca6d1
32 changed files with 2892 additions and 284 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
gcc/fortran/ChangeLog
View File

@ -1,3 +1,61 @@
2016-08-31 Paul Thomas <pault@gcc.gnu.org>
Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/48298
* decl.c (access_attr_decl): Include case INTERFACE_DTIO as
appropriate.
* gfortran.h : Add INTRINSIC_FORMATTED and
INTRINSIC_UNFORMATTED to gfc_intrinsic_op. Add INTERFACE_DTIO
to interface type. Add new enum 'dtio_codes'. Add bitfield
'has_dtio_procs' to symbol_attr. Add prototypes
'gfc_check_dtio_interfaces' and 'gfc_find_specific_dtio_proc'.
* interface.c (dtio_op): New function.
(gfc_match_generic_spec): Match generic DTIO interfaces.
(gfc_match_interface): Treat DTIO interfaces in the same way as
(gfc_current_interface_head): Add INTERFACE_DTIO appropriately.
(check_dtio_arg_TKR_intent): New function.
(check_dtio_interface1): New function.
(gfc_check_dtio_interfaces): New function.
(gfc_find_specific_dtio_proc): New function.
* io.c : Add FMT_DT to format_token.
(format_lex): Handle DTIO formatting.
* match.c (gfc_op2string): Add DTIO operators.
* resolve.c (derived_inaccessible): Ignore pointer components
to enclosing derived type.
(resolve_transfer): Resolve transfers that involve DTIO.
procedures. Find the specific subroutine for the transfer and
use its existence to over-ride some of the constraints on
derived types. If the transfer is recursive, require that the
subroutine be so qualified.
(dtio_procs_present): New function.
(resolve_fl_namelist): Remove inhibition of polymorphic objects
in namelists if DTIO read and write subroutines exist. Likewise
for derived types.
(resolve_types): Invoke 'gfc_verify_dtio_procedures'.
* symbol.c : Set 'dtio_procs' using 'minit'.
* trans-decl.c (gfc_finish_var_decl): If a derived-type/class
object is associated with DTIO procedures, make it TREE_STATIC.
* trans-expr.c (gfc_get_vptr_from_expr): If the expression
drills down to a PARM_DECL, extract the vptr correctly.
(gfc_conv_derived_to_class): Check 'info' in the test for
'useflags'. If the se expression exists and is a pointer, use
it as the class _data.
* trans-io.c : Add IOCALL_X_DERIVED to iocall and the function
prototype. Likewise for IOCALL_SET_NML_DTIO_VAL.
(set_parameter_tree): Renamed from 'set_parameter_const', now
returns void and has new tree argument. Calls modified to match
new interface.
(transfer_namelist_element): Transfer DTIO procedure pointer
and vpointer using the new function IOCALL_SET_NML_DTIO_VAL.
(get_dtio_proc): New function.
(transfer_expr): Add new argument for the vptr field of class
objects. Add the code to call the specific DTIO proc, convert
derived types to class and call IOCALL_X_DERIVED.
(trans_transfer): Add BT_CLASS to structures for treatment by
the scalarizer. Obtain the vptr for the dynamic type, both for
scalar and array transfer.
2016-08-30 Fritz Reese <fritzoreese@gmail.com> 2016-08-30 Fritz Reese <fritzoreese@gmail.com>
* gfortran.texi: Fix typo in STRUCTURE documentation. * gfortran.texi: Fix typo in STRUCTURE documentation.

4
gcc/fortran/decl.c
View File

@ -7469,6 +7469,7 @@ access_attr_decl (gfc_statement st)
goto syntax; goto syntax;
case INTERFACE_GENERIC: case INTERFACE_GENERIC:
case INTERFACE_DTIO:
if (gfc_get_symbol (name, NULL, &sym)) if (gfc_get_symbol (name, NULL, &sym))
goto done; goto done;
@ -9378,6 +9379,7 @@ gfc_match_generic (void)
switch (op_type) switch (op_type)
{ {
case INTERFACE_GENERIC: case INTERFACE_GENERIC:
case INTERFACE_DTIO:
snprintf (bind_name, sizeof (bind_name), "%s", name); snprintf (bind_name, sizeof (bind_name), "%s", name);
break; break;
@ -9413,6 +9415,7 @@ gfc_match_generic (void)
switch (op_type) switch (op_type)
{ {
case INTERFACE_DTIO:
case INTERFACE_USER_OP: case INTERFACE_USER_OP:
case INTERFACE_GENERIC: case INTERFACE_GENERIC:
{ {
@ -9467,6 +9470,7 @@ gfc_match_generic (void)
switch (op_type) switch (op_type)
{ {
case INTERFACE_DTIO:
case INTERFACE_GENERIC: case INTERFACE_GENERIC:
case INTERFACE_USER_OP: case INTERFACE_USER_OP:
{ {

21
gcc/fortran/gfortran.h
View File

@ -177,8 +177,10 @@ enum gfc_intrinsic_op
/* .EQ., .NE., .GT., .GE., .LT., .LE. (OS = Old-Style) */ /* .EQ., .NE., .GT., .GE., .LT., .LE. (OS = Old-Style) */
INTRINSIC_EQ_OS, INTRINSIC_NE_OS, INTRINSIC_GT_OS, INTRINSIC_GE_OS, INTRINSIC_EQ_OS, INTRINSIC_NE_OS, INTRINSIC_GT_OS, INTRINSIC_GE_OS,
INTRINSIC_LT_OS, INTRINSIC_LE_OS, INTRINSIC_LT_OS, INTRINSIC_LE_OS,
INTRINSIC_NOT, INTRINSIC_USER, INTRINSIC_ASSIGN, INTRINSIC_NOT, INTRINSIC_USER, INTRINSIC_ASSIGN, INTRINSIC_PARENTHESES,
INTRINSIC_PARENTHESES, GFC_INTRINSIC_END /* Sentinel */ /* User defined derived type pseudo operator. */
INTRINSIC_FORMATTED, INTRINSIC_UNFORMATTED,
GFC_INTRINSIC_END /* Sentinel */
}; };
/* This macro is the number of intrinsic operators that exist. /* This macro is the number of intrinsic operators that exist.
@ -261,7 +263,8 @@ enum gfc_statement
enum interface_type enum interface_type
{ {
INTERFACE_NAMELESS = 1, INTERFACE_GENERIC, INTERFACE_NAMELESS = 1, INTERFACE_GENERIC,
INTERFACE_INTRINSIC_OP, INTERFACE_USER_OP, INTERFACE_ABSTRACT INTERFACE_INTRINSIC_OP, INTERFACE_USER_OP, INTERFACE_ABSTRACT,
INTERFACE_DTIO
}; };
/* Symbol flavors: these are all mutually exclusive. /* Symbol flavors: these are all mutually exclusive.
@ -313,6 +316,12 @@ extern const mstring access_types[];
extern const mstring ifsrc_types[]; extern const mstring ifsrc_types[];
extern const mstring save_status[]; 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 /* Enumeration of all the generic intrinsic functions. Used by the
backend for identification of a function. */ backend for identification of a function. */
@ -841,7 +850,8 @@ typedef struct
entities. */ entities. */
unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1, unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1,
private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1, private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1,
event_comp:1, defined_assign_comp:1, unlimited_polymorphic:1; event_comp:1, defined_assign_comp:1, unlimited_polymorphic:1,
has_dtio_procs:1;
/* This is a temporary selector for SELECT TYPE or an associate /* This is a temporary selector for SELECT TYPE or an associate
variable for SELECT_TYPE or ASSOCIATE. */ variable for SELECT_TYPE or ASSOCIATE. */
@ -3170,6 +3180,9 @@ bool gfc_check_operator_interface (gfc_symbol*, gfc_intrinsic_op, locus);
int gfc_has_vector_subscript (gfc_expr*); int gfc_has_vector_subscript (gfc_expr*);
gfc_intrinsic_op gfc_equivalent_op (gfc_intrinsic_op); gfc_intrinsic_op gfc_equivalent_op (gfc_intrinsic_op);
bool gfc_check_typebound_override (gfc_symtree*, gfc_symtree*); 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 */ /* io.c */
extern gfc_st_label format_asterisk; extern gfc_st_label format_asterisk;

359
gcc/fortran/interface.c
View File

@ -115,6 +115,19 @@ fold_unary_intrinsic (gfc_intrinsic_op op)
} }
/* Return the operator depending on the DTIO moded string. */
static gfc_intrinsic_op
dtio_op (char* mode)
{
if (strncmp (mode, "formatted", 9) == 0)
return INTRINSIC_FORMATTED;
if (strncmp (mode, "unformatted", 9) == 0)
return INTRINSIC_UNFORMATTED;
return INTRINSIC_NONE;
}
/* Match a generic specification. Depending on which type of /* Match a generic specification. Depending on which type of
interface is found, the 'name' or 'op' pointers may be set. interface is found, the 'name' or 'op' pointers may be set.
This subroutine doesn't return MATCH_NO. */ This subroutine doesn't return MATCH_NO. */
@ -162,6 +175,40 @@ gfc_match_generic_spec (interface_type *type,
return MATCH_YES; 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) if (gfc_match_name (buffer) == MATCH_YES)
{ {
strcpy (name, buffer); strcpy (name, buffer);
@ -209,6 +256,7 @@ gfc_match_interface (void)
switch (type) switch (type)
{ {
case INTERFACE_DTIO:
case INTERFACE_GENERIC: case INTERFACE_GENERIC:
if (gfc_get_symbol (name, NULL, &sym)) if (gfc_get_symbol (name, NULL, &sym))
return MATCH_ERROR; return MATCH_ERROR;
@ -371,6 +419,7 @@ gfc_match_end_interface (void)
break; break;
case INTERFACE_DTIO:
case INTERFACE_GENERIC: case INTERFACE_GENERIC:
if (type != current_interface.type if (type != current_interface.type
|| strcmp (current_interface.sym->name, name) != 0) || strcmp (current_interface.sym->name, name) != 0)
@ -4210,6 +4259,7 @@ gfc_add_interface (gfc_symbol *new_sym)
break; break;
case INTERFACE_GENERIC: case INTERFACE_GENERIC:
case INTERFACE_DTIO:
for (ns = current_interface.ns; ns; ns = ns->parent) for (ns = current_interface.ns; ns; ns = ns->parent)
{ {
gfc_find_symbol (current_interface.sym->name, ns, 0, &sym); gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
@ -4257,6 +4307,7 @@ gfc_current_interface_head (void)
break; break;
case INTERFACE_GENERIC: case INTERFACE_GENERIC:
case INTERFACE_DTIO:
return current_interface.sym->generic; return current_interface.sym->generic;
break; break;
@ -4280,6 +4331,7 @@ gfc_set_current_interface_head (gfc_interface *i)
break; break;
case INTERFACE_GENERIC: case INTERFACE_GENERIC:
case INTERFACE_DTIO:
current_interface.sym->generic = i; current_interface.sym->generic = i;
break; break;
@ -4496,3 +4548,310 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
return true; return true;
} }
/* The following three functions check that the formal arguments
of user defined derived type IO procedures are compliant with
the requirements of the standard. */
static void
check_dtio_arg_TKR_intent (gfc_symbol *fsym, bool typebound, bt type,
int kind, int rank, sym_intent intent)
{
if (fsym->ts.type != type)
gfc_error ("DTIO dummy argument at %L must be of type %s",
&fsym->declared_at, gfc_basic_typename (type));
if (fsym->ts.type != BT_CLASS && fsym->ts.type != BT_DERIVED
&& fsym->ts.kind != kind)
gfc_error ("DTIO dummy argument at %L must be of KIND = %d",
&fsym->declared_at, kind);
if (!typebound
&& rank == 0
&& (((type == BT_CLASS) && CLASS_DATA (fsym)->attr.dimension)
|| ((type != BT_CLASS) && fsym->attr.dimension)))
gfc_error ("DTIO dummy argument at %L be a scalar",
&fsym->declared_at);
else if (rank == 1
&& (fsym->as == NULL || fsym->as->type != AS_ASSUMED_SHAPE))
gfc_error ("DTIO dummy argument at %L must be an "
"ASSUMED SHAPE ARRAY", &fsym->declared_at);
if (fsym->attr.intent != intent)
gfc_error ("DTIO dummy argument at %L must have intent %s",
&fsym->declared_at, gfc_code2string (intents, (int)intent));
return;
}
static void
check_dtio_interface1 (gfc_symbol *derived, gfc_symtree *tb_io_st,
bool typebound, bool formatted, int code)
{
gfc_symbol *dtio_sub, *generic_proc, *fsym;
gfc_typebound_proc *tb_io_proc, *specific_proc;
gfc_interface *intr;
gfc_formal_arglist *formal;
int arg_num;
bool read = ((dtio_codes)code == DTIO_RF)
|| ((dtio_codes)code == DTIO_RUF);
bt type;
sym_intent intent;
int kind;
dtio_sub = NULL;
if (typebound)
{
/* Typebound DTIO binding. */
tb_io_proc = tb_io_st->n.tb;
gcc_assert (tb_io_proc != NULL);
gcc_assert (tb_io_proc->is_generic);
gcc_assert (tb_io_proc->u.generic->next == NULL);
specific_proc = tb_io_proc->u.generic->specific;
gcc_assert (!specific_proc->is_generic);
dtio_sub = specific_proc->u.specific->n.sym;
}
else
{
generic_proc = tb_io_st->n.sym;
gcc_assert (generic_proc);
gcc_assert (generic_proc->generic);
for (intr = tb_io_st->n.sym->generic; intr; intr = intr->next)
{
if (intr->sym && intr->sym->formal
&& ((intr->sym->formal->sym->ts.type == BT_CLASS
&& CLASS_DATA (intr->sym->formal->sym)->ts.u.derived
== derived)
|| (intr->sym->formal->sym->ts.type == BT_DERIVED
&& intr->sym->formal->sym->ts.u.derived == derived)))
{
dtio_sub = intr->sym;
break;
}
}
if (dtio_sub == NULL)
return;
}
gcc_assert (dtio_sub);
if (!dtio_sub->attr.subroutine)
gfc_error ("DTIO procedure %s at %L must be a subroutine",
dtio_sub->name, &dtio_sub->declared_at);
/* Now go through the formal arglist. */
arg_num = 1;
for (formal = dtio_sub->formal; formal; formal = formal->next, arg_num++)
{
if (!formatted && arg_num == 3)
arg_num = 5;
fsym = formal->sym;
switch (arg_num)
{
case(1): /* DTV */
type = derived->attr.sequence || derived->attr.is_bind_c ?
BT_DERIVED : BT_CLASS;
kind = 0;
intent = read ? INTENT_INOUT : INTENT_IN;
check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
0, intent);
break;
case(2): /* UNIT */
type = BT_INTEGER;
kind = gfc_default_integer_kind;
intent = INTENT_IN;
check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
0, intent);
break;
case(3): /* IOTYPE */
type = BT_CHARACTER;
kind = gfc_default_character_kind;
intent = INTENT_IN;
check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
0, intent);
break;
case(4): /* VLIST */
type = BT_INTEGER;
kind = gfc_default_integer_kind;
intent = INTENT_IN;
check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
1, intent);
break;
case(5): /* IOSTAT */
type = BT_INTEGER;
kind = gfc_default_integer_kind;
intent = INTENT_OUT;
check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
0, intent);
break;
case(6): /* IOMSG */
type = BT_CHARACTER;
kind = gfc_default_character_kind;
intent = INTENT_INOUT;
check_dtio_arg_TKR_intent (fsym, typebound, type, kind,
0, intent);
break;
default:
gcc_unreachable ();
}
}
derived->attr.has_dtio_procs = 1;
return;
}
void
gfc_check_dtio_interfaces (gfc_symbol *derived)
{
gfc_symtree *tb_io_st;
bool t = false;
int code;
bool formatted;
if (derived->attr.is_class == 1 || derived->attr.vtype == 1)
return;
/* Check typebound DTIO bindings. */
for (code = 0; code < 4; code++)
{
formatted = ((dtio_codes)code == DTIO_RF)
|| ((dtio_codes)code == DTIO_WF);
tb_io_st = gfc_find_typebound_proc (derived, &t,
gfc_code2string (dtio_procs, code),
true, &derived->declared_at);
if (tb_io_st != NULL)
check_dtio_interface1 (derived, tb_io_st, true, formatted, code);
}
/* Check generic DTIO interfaces. */
for (code = 0; code < 4; code++)
{
formatted = ((dtio_codes)code == DTIO_RF)
|| ((dtio_codes)code == DTIO_WF);
tb_io_st = gfc_find_symtree (derived->ns->sym_root,
gfc_code2string (dtio_procs, code));
if (tb_io_st != NULL)
check_dtio_interface1 (derived, tb_io_st, false, formatted, code);
}
}
gfc_symbol *
gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted)
{
gfc_symtree *tb_io_st = NULL;
gfc_symbol *dtio_sub = NULL;
gfc_symbol *extended;
gfc_typebound_proc *tb_io_proc, *specific_proc;
bool t = false;
/* Try to find a typebound DTIO binding. */
if (formatted == true)
{
if (write == true)
tb_io_st = gfc_find_typebound_proc (derived, &t,
gfc_code2string (dtio_procs,
DTIO_WF),
true,
&derived->declared_at);
else
tb_io_st = gfc_find_typebound_proc (derived, &t,
gfc_code2string (dtio_procs,
DTIO_RF),
true,
&derived->declared_at);
}
else
{
if (write == true)
tb_io_st = gfc_find_typebound_proc (derived, &t,
gfc_code2string (dtio_procs,
DTIO_WUF),
true,
&derived->declared_at);
else
tb_io_st = gfc_find_typebound_proc (derived, &t,
gfc_code2string (dtio_procs,
DTIO_RUF),
true,
&derived->declared_at);
}
if (tb_io_st != NULL)
{
tb_io_proc = tb_io_st->n.tb;
gcc_assert (tb_io_proc != NULL);
gcc_assert (tb_io_proc->is_generic);
gcc_assert (tb_io_proc->u.generic->next == NULL);
specific_proc = tb_io_proc->u.generic->specific;
gcc_assert (!specific_proc->is_generic);
dtio_sub = specific_proc->u.specific->n.sym;
}
if (tb_io_st != NULL)
goto finish;
/* If there is not a typebound binding, look for a generic
DTIO interface. */
for (extended = derived; extended;
extended = gfc_get_derived_super_type (extended))
{
if (formatted == true)
{
if (write == true)
tb_io_st = gfc_find_symtree (extended->ns->sym_root,
gfc_code2string (dtio_procs,
DTIO_WF));
else
tb_io_st = gfc_find_symtree (extended->ns->sym_root,
gfc_code2string (dtio_procs,
DTIO_RF));
}
else
{
if (write == true)
tb_io_st = gfc_find_symtree (extended->ns->sym_root,
gfc_code2string (dtio_procs,
DTIO_WUF));
else
tb_io_st = gfc_find_symtree (extended->ns->sym_root,
gfc_code2string (dtio_procs,
DTIO_RUF));
}
if (tb_io_st != NULL
&& tb_io_st->n.sym
&& tb_io_st->n.sym->generic)
{
gfc_interface *intr;
for (intr = tb_io_st->n.sym->generic; intr; intr = intr->next)
{
gfc_symbol *fsym = intr->sym->formal->sym;
if (intr->sym && intr->sym->formal
&& ((fsym->ts.type == BT_CLASS
&& CLASS_DATA (fsym)->ts.u.derived == extended)
|| (fsym->ts.type == BT_DERIVED
&& fsym->ts.u.derived == extended)))
{
dtio_sub = intr->sym;
break;
}
}
}
}
finish:
if (dtio_sub && derived != CLASS_DATA (dtio_sub->formal->sym)->ts.u.derived)
gfc_find_derived_vtab (derived);
return dtio_sub;
}

88
gcc/fortran/io.c
View File

@ -113,7 +113,7 @@ enum format_token
FMT_RPAREN, FMT_X, FMT_SIGN, FMT_BLANK, FMT_CHAR, FMT_P, FMT_IBOZ, FMT_F, 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_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_ERROR, FMT_DC, FMT_DP, FMT_T, FMT_TR, FMT_TL, FMT_STAR, FMT_RC,
FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT
}; };
/* Local variables for checking format strings. The saved_token is /* Local variables for checking format strings. The saved_token is
@ -463,6 +463,44 @@ format_lex (void)
return FMT_ERROR; return FMT_ERROR;
token = FMT_DC; 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 else
{ {
token = FMT_D; token = FMT_D;
@ -652,6 +690,54 @@ format_item_1:
return false; return false;
goto between_desc; 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_SIGN:
case FMT_BLANK: case FMT_BLANK:
case FMT_DP: case FMT_DP:

6
gcc/fortran/match.c
View File

@ -102,6 +102,12 @@ gfc_op2string (gfc_intrinsic_op op)
case INTRINSIC_NONE: case INTRINSIC_NONE:
return "none"; return "none";
/* DTIO */
case INTRINSIC_FORMATTED:
return "formatted";
case INTRINSIC_UNFORMATTED:
return "unformatted";
default: default:
break; break;
} }

126
gcc/fortran/resolve.c
View File

@ -6689,6 +6689,11 @@ derived_inaccessible (gfc_symbol *sym)
for (c = sym->components; c; c = c->next) for (c = sym->components; c; c = c->next)
{ {
/* Prevent an infinite loop through this function. */
if (c->ts.type == BT_DERIVED && c->attr.pointer
&& sym == c->ts.u.derived)
continue;
if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived)) if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived))
return 1; return 1;
} }
@ -8642,9 +8647,13 @@ static void
resolve_transfer (gfc_code *code) resolve_transfer (gfc_code *code)
{ {
gfc_typespec *ts; gfc_typespec *ts;
gfc_symbol *sym; gfc_symbol *sym, *derived;
gfc_ref *ref; gfc_ref *ref;
gfc_expr *exp; gfc_expr *exp;
bool write = false;
bool formatted = false;
gfc_dt *dt = code->ext.dt;
gfc_symbol *dtio_sub = NULL;
exp = code->expr1; exp = code->expr1;
@ -8668,7 +8677,7 @@ resolve_transfer (gfc_code *code)
/* If we are reading, the variable will be changed. Note that /* If we are reading, the variable will be changed. Note that
code->ext.dt may be NULL if the TRANSFER is related to code->ext.dt may be NULL if the TRANSFER is related to
an INQUIRE statement -- but in this case, we are not reading, either. */ an INQUIRE statement -- but in this case, we are not reading, either. */
if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ if (dt && dt->dt_io_kind->value.iokind == M_READ
&& !gfc_check_vardef_context (exp, false, false, false, && !gfc_check_vardef_context (exp, false, false, false,
_("item in READ"))) _("item in READ")))
return; return;
@ -8680,9 +8689,53 @@ resolve_transfer (gfc_code *code)
if (ref->type == REF_COMPONENT) if (ref->type == REF_COMPONENT)
ts = &ref->u.c.component->ts; ts = &ref->u.c.component->ts;
if (ts->type == BT_CLASS) if (dt && dt->dt_io_kind->value.iokind != M_INQUIRE
&& (ts->type == BT_DERIVED || ts->type == BT_CLASS))
{
if (ts->type == BT_DERIVED)
derived = ts->u.derived;
else
derived = ts->u.derived->components->ts.u.derived;
if (dt->format_expr)
{
char *fmt;
fmt = gfc_widechar_to_char (dt->format_expr->value.character.string,
-1);
if (strtok (fmt, "DT") != NULL)
formatted = true;
}
else if (dt->format_label == &format_asterisk)
{
/* List directed io must call the formatted DTIO procedure. */
formatted = true;
}
write = dt->dt_io_kind->value.iokind == M_WRITE
|| dt->dt_io_kind->value.iokind == M_PRINT;
dtio_sub = gfc_find_specific_dtio_proc (derived, write, formatted);
if (dtio_sub != NULL && exp->expr_type == EXPR_VARIABLE)
{
sym = exp->symtree->n.sym->ns->proc_name;
/* Check to see if this is a nested DTIO call, with the
dummy as the io-list object. */
if (sym && sym == dtio_sub && sym->formal
&& sym->formal->sym == exp->symtree->n.sym
&& exp->ref == NULL)
{
if (!sym->attr.recursive)
{
gfc_error ("DTIO %s procedure at %L must be recursive",
sym->name, &sym->declared_at);
return;
}
}
}
}
if (ts->type == BT_CLASS && dtio_sub == NULL)
{ {
/* FIXME: Test for defined input/output. */
gfc_error ("Data transfer element at %L cannot be polymorphic unless " gfc_error ("Data transfer element at %L cannot be polymorphic unless "
"it is processed by a defined input/output procedure", "it is processed by a defined input/output procedure",
&code->loc); &code->loc);
@ -8692,8 +8745,9 @@ resolve_transfer (gfc_code *code)
if (ts->type == BT_DERIVED) if (ts->type == BT_DERIVED)
{ {
/* Check that transferred derived type doesn't contain POINTER /* Check that transferred derived type doesn't contain POINTER
components. */ components unless it is processed by a defined input/output
if (ts->u.derived->attr.pointer_comp) procedure". */
if (ts->u.derived->attr.pointer_comp && dtio_sub == NULL)
{ {
gfc_error ("Data transfer element at %L cannot have POINTER " gfc_error ("Data transfer element at %L cannot have POINTER "
"components unless it is processed by a defined " "components unless it is processed by a defined "
@ -8709,7 +8763,7 @@ resolve_transfer (gfc_code *code)
return; return;
} }
if (ts->u.derived->attr.alloc_comp) if (ts->u.derived->attr.alloc_comp && dtio_sub == NULL)
{ {
gfc_error ("Data transfer element at %L cannot have ALLOCATABLE " gfc_error ("Data transfer element at %L cannot have ALLOCATABLE "
"components unless it is processed by a defined " "components unless it is processed by a defined "
@ -8726,10 +8780,11 @@ resolve_transfer (gfc_code *code)
"cannot have PRIVATE components", &code->loc)) "cannot have PRIVATE components", &code->loc))
return; return;
} }
else if (derived_inaccessible (ts->u.derived)) else if (derived_inaccessible (ts->u.derived) && dtio_sub == NULL)
{ {
gfc_error ("Data transfer element at %L cannot have " gfc_error ("Data transfer element at %L cannot have "
"PRIVATE components",&code->loc); "PRIVATE components unless it is processed by "
"a defined input/output procedure", &code->loc);
return; return;
} }
} }
@ -10901,6 +10956,21 @@ resolve_bind_c_derived_types (gfc_symbol *derived_sym)
} }
/* Check the interfaces of DTIO procedures associated with derived
type 'sym'. These procedures can either have typebound bindings or
can appear in DTIO generic interfaces. */
static void
gfc_verify_DTIO_procedures (gfc_symbol *sym)
{
if (!sym || sym->attr.flavor != FL_DERIVED)
return;
gfc_check_dtio_interfaces (sym);
return;
}
/* Verify that any binding labels used in a given namespace do not collide /* 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 with the names or binding labels of any global symbols. Multiple INTERFACE
for the same procedure are permitted. */ for the same procedure are permitted. */
@ -13421,11 +13491,31 @@ resolve_fl_derived (gfc_symbol *sym)
} }
/* Check for formatted read and write DTIO procedures. */
static bool
dtio_procs_present (gfc_symbol *sym)
{
gfc_symbol *derived;
if (sym->ts.type == BT_CLASS)
derived = CLASS_DATA (sym)->ts.u.derived;
else if (sym->ts.type == BT_DERIVED)
derived = sym->ts.u.derived;
else
return false;
return gfc_find_specific_dtio_proc (derived, true, true) != NULL
&& gfc_find_specific_dtio_proc (derived, false, true) != NULL;
}
static bool static bool
resolve_fl_namelist (gfc_symbol *sym) resolve_fl_namelist (gfc_symbol *sym)
{ {
gfc_namelist *nl; gfc_namelist *nl;
gfc_symbol *nlsym; gfc_symbol *nlsym;
bool dtio;
for (nl = sym->namelist; nl; nl = nl->next) for (nl = sym->namelist; nl; nl = nl->next)
{ {
@ -13459,9 +13549,9 @@ resolve_fl_namelist (gfc_symbol *sym)
sym->name, &sym->declared_at)) sym->name, &sym->declared_at))
return false; return false;
/* FIXME: Once UDDTIO is implemented, the following can be dtio = dtio_procs_present (nl->sym);
removed. */
if (nl->sym->ts.type == BT_CLASS) if (nl->sym->ts.type == BT_CLASS && !dtio)
{ {
gfc_error ("NAMELIST object %qs in namelist %qs at %L is " gfc_error ("NAMELIST object %qs in namelist %qs at %L is "
"polymorphic and requires a defined input/output " "polymorphic and requires a defined input/output "
@ -13479,8 +13569,8 @@ resolve_fl_namelist (gfc_symbol *sym)
sym->name, &sym->declared_at)) sym->name, &sym->declared_at))
return false; return false;
/* FIXME: Once UDDTIO is implemented, the following can be if (!dtio)
removed. */ {
gfc_error ("NAMELIST object %qs in namelist %qs at %L has " gfc_error ("NAMELIST object %qs in namelist %qs at %L has "
"ALLOCATABLE or POINTER components and thus requires " "ALLOCATABLE or POINTER components and thus requires "
"a defined input/output procedure", nl->sym->name, "a defined input/output procedure", nl->sym->name,
@ -13488,6 +13578,7 @@ resolve_fl_namelist (gfc_symbol *sym)
return false; return false;
} }
} }
}
/* Reject PRIVATE objects in a PUBLIC namelist. */ /* Reject PRIVATE objects in a PUBLIC namelist. */
if (gfc_check_symbol_access (sym)) if (gfc_check_symbol_access (sym))
@ -13504,6 +13595,11 @@ resolve_fl_namelist (gfc_symbol *sym)
return false; return false;
} }
/* If the derived type has specific DTIO procedures for both read and
write then namelist objects with private components are OK. */
if (dtio_procs_present (nl->sym))
continue;
/* Types with private components that came here by USE-association. */ /* Types with private components that came here by USE-association. */
if (nl->sym->ts.type == BT_DERIVED if (nl->sym->ts.type == BT_DERIVED
&& derived_inaccessible (nl->sym->ts.u.derived)) && derived_inaccessible (nl->sym->ts.u.derived))
@ -15527,6 +15623,8 @@ resolve_types (gfc_namespace *ns)
gfc_resolve_uops (ns->uop_root); gfc_resolve_uops (ns->uop_root);
gfc_traverse_ns (ns, gfc_verify_DTIO_procedures);
gfc_resolve_omp_declare_simd (ns); gfc_resolve_omp_declare_simd (ns);
gfc_resolve_omp_udrs (ns->omp_udr_root); gfc_resolve_omp_udrs (ns->omp_udr_root);

9
gcc/fortran/symbol.c
View File

@ -87,6 +87,15 @@ const mstring save_status[] =
minit ("IMPLICIT-SAVE", SAVE_IMPLICIT), 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 /* This is to make sure the backend generates setup code in the correct
order. */ order. */

10
gcc/fortran/trans-decl.c
View File

@ -638,6 +638,16 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
&& sym->attr.codimension && !sym->attr.allocatable))) && sym->attr.codimension && !sym->attr.allocatable)))
TREE_STATIC (decl) = 1; 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_) if (sym->attr.volatile_)
{ {
TREE_THIS_VOLATILE (decl) = 1; TREE_THIS_VOLATILE (decl) = 1;

20
gcc/fortran/trans-expr.c
View File

@ -430,9 +430,17 @@ gfc_get_vptr_from_expr (tree expr)
else else
type = NULL_TREE; type = NULL_TREE;
} }
if (TREE_CODE (tmp) == VAR_DECL) if (TREE_CODE (tmp) == VAR_DECL
|| TREE_CODE (tmp) == PARM_DECL)
break; 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; return NULL_TREE;
} }
@ -511,7 +519,14 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
if (optional) if (optional)
cond_optional = gfc_conv_expr_present (e->symtree->n.sym); cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
if (parmse->ss && parmse->ss->info->useflags) if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
{
/* If there is a ready made pointer to a derived type, use it
rather than evaluating the expression again. */
tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
gfc_add_modify (&parmse->pre, ctree, tmp);
}
else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
{ {
/* For an array reference in an elemental procedure call we need /* For an array reference in an elemental procedure call we need
to retain the ss to provide the scalarized array reference. */ to retain the ss to provide the scalarized array reference. */
@ -522,7 +537,6 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
cond_optional, tmp, cond_optional, tmp,
fold_convert (TREE_TYPE (tmp), null_pointer_node)); fold_convert (TREE_TYPE (tmp), null_pointer_node));
gfc_add_modify (&parmse->pre, ctree, tmp); gfc_add_modify (&parmse->pre, ctree, tmp);
} }
else else
{ {

194
gcc/fortran/trans-io.c
View File

@ -132,6 +132,7 @@ enum iocall
IOCALL_X_COMPLEX128_WRITE, IOCALL_X_COMPLEX128_WRITE,
IOCALL_X_ARRAY, IOCALL_X_ARRAY,
IOCALL_X_ARRAY_WRITE, IOCALL_X_ARRAY_WRITE,
IOCALL_X_DERIVED,
IOCALL_OPEN, IOCALL_OPEN,
IOCALL_CLOSE, IOCALL_CLOSE,
IOCALL_INQUIRE, IOCALL_INQUIRE,
@ -142,6 +143,7 @@ enum iocall
IOCALL_ENDFILE, IOCALL_ENDFILE,
IOCALL_FLUSH, IOCALL_FLUSH,
IOCALL_SET_NML_VAL, IOCALL_SET_NML_VAL,
IOCALL_SET_NML_DTIO_VAL,
IOCALL_SET_NML_VAL_DIM, IOCALL_SET_NML_VAL_DIM,
IOCALL_WAIT, IOCALL_WAIT,
IOCALL_NUM IOCALL_NUM
@ -397,6 +399,10 @@ gfc_build_io_library_fndecls (void)
void_type_node, 4, dt_parm_type, pvoid_type_node, void_type_node, 4, dt_parm_type, pvoid_type_node,
integer_type_node, gfc_charlen_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 */ /* Library entry points */
iocall[IOCALL_READ] = gfc_build_library_function_decl_with_spec ( iocall[IOCALL_READ] = gfc_build_library_function_decl_with_spec (
@ -468,6 +474,12 @@ gfc_build_io_library_fndecls (void)
void_type_node, 6, dt_parm_type, pvoid_type_node, pvoid_type_node, 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); gfc_int4_type_node, gfc_charlen_type_node, gfc_int4_type_node);
iocall[IOCALL_SET_NML_DTIO_VAL] = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("st_set_nml_dtio_var")), ".w.R",
void_type_node, 8, dt_parm_type, pvoid_type_node, pvoid_type_node,
gfc_int4_type_node, gfc_charlen_type_node, gfc_int4_type_node,
pvoid_type_node, pvoid_type_node);
iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl_with_spec ( iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("st_set_nml_var_dim")), ".w", get_identifier (PREFIX("st_set_nml_var_dim")), ".w",
void_type_node, 5, dt_parm_type, gfc_int4_type_node, void_type_node, 5, dt_parm_type, gfc_int4_type_node,
@ -475,12 +487,8 @@ gfc_build_io_library_fndecls (void)
} }
/* Generate code to store an integer constant into the static void
st_parameter_XXX structure. */ set_parameter_tree (stmtblock_t *block, tree var, enum iofield type, tree value)
static unsigned int
set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
unsigned int val)
{ {
tree tmp; tree tmp;
gfc_st_parameter_field *p = &st_parameter_field[type]; gfc_st_parameter_field *p = &st_parameter_field[type];
@ -491,7 +499,21 @@ set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field), tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
var, p->field, NULL_TREE); var, p->field, NULL_TREE);
gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (p->field), val)); gfc_add_modify (block, tmp, value);
}
/* Generate code to store an integer constant into the
st_parameter_XXX structure. */
static unsigned int
set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
unsigned int val)
{
gfc_st_parameter_field *p = &st_parameter_field[type];
set_parameter_tree (block, var, type,
build_int_cst (TREE_TYPE (p->field), val));
return p->mask; return p->mask;
} }
@ -697,13 +719,7 @@ set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
gfc_add_modify (postblock, se.expr, tmp); gfc_add_modify (postblock, se.expr, tmp);
} }
if (p->param_type == IOPARM_ptype_common) set_parameter_tree (block, var, type, addr);
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; return p->mask;
} }
@ -1618,6 +1634,8 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
tree dt_parm_addr; tree dt_parm_addr;
tree decl = NULL_TREE; tree decl = NULL_TREE;
tree gfc_int4_type_node = gfc_get_int_type (4); 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 n_dim;
int itype; int itype;
int rank = 0; int rank = 0;
@ -1659,15 +1677,45 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm); 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) if (ts->type == BT_CHARACTER)
tmp = ts->u.cl->backend_decl; tmp = ts->u.cl->backend_decl;
else else
tmp = build_int_cst (gfc_charlen_type_node, 0); tmp = build_int_cst (gfc_charlen_type_node, 0);
if (dtio_proc == NULL_TREE)
tmp = build_call_expr_loc (input_location, tmp = build_call_expr_loc (input_location,
iocall[IOCALL_SET_NML_VAL], 6, iocall[IOCALL_SET_NML_VAL], 6,
dt_parm_addr, addr_expr, string, dt_parm_addr, addr_expr, string,
build_int_cst (gfc_int4_type_node, ts->kind), build_int_cst (gfc_int4_type_node, ts->kind),
tmp, dtype); tmp, dtype);
else
tmp = build_call_expr_loc (input_location,
iocall[IOCALL_SET_NML_DTIO_VAL], 8,
dt_parm_addr, addr_expr, string,
build_int_cst (gfc_int4_type_node, ts->kind),
tmp, dtype, dtio_proc, vtable);
gfc_add_expr_to_block (block, tmp); gfc_add_expr_to_block (block, tmp);
/* If the object is an array, transfer rank times: /* If the object is an array, transfer rank times:
@ -1685,7 +1733,8 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
gfc_add_expr_to_block (block, tmp); gfc_add_expr_to_block (block, tmp);
} }
if (gfc_bt_struct (ts->type) && ts->u.derived->components) if (gfc_bt_struct (ts->type) && ts->u.derived->components
&& dtio_proc == null_pointer_node)
{ {
gfc_component *cmp; gfc_component *cmp;
@ -1995,7 +2044,8 @@ gfc_trans_dt_end (gfc_code * code)
} }
static void static void
transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code); transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
gfc_code * code, tree vptr);
/* Given an array field in a derived type variable, generate the code /* Given an array field in a derived type variable, generate the code
for the loop that iterates over array elements, and the code that for the loop that iterates over array elements, and the code that
@ -2061,7 +2111,7 @@ transfer_array_component (tree expr, gfc_component * cm, locus * where)
/* Now se.expr contains an element of the array. Take the address and pass /* Now se.expr contains an element of the array. Take the address and pass
it to the IO routines. */ it to the IO routines. */
tmp = gfc_build_addr_expr (NULL_TREE, se.expr); tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
transfer_expr (&se, &cm->ts, tmp, NULL); transfer_expr (&se, &cm->ts, tmp, NULL, NULL_TREE);
/* We are done now with the loop body. Wrap up the scalarizer and /* We are done now with the loop body. Wrap up the scalarizer and
return. */ return. */
@ -2081,10 +2131,53 @@ transfer_array_component (tree expr, gfc_component * cm, locus * where)
return gfc_finish_block (&block); 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. */ /* Generate the call for a scalar transfer node. */
static void static void
transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code) transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
gfc_code * code, tree vptr)
{ {
tree tmp, function, arg2, arg3, field, expr; tree tmp, function, arg2, arg3, field, expr;
gfc_component *c; gfc_component *c;
@ -2212,9 +2305,45 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
break; break;
case_bt_struct: case_bt_struct:
case BT_CLASS:
if (ts->u.derived->components == NULL) if (ts->u.derived->components == NULL)
return; 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. */ /* Recurse into the elements of the derived type. */
expr = gfc_evaluate_now (addr_expr, &se->pre); expr = gfc_evaluate_now (addr_expr, &se->pre);
expr = build_fold_indirect_ref_loc (input_location, expr = build_fold_indirect_ref_loc (input_location,
@ -2244,11 +2373,13 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
{ {
if (!c->attr.pointer) if (!c->attr.pointer)
tmp = gfc_build_addr_expr (NULL_TREE, tmp); tmp = gfc_build_addr_expr (NULL_TREE, tmp);
transfer_expr (se, &c->ts, tmp, code); transfer_expr (se, &c->ts, tmp, code, NULL_TREE);
} }
} }
return; return;
}
/* If a CLASS object gets through to here, fall through and ICE. */
}
default: default:
gfc_internal_error ("Bad IO basetype (%d)", ts->type); gfc_internal_error ("Bad IO basetype (%d)", ts->type);
} }
@ -2303,6 +2434,7 @@ gfc_trans_transfer (gfc_code * code)
gfc_ss *ss; gfc_ss *ss;
gfc_se se; gfc_se se;
tree tmp; tree tmp;
tree vptr;
int n; int n;
gfc_start_block (&block); gfc_start_block (&block);
@ -2315,8 +2447,18 @@ gfc_trans_transfer (gfc_code * code)
if (expr->rank == 0) if (expr->rank == 0)
{ {
/* Transfer a scalar value. */ /* 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); gfc_conv_expr_reference (&se, expr);
transfer_expr (&se, &expr->ts, se.expr, code); }
transfer_expr (&se, &expr->ts, se.expr, code, vptr);
} }
else else
{ {
@ -2330,7 +2472,8 @@ gfc_trans_transfer (gfc_code * code)
gcc_assert (ref && ref->type == REF_ARRAY); gcc_assert (ref && ref->type == REF_ARRAY);
} }
if (!gfc_bt_struct (expr->ts.type) if (!(gfc_bt_struct (expr->ts.type)
|| expr->ts.type == BT_CLASS)
&& ref && ref->next == NULL && ref && ref->next == NULL
&& !is_subref_array (expr)) && !is_subref_array (expr))
{ {
@ -2378,9 +2521,12 @@ gfc_trans_transfer (gfc_code * code)
gfc_copy_loopinfo_to_se (&se, &loop); gfc_copy_loopinfo_to_se (&se, &loop);
se.ss = ss; se.ss = ss;
gfc_conv_expr_reference (&se, expr); gfc_conv_expr_reference (&se, expr);
transfer_expr (&se, &expr->ts, se.expr, code); if (expr->ts.type == BT_CLASS)
vptr = gfc_get_vptr_from_expr (ss->info->data.array.descriptor);
else
vptr = NULL_TREE;
transfer_expr (&se, &expr->ts, se.expr, code, vptr);
} }
finish_block_label: finish_block_label:

15
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,18 @@
2016-08-31 Jerry DeLisle <jvdelisle@gcc.gnu.org>
Paul Thomas <pault@gcc.gnu.org>
PR fortran/48298
* gfortran.dg/dtio_1.f90: New test.
* gfortran.dg/dtio_2.f90: New test.
* gfortran.dg/dtio_3.f90: New test.
* gfortran.dg/dtio_4.f90: New test.
* gfortran.dg/dtio_5.f90: New test.
* gfortran.dg/dtio_6.f90: New test.
* gfortran.dg/dtio_7.f90: New test.
* gfortran.dg/dtio_8.f90: New test.
* gfortran.dg/dtio_9.f90: New test.
* gfortran.dg/dtio_10.f90: New test.
2016-08-30 David Malcolm <dmalcolm@redhat.com> 2016-08-30 David Malcolm <dmalcolm@redhat.com>
* gcc.dg/plugin/diagnostic-test-show-locus-bw.c * gcc.dg/plugin/diagnostic-test-show-locus-bw.c

164
gcc/testsuite/gfortran.dg/dtio_1.f90 Normal file
View File

@ -0,0 +1,164 @@
! { dg-do run }
!
! Functional test of User Defined Derived Type IO, Formatted WRITE/READ
!
! 1) Tests passing of iostat out of the user procedure.
! 2) Tests parsing of the DT optional string and passing in and using
! to control execution.
! 3) Tests parsing of the optional vlist, passing in and using it to
! generate a user defined format string.
! 4) Tests passing an iostat or iomsg out of libgfortranthe child procedure back to
! the parent.
!
MODULE p
USE ISO_FORTRAN_ENV
TYPE :: person
CHARACTER (LEN=20) :: name
INTEGER(4) :: age
CONTAINS
procedure :: pwf
procedure :: prf
GENERIC :: WRITE(FORMATTED) => pwf
GENERIC :: READ(FORMATTED) => prf
END TYPE person
CONTAINS
SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg)
CLASS(person), INTENT(IN) :: dtv
INTEGER, INTENT(IN) :: unit
CHARACTER (LEN=*), INTENT(IN) :: iotype
INTEGER, INTENT(IN) :: vlist(:)
INTEGER, INTENT(OUT) :: iostat
CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
CHARACTER (LEN=30) :: udfmt
INTEGER :: myios
udfmt='(*(g0))'
iomsg = "SUCCESS"
iostat=0
if (iotype.eq."DT") then
if (size(vlist).ne.0) print *, 36
WRITE(unit, FMT = '(a,5x,i2)', IOSTAT=iostat, advance='no') trim(dtv%name), dtv%age
if (iostat.ne.0) iomsg = "Fail PWF DT"
endif
if (iotype.eq."DTzeroth") then
if (size(vlist).ne.0) print *, 40
WRITE(unit, FMT = '(g0,g0)', advance='no') dtv%name, dtv%age
if (iostat.ne.0) iomsg = "Fail PWF DTzeroth"
endif
if (iotype.eq."DTtwo") then
if (size(vlist).ne.2) call abort
WRITE(udfmt,'(A,A,I1,A,I1,A)') '(', 'A', vlist(1),',I', vlist(2), ')'
WRITE(unit, FMT='(A8,I2)') dtv%name, dtv%age
if (iostat.ne.0) iomsg = "Fail PWF DTtwo"
endif
if (iotype.eq."DTthree") then
WRITE(udfmt,'(2A,I2,A,I1,A,I2,A)',iostat=myios) '(', 'A', vlist(1),',I', vlist(2), ',F', vlist(3), '.2)'
WRITE(unit, FMT=udfmt, IOSTAT=iostat, advance='no') trim(dtv%name), dtv%age, 3.14
if (iostat.ne.0) iomsg = "Fail PWF DTthree"
endif
if (iotype.eq."LISTDIRECTED") then
if (size(vlist).ne.0) print *, 55
WRITE(unit, FMT = *) dtv%name, dtv%age
if (iostat.ne.0) iomsg = "Fail PWF LISTDIRECTED"
endif
if (iotype.eq."NAMELIST") then
if (size(vlist).ne.0) print *, 59
iostat=6000
endif
END SUBROUTINE pwf
SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg)
CLASS(person), INTENT(INOUT) :: dtv
INTEGER, INTENT(IN) :: unit
CHARACTER (LEN=*), INTENT(IN) :: iotype
INTEGER, INTENT(IN) :: vlist(:)
INTEGER, INTENT(OUT) :: iostat
CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
CHARACTER (LEN=30) :: udfmt
INTEGER :: myios
real :: areal
udfmt='(*(g0))'
iomsg = "SUCCESS"
iostat=0
if (iotype.eq."DT") then
if (size(vlist).ne.0) print *, 36
READ(unit, FMT = '(a,5x,i2)', IOSTAT=iostat, advance='no') dtv%name, dtv%age
if (iostat.ne.0) iomsg = "Fail PWF DT"
endif
if (iotype.eq."DTzeroth") then
if (size(vlist).ne.0) print *, 40
READ(unit, FMT = '(a,I2)', advance='no') dtv%name, dtv%age
if (iostat.ne.0) iomsg = "Fail PWF DTzeroth"
endif
if (iotype.eq."DTtwo") then
if (size(vlist).ne.2) call abort
WRITE(udfmt,'(A,A,I1,A,I1,A)') '(', 'A', vlist(1),',I', vlist(2), ')'
READ(unit, FMT='(A8,I2)') dtv%name, dtv%age
if (iostat.ne.0) iomsg = "Fail PWF DTtwo"
endif
if (iotype.eq."DTthree") then
WRITE(udfmt,'(2A,I2,A,I1,A,I2,A)',iostat=myios) '(', 'A', vlist(1),',I', vlist(2), ',F', vlist(3), '.2)'
READ(unit, FMT=udfmt, IOSTAT=iostat, advance='no') dtv%name, dtv%age, areal
if (iostat.ne.0) iomsg = "Fail PWF DTthree"
endif
if (iotype.eq."LISTDIRECTED") then
if (size(vlist).ne.0) print *, 55
READ(unit, FMT = *) dtv%name, dtv%age
if (iostat.ne.0) iomsg = "Fail PWF LISTDIRECTED"
endif
if (iotype.eq."NAMELIST") then
if (size(vlist).ne.0) print *, 59
iostat=6000
endif
!READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age
END SUBROUTINE prf
END MODULE p
PROGRAM test
USE p
TYPE (person), SAVE :: chairman
TYPE (person), SAVE :: member
character(80) :: astring
integer :: thelength
chairman%name="Charlie"
chairman%age=62
member%name="George"
member%age=42
astring = "FAILURE"
write (10, "(DT'zeroth',3x, DT'three'(11,4,10),11x,DT'two'(8,2))", &
& iostat=myiostat, iomsg=astring) member, chairman, member
if (myiostat.ne.0) call abort
if (astring.ne."SUCCESS") call abort
astring = "FAILURE"
write (10, *, iostat=myiostat, iomsg=astring) member, chairman, member
if (myiostat.ne.0) call abort
if (astring.ne."SUCCESS") call abort
write(10,*) ! See note below
rewind(10)
chairman%name="bogus1"
chairman%age=99
member%name="bogus2"
member%age=66
astring = "FAILURE"
read(10,"(DT'zeroth',3x, DT'three'(11,4,10),11x,DT'two'(8,2))") member, chairman, member
if (member%name.ne."George") call abort
if (chairman%name.ne." Charlie") call abort
if (member%age.ne.42) call abort
if (chairman%age.ne.62) call abort
chairman%name="bogus1"
chairman%age=99
member%name="bogus2"
member%age=66
astring = "FAILURE"
read (10, *, iostat=myiostat, iomsg=astring) member, chairman, member
! The user defined procedure reads to the end of the line/file, then finalizing the parent
! reads past, so we wrote a blank line above. User needs to address these nuances in their
! procedures. (subject to interpretation)
if (astring.ne."SUCCESS") 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

27
gcc/testsuite/gfortran.dg/dtio_10.f90 Normal file
View File

@ -0,0 +1,27 @@
! { dg-do run }
!
! Tests runtime check of the required type in dtio formatted read.
!
module usertypes
type udt
integer :: myarray(15)
end type udt
type, extends(udt) :: more
integer :: itest = -25
end type
end module usertypes
program test1
use usertypes
type (udt) :: udt1
type (more) :: more1
class (more), allocatable :: somemore
integer :: thesize, i, ios
character(100) :: errormsg
read (10, fmt='(dt)', advance='no', size=thesize, iostat=ios, &
& iomsg=errormsg) i, udt1
if (ios.ne.5006) call abort
if (errormsg(1:25).ne."Expected CLASS or DERIVED") call abort
end program test1

71
gcc/testsuite/gfortran.dg/dtio_2.f90 Normal file
View File

@ -0,0 +1,71 @@
! { dg-do run }
!
! Functional test of User Defined DT IO, unformatted WRITE/READ
!
! 1) Tests unformatted DTV write with other variables in the record
! 2) Tests reading back the recods written.
!
module p
type :: person
character (len=20) :: name
integer(4) :: age
contains
procedure :: pwuf
procedure :: pruf
generic :: write(unformatted) => pwuf
generic :: read(unformatted) => pruf
end type person
contains
subroutine pwuf (dtv,unit,iostat,iomsg)
class(person), intent(in) :: dtv
integer, intent(in) :: unit
integer, intent(out) :: iostat
character (len=*), intent(inout) :: iomsg
write (unit=unit, iostat=iostat, iomsg=iomsg) dtv%name, dtv%age
end subroutine pwuf
subroutine pruf (dtv,unit,iostat,iomsg)
class(person), intent(inout) :: dtv
integer, intent(in) :: unit
integer, intent(out) :: iostat
character (len=*), intent(inout) :: iomsg
read (unit = unit) dtv%name, dtv%age
end subroutine pruf
end module p
program test
use p
type (person), save :: chairman
character(3) :: tmpstr1, tmpstr2
chairman%name="charlie"
chairman%age=62
open (unit=71, file='myunformatted_data.dat', form='unformatted')
write (71) "abc", chairman, "efg"
write (71) "hij", chairman, "klm"
write (71) "nop", chairman, "qrs"
rewind (unit = 71)
chairman%name="boggle"
chairman%age=1234
read (71) tmpstr1, chairman, tmpstr2
if (tmpstr1.ne."abc") call abort
if (tmpstr2.ne."efg") call abort
if (chairman%name.ne."charlie") call abort
if (chairman%age.ne.62) call abort
chairman%name="boggle"
chairman%age=1234
read (71) tmpstr1, chairman, tmpstr2
if (tmpstr1.ne."hij") call abort
if (tmpstr2.ne."klm") call abort
if (chairman%name.ne."charlie") call abort
if (chairman%age.ne.62) call abort
chairman%name="boggle"
chairman%age=1234
read (71) tmpstr1, chairman, tmpstr2
if (tmpstr1.ne."nop") call abort
if (tmpstr2.ne."qrs") call abort
if (chairman%name.ne."charlie") call abort
if (chairman%age.ne.62) call abort
close (unit = 71, status='delete')
end program test

172
gcc/testsuite/gfortran.dg/dtio_3.f90 Normal file
View File

@ -0,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

107
gcc/testsuite/gfortran.dg/dtio_4.f90 Normal file
View File

@ -0,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

278
gcc/testsuite/gfortran.dg/dtio_5.f90 Normal file
View File

@ -0,0 +1,278 @@
! { dg-do run }
!
! This test is based on the second case in the PGInsider article at
! https://www.pgroup.com/lit/articles/insider/v6n2a3.htm
!
! The complete original code is at:
! https://www.pgroup.com/lit/samples/pginsider/stack.f90
!
! Thanks to Mark LeAir.
!
! Copyright (c) 2015, NVIDIA CORPORATION. All rights reserved.
!
! NVIDIA CORPORATION and its licensors retain all intellectual property
! and proprietary rights in and to this software, related documentation
! and any modifications thereto. Any use, reproduction, disclosure or
! distribution of this software and related documentation without an express
! license agreement from NVIDIA CORPORATION is strictly prohibited.
!
! THIS CODE AND INFORMATION ARE PROVIDED "AS IS" WITHOUT
! WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING BUT
! NOT LIMITED TO THE IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR
! FITNESS FOR A PARTICULAR PURPOSE.
!
module stack_mod
type, abstract :: stack
private
class(*), allocatable :: item ! an item on the stack
class(stack), pointer :: next=>null() ! next item on the stack
contains
procedure :: empty ! returns true if stack is empty
procedure :: delete ! empties the stack
end type stack
type, extends(stack) :: integer_stack
contains
procedure :: push => push_integer ! add integer item to stack
procedure :: pop => pop_integer ! remove integer item from stack
procedure :: compare => compare_integer ! compare with an integer array
end type integer_stack
type, extends(integer_stack) :: io_stack
contains
procedure,private :: wio_stack
procedure,private :: rio_stack
procedure,private :: dump_stack
generic :: write(unformatted) => wio_stack ! write stack item to file
generic :: read(unformatted) => rio_stack ! push item from file
generic :: write(formatted) => dump_stack ! print all items from stack
end type io_stack
contains
subroutine rio_stack (dtv, unit, iostat, iomsg)
! read item from file and add it to stack
class(io_stack), intent(inout) :: dtv
integer, intent(in) :: unit
integer, intent(out) :: iostat
character(len=*), intent(inout) :: iomsg
integer :: item
read(unit,IOSTAT=iostat,IOMSG=iomsg) item
if (iostat .ne. 0) then
call dtv%push(item)
endif
end subroutine rio_stack
subroutine wio_stack(dtv, unit, iostat, iomsg)
! pop an item from stack and write it to file
class(io_stack), intent(in) :: dtv
integer, intent(in) :: unit
integer, intent(out) :: iostat
character(len=*), intent(inout) :: iomsg
integer :: item
item = dtv%pop()
write(unit,IOSTAT=iostat,IOMSG=iomsg) item
end subroutine wio_stack
subroutine dump_stack(dtv, unit, iotype, v_list, iostat, iomsg)
! Pop all items off stack and write them out to unit
! Assumes default LISTDIRECTED output
class(io_stack), intent(in) :: dtv
integer, intent(in) :: unit
character(len=*), intent(in) :: iotype
integer, intent(in) :: v_list(:)
integer, intent(out) :: iostat
character(len=*), intent(inout) :: iomsg
character(len=80) :: buffer
integer :: item
if (iotype .ne. 'LISTDIRECTED') then
! Error
iomsg = 'dump_stack: unsupported iotype'
iostat = 1
else
iostat = 0
do while( (.not. dtv%empty()) .and. (iostat .eq. 0) )
item = dtv%pop()
write(unit, '(I6/)',IOSTAT=iostat,IOMSG=iomsg) item
enddo
endif
end subroutine dump_stack
logical function empty(this)
class(stack) :: this
if (.not.associated(this%next)) then
empty = .true.
else
empty = .false.
end if
end function empty
subroutine push_integer(this,item)
class(integer_stack) :: this
integer :: item
type(integer_stack), allocatable :: new_item
allocate(new_item)
allocate(new_item%item, source=item)
new_item%next => this%next
allocate(this%next, source=new_item)
end subroutine push_integer
function pop_integer(this) result(item)
class(integer_stack) :: this
integer item
if (this%empty()) then
stop 'Error! pop_integer invoked on empty stack'
endif
select type(top=>this%next)
type is (integer_stack)
select type(i => top%item)
type is(integer)
item = i
class default
stop 'Error #1! pop_integer encountered non-integer stack item'
end select
this%next => top%next
deallocate(top)
class default
stop 'Error #2! pop_integer encountered non-integer_stack item'
end select
end function pop_integer
! gfortran addition to check read/write
logical function compare_integer (this, array, error)
class(integer_stack), target :: this
class(stack), pointer :: ptr, next
integer :: array(:), i, j, error
compare_integer = .true.
ptr => this
do j = 0, size (array, 1)
if (compare_integer .eqv. .false.) return
select type (ptr)
type is (integer_stack)
select type(k => ptr%item)
type is(integer)
if (k .ne. array(j)) error = 1
class default
error = 2
compare_integer = .false.
end select
class default
if (j .ne. 0) then
error = 3
compare_integer = .false.
end if
end select
next => ptr%next
if (associated (next)) then
ptr => next
else if (j .ne. size (array, 1)) then
error = 4
compare_integer = .false.
end if
end do
end function
subroutine delete (this)
class(stack), target :: this
class(stack), pointer :: ptr1, ptr2
ptr1 => this%next
ptr2 => ptr1%next
do while (associated (ptr1))
deallocate (ptr1)
ptr1 => ptr2
if (associated (ptr1)) ptr2 => ptr1%next
end do
end subroutine
end module stack_mod
program stack_demo
use stack_mod
implicit none
integer i, k(10), error
class(io_stack), allocatable :: stk
allocate(stk)
k = [3,1,7,0,2,9,4,8,5,6]
! step 1: set up an 'output' file > changed to 'scratch'
open(10, status='scratch', form='unformatted')
! step 2: add values to stack
do i=1,10
! write(*,*) 'Adding ',i,' to the stack'
call stk%push(k(i))
enddo
! step 3: pop values from stack and write them to file
! write(*,*)
! write(*,*) 'Removing each item from stack and writing it to file.'
! write(*,*)
do while(.not.stk%empty())
write(10) stk
enddo
! step 4: close file and reopen it for read > changed to rewind.
rewind(10)
! step 5: read values back into stack
! write(*,*) 'Reading each value from file and adding it to stack:'
do while(.true.)
read(10,END=9999) i
! write(*,*), 'Reading ',i,' from file. Adding it to stack'
call stk%push(i)
enddo
9999 continue
! step 6: Dump stack to standard out
! write(*,*)
! write(*,*), 'Removing every element from stack and writing it to screen:'
! write(*,*) stk
! gfortran addition to check read/write
if (.not. stk%compare (k, error)) then
select case (error)
case(1)
print *, "values do not match"
case(2)
print *, "non integer found in stack"
case(3)
print *, "type mismatch in stack"
case(4)
print *, "too few values in stack"
end select
call abort
end if
close(10)
! Clean up - valgrind indicates no leaks.
call stk%delete
deallocate (stk)
end program stack_demo

98
gcc/testsuite/gfortran.dg/dtio_6.f90 Normal file
View File

@ -0,0 +1,98 @@
! { dg-do compile }
!
! Tests the checks for interface compliance.
!
!
MODULE p
USE ISO_C_BINDING
TYPE :: person
CHARACTER (LEN=20) :: name
INTEGER(4) :: age
CONTAINS
procedure :: pwf ! { dg-error "Non-polymorphic passed-object" }
procedure :: pwuf
GENERIC :: WRITE(FORMATTED) => pwf
GENERIC :: WRITE(UNFORMATTED) => pwuf
END TYPE person
INTERFACE READ(FORMATTED)
MODULE PROCEDURE prf
END INTERFACE
INTERFACE READ(UNFORMATTED)
MODULE PROCEDURE pruf
END INTERFACE
TYPE :: seq_type
sequence
INTEGER(4) :: i
END TYPE seq_type
INTERFACE WRITE(FORMATTED)
MODULE PROCEDURE pwf_seq
END INTERFACE
TYPE, BIND(C) :: bindc_type
INTEGER(C_INT) :: i
END TYPE bindc_type
INTERFACE WRITE(FORMATTED)
MODULE PROCEDURE pwf_bindc
END INTERFACE
CONTAINS
SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg) ! { dg-error "must be of type CLASS" }
type(person), INTENT(IN) :: dtv
INTEGER, INTENT(IN) :: unit
CHARACTER (LEN=*), INTENT(IN) :: iotype
INTEGER, INTENT(IN) :: vlist(:)
INTEGER, INTENT(OUT) :: iostat
CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
WRITE(unit, FMT = *, IOSTAT=iostat) dtv%name, dtv%age
END SUBROUTINE pwf
SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg) ! { dg-error "must be an ASSUMED SHAPE ARRAY" }
CLASS(person), INTENT(INOUT) :: dtv
INTEGER, INTENT(IN) :: unit
CHARACTER (LEN=*), INTENT(IN) :: iotype
INTEGER, INTENT(IN) :: vlist
INTEGER, INTENT(OUT) :: iostat
CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age
END SUBROUTINE prf
SUBROUTINE pwuf (dtv,unit,iostat,iomsg) ! { dg-error "must have intent IN" }
CLASS(person), INTENT(INOUT) :: dtv
INTEGER, INTENT(IN) :: unit
INTEGER, INTENT(OUT) :: iostat
CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
WRITE (UNIT=UNIT, FMT = *) DTV%name, DTV%age
END SUBROUTINE pwuf
SUBROUTINE pruf (dtv,unit,iostat,iomsg) ! { dg-error "must be of KIND = 4" }
CLASS(person), INTENT(INOUT) :: dtv
INTEGER, INTENT(IN) :: unit
INTEGER(8), INTENT(OUT) :: iostat
CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age
END SUBROUTINE pruf
SUBROUTINE pwf_seq (dtv,unit,iotype,vlist,iostat,iomsg) ! { dg-error "not extensible|DERIVED" }
class(seq_type), INTENT(IN) :: dtv
INTEGER, INTENT(IN) :: unit
CHARACTER (LEN=*), INTENT(IN) :: iotype
INTEGER, INTENT(IN) :: vlist(:)
INTEGER, INTENT(OUT) :: iostat
CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
WRITE(unit, FMT = *, IOSTAT=iostat) dtv%i
END SUBROUTINE pwf_seq
SUBROUTINE pwf_bindc (dtv,unit,iotype,vlist,iostat,iomsg) ! { dg-error "not extensible|DERIVED" }
class(bindc_type), INTENT(IN) :: dtv
INTEGER, INTENT(IN) :: unit
CHARACTER (LEN=*), INTENT(IN) :: iotype
INTEGER, INTENT(IN) :: vlist(:)
INTEGER, INTENT(OUT) :: iostat
CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
WRITE(unit, FMT = *, IOSTAT=iostat) dtv%i
END SUBROUTINE pwf_bindc
END MODULE p

139
gcc/testsuite/gfortran.dg/dtio_7.f90 Normal file
View File

@ -0,0 +1,139 @@
! { dg-do run }
!
! Tests dtio transfer of arrays of derived types and classes
!
MODULE p
TYPE :: person
CHARACTER (LEN=20) :: name
INTEGER(4) :: age
CONTAINS
procedure :: pwf
procedure :: prf
GENERIC :: WRITE(FORMATTED) => pwf
GENERIC :: READ(FORMATTED) => prf
END TYPE person
type, extends(person) :: employee
character(20) :: job_title
end type
type, extends(person) :: officer
character(20) :: position
end type
type, extends(person) :: member
integer :: membership_number
end type
type :: club
type(employee), allocatable :: staff(:)
class(person), allocatable :: committee(:)
class(person), allocatable :: membership(:)
end type
CONTAINS
SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg)
CLASS(person), INTENT(IN) :: dtv
INTEGER, INTENT(IN) :: unit
CHARACTER (LEN=*), INTENT(IN) :: iotype
INTEGER, INTENT(IN) :: vlist(:)
INTEGER, INTENT(OUT) :: iostat
CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
select type (dtv)
type is (employee)
WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Employee"
WRITE(unit, FMT = "(A20,I4,A20/)", IOSTAT=iostat) dtv%name, dtv%age, dtv%job_title
type is (officer)
WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Officer"
WRITE(unit, FMT = "(A20,I4,A20/)", IOSTAT=iostat) dtv%name, dtv%age, dtv%position
type is (member)
WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Member"
WRITE(unit, FMT = "(A20,I4,I4/)", IOSTAT=iostat) dtv%name, dtv%age, dtv%membership_number
class default
WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Ugggh!"
WRITE(unit, FMT = "(A20,I4,' '/)", IOSTAT=iostat) dtv%name, dtv%age
end select
END SUBROUTINE pwf
SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg)
CLASS(person), INTENT(INOUT) :: dtv
INTEGER, INTENT(IN) :: unit
CHARACTER (LEN=*), INTENT(IN) :: iotype
INTEGER, INTENT(IN) :: vlist(:)
INTEGER, INTENT(OUT) :: iostat
CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
character (20) :: header, rname, jtitle, oposition
integer :: i
integer :: no
integer :: age
iostat = 0
select type (dtv)
type is (employee)
read (unit = unit, fmt = *) header
READ (UNIT = UNIT, FMT = "(A20,I4,A20)") rname, age, jtitle
if (trim (rname) .ne. dtv%name) iostat = 1
if (age .ne. dtv%age) iostat = 2
if (trim (jtitle) .ne. dtv%job_title) iostat = 3
if (iotype .ne. "DTstaff") iostat = 4
type is (officer)
read (unit = unit, fmt = *) header
READ (UNIT = UNIT, FMT = "(A20,I4,A20)") rname, age, oposition
if (trim (rname) .ne. dtv%name) iostat = 1
if (age .ne. dtv%age) iostat = 2
if (trim (oposition) .ne. dtv%position) iostat = 3
if (iotype .ne. "DTofficers") iostat = 4
type is (member)
read (unit = unit, fmt = *) header
READ (UNIT = UNIT, FMT = "(A20,I4,I4)") rname, age, no
if (trim (rname) .ne. dtv%name) iostat = 1
if (age .ne. dtv%age) iostat = 2
if (no .ne. dtv%membership_number) iostat = 3
if (iotype .ne. "DTmembers") iostat = 4
class default
call abort
end select
end subroutine
END MODULE p
PROGRAM test
USE p
type (club) :: social_club
TYPE (person) :: chairman
CLASS (person), allocatable :: president(:)
character (40) :: line
integer :: i, j
allocate (social_club%staff, source = [employee ("Bert",25,"Barman"), &
employee ("Joy",16,"Auditor")])
allocate (social_club%committee, source = [officer ("Hank",32, "Chair"), &
officer ("Ann", 29, "Secretary")])
allocate (social_club%membership, source = [member ("Dan",52,1), &
member ("Sue",39,2)])
chairman%name="Charlie"
chairman%age=62
open (7, status = "scratch")
write (7,*) social_club%staff ! Tests array of derived types
write (7,*) social_club%committee ! Tests class array
do i = 1, size (social_club%membership, 1)
write (7,*) social_club%membership(i) ! Tests class array elements
end do
rewind (7)
read (7, "(DT'staff')", iostat = i) social_club%staff
if (i .ne. 0) call abort
social_club%committee(2)%age = 33 ! Introduce an error
read (7, "(DT'officers')", iostat = i) social_club%committee
if (i .ne. 2) call abort ! Pick up error
do j = 1, size (social_club%membership, 1)
read (7, "(DT'members')", iostat = i) social_club%membership(j)
if (i .ne. 0) call abort
end do
close (7)
END PROGRAM test

65
gcc/testsuite/gfortran.dg/dtio_8.f90 Normal file
View File

@ -0,0 +1,65 @@
! { dg-do run }
!
! Tests dtio transfer sequence types.
!
! Note difficulty at end with comparisons at any level of optimization.
!
MODULE p
TYPE :: person
sequence
CHARACTER (LEN=20) :: name
INTEGER(4) :: age
END TYPE person
INTERFACE WRITE(UNFORMATTED)
MODULE PROCEDURE pwuf
END INTERFACE
INTERFACE READ(UNFORMATTED)
MODULE PROCEDURE pruf
END INTERFACE
CONTAINS
SUBROUTINE pwuf (dtv,unit,iostat,iomsg)
type(person), INTENT(IN) :: dtv
INTEGER, INTENT(IN) :: unit
INTEGER, INTENT(OUT) :: iostat
CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
WRITE (UNIT=UNIT) DTV%name, DTV%age
END SUBROUTINE pwuf
SUBROUTINE pruf (dtv,unit,iostat,iomsg)
type(person), INTENT(INOUT) :: dtv
INTEGER, INTENT(IN) :: unit
INTEGER, INTENT(OUT) :: iostat
CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
READ (UNIT = UNIT) dtv%name, dtv%age
END SUBROUTINE pruf
END MODULE p
PROGRAM test
USE p
TYPE (person) :: chairman
character(10) :: line
chairman%name="Charlie"
chairman%age=62
OPEN (UNIT=71, status = 'scratch', FORM='UNFORMATTED')
write (71) chairman
rewind (71)
chairman%name = "Charles"
chairman%age = 0
read (71) chairman
close (unit = 71)
! Straight comparisons fail at any level of optimization.
write(line, "(A7)") chairman%name
if (trim (line) .ne. "Charlie") call abort
line = " "
write(line, "(I4)") chairman%age
if (trim (line) .eq. " 62") print *, trim(line)
END PROGRAM test

66
gcc/testsuite/gfortran.dg/dtio_9.f90 Normal file
View File

@ -0,0 +1,66 @@
! { dg-do run }
!
! Tests dtio of transfer bind-C types.
!
! Note difficulties with c_char at -O1. This is why no character field is used.
!
MODULE p
USE ISO_C_BINDING
TYPE, BIND(C) :: person
integer(c_int) :: id_no
INTEGER(c_int) :: age
END TYPE person
INTERFACE WRITE(UNFORMATTED)
MODULE PROCEDURE pwuf
END INTERFACE
INTERFACE READ(UNFORMATTED)
MODULE PROCEDURE pruf
END INTERFACE
CONTAINS
SUBROUTINE pwuf (dtv,unit,iostat,iomsg)
type(person), INTENT(IN) :: dtv
INTEGER, INTENT(IN) :: unit
INTEGER, INTENT(OUT) :: iostat
CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
WRITE (UNIT=UNIT) DTV%id_no, DTV%age
END SUBROUTINE pwuf
SUBROUTINE pruf (dtv,unit,iostat,iomsg)
type(person), INTENT(INOUT) :: dtv
INTEGER, INTENT(IN) :: unit
INTEGER, INTENT(OUT) :: iostat
CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
READ (UNIT = UNIT) dtv%id_no, dtv%age
END SUBROUTINE pruf
END MODULE p
PROGRAM test
USE p
TYPE (person) :: chairman
CHARACTER (kind=c_char) :: cname(20)
integer (c_int) :: cage, cid_no
character(10) :: line
cid_no = 1
cage = 62
chairman%id_no = cid_no
chairman%age = cage
OPEN (UNIT=71, status = 'scratch', FORM='UNFORMATTED')
write (71) chairman
rewind (71)
chairman%id_no = 0
chairman%age = 0
read (71) chairman
close (unit = 71)
write(line, "(I4)") chairman%id_no
if (trim (line) .ne. " 1") call abort
write(line, "(I4)") chairman%age
if (trim (line) .ne. " 62") call abort
end program

48
libgfortran/ChangeLog
View File

@ -1,3 +1,51 @@
2016-08-31 Jerry DeLisle <jvdelisle@gcc.gnu.org>
Paul Thomas <pault@gcc.gnu.org>
PR libgfortran/48298
* gfortran.map : Flag _st_set_nml_dtio_var and
_gfortran_transfer_derived.
* io/format.c (format_lex): Detect DTIO formatting.
(parse_format_list): Parse the DTIO format.
(next_format): Include FMT_DT.
* io/format.h : Likewise. Add structure 'udf' to structure
'fnode' to carry the IOTYPE string and the 'vlist'.
* io/io.h : Add prototypes for the two types of DTIO subroutine
and a typedef for gfc_class. Also, add to 'namelist_type'
fields for the pointer to the DTIO procedure and the vtable.
Add fields to struct st_parameter_dt for pointers to the two
types of DTIO subroutine. Add to gfc_unit DTIO specific fields.
(internal_proto): Add prototype for 'read_user_defined' and
'write_user_defined'.
* io/list_read.c (check_buffers): Use the 'current_unit' field.
(unget_char): Likewise.
(eat_spaces): Likewise.
(list_formatted_read_scalar): For case BT_CLASS, call the DTIO
procedure.
(nml_get_obj_data): Likewise when DTIO procedure is present,.
* io/transfer.c : Export prototypes for 'transfer_derived' and
'transfer_derived_write'.
(unformatted_read): For case BT_CLASS, call the DTIO procedure.
(unformatted_write): Likewise.
(formatted_transfer_scalar_read): Likewise.
(formatted_transfer_scalar_write: Likewise.
(transfer_derived): New function.
(data_transfer_init): Set last_char if no child_dtio.
(finalize_transfer): Return if child_dtio set.
(st_write_done): Add condition for child_dtio not set.
Add extra arguments for st_set_nml_var prototype.
(set_nml_var): New function that contains the contents of the
old version of st_set_nml_var. Also sets the 'dtio_sub' and
'vtable' fields of the 'nml' structure.
(st_set_nml_var): Now just calls set_nml_var with 'dtio_sub'
and 'vtable' NULL.
(st_set_nml_dtio_var): New function that calls set_nml_var.
* io/unit.c (get_external_unit): If the found unit child_dtio
is non zero, don't do any mutex locking/unlocking. Just
return the unit.
* io/unix.c (tempfile_open): Revert to C style comment.
* io/write.c (list_formatted_write_scalar): Do the DTIO call.
(nml_write_obj): Add BT_CLASS and do the DTIO call.
2016-08-29 Nathan Sidwell <nathan@acm.org> 2016-08-29 Nathan Sidwell <nathan@acm.org>
* configure.ac (nvptx-*): Hardwire newlib. * configure.ac (nvptx-*): Hardwire newlib.

6
libgfortran/gfortran.map
View File

@ -1289,6 +1289,12 @@ GFORTRAN_1.7 {
_gfortran_shape_2; _gfortran_shape_2;
} GFORTRAN_1.6; } GFORTRAN_1.6;
GFORTRAN_1.8 {
global:
_gfortran_st_set_nml_dtio_var;
_gfortran_transfer_derived;
} GFORTRAN_1.7;
F2C_1.0 { F2C_1.0 {
global: global:
_gfortran_f2c_specific__abs_c4; _gfortran_f2c_specific__abs_c4;

81
libgfortran/io/format.c
View File

@ -261,11 +261,20 @@ void
free_format_data (format_data *fmt) free_format_data (format_data *fmt)
{ {
fnode_array *fa, *fa_next; fnode_array *fa, *fa_next;
fnode *fnp;
if (fmt == NULL) if (fmt == NULL)
return; 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) for (fa = fmt->array.next; fa; fa = fa_next)
{ {
fa_next = fa->next; fa_next = fa->next;
@ -545,6 +554,9 @@ format_lex (format_data *fmt)
case 'C': case 'C':
token = FMT_DC; token = FMT_DC;
break; break;
case 'T':
token = FMT_DT;
break;
default: default:
token = FMT_D; token = FMT_D;
unget_char (fmt); unget_char (fmt);
@ -806,6 +818,7 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
case FMT_EN: case FMT_EN:
case FMT_ES: case FMT_ES:
case FMT_D: case FMT_D:
case FMT_DT:
case FMT_L: case FMT_L:
case FMT_A: case FMT_A:
case FMT_F: case FMT_F:
@ -849,6 +862,7 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
/* In this state, t must currently be a data descriptor. Deal with /* In this state, t must currently be a data descriptor. Deal with
things that can/must follow the descriptor */ things that can/must follow the descriptor */
data_desc: data_desc:
switch (t) switch (t)
{ {
case FMT_L: case FMT_L:
@ -997,7 +1011,57 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
} }
break; 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: case FMT_H:
if (repeat > fmt->format_string_len) if (repeat > fmt->format_string_len)
{ {
@ -1219,9 +1283,12 @@ parse_format (st_parameter_dt *dtp)
format_data *fmt; format_data *fmt;
bool format_cache_ok, seen_data_desc = false; bool format_cache_ok, seen_data_desc = false;
/* Don't cache for internal units and set an arbitrary limit on the size of /* Don't cache for internal units and set an arbitrary limit on the
format strings we will cache. (Avoids memory issues.) */ size of format strings we will cache. (Avoids memory issues.)
format_cache_ok = !is_internal_unit (dtp); 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. */ /* Lookup format string to see if it has already been parsed. */
if (format_cache_ok) if (format_cache_ok)
@ -1257,6 +1324,10 @@ parse_format (st_parameter_dt *dtp)
fmt->reversion_ok = 0; fmt->reversion_ok = 0;
fmt->saved_format = NULL; 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. */ /* Allocate the first format node as the root of the tree. */
fmt->last = &fmt->array; fmt->last = &fmt->array;
@ -1392,7 +1463,7 @@ next_format (st_parameter_dt *dtp)
if (!fmt->reversion_ok && if (!fmt->reversion_ok &&
(t == FMT_I || t == FMT_B || t == FMT_O || t == FMT_Z || t == FMT_F || (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_E || t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_L ||
t == FMT_A || t == FMT_D)) t == FMT_A || t == FMT_D || t == FMT_DT))
fmt->reversion_ok = 1; fmt->reversion_ok = 1;
return f; return f;
} }

10
libgfortran/io/format.h
View File

@ -38,7 +38,7 @@ typedef enum
FMT_LPAREN, FMT_RPAREN, FMT_X, FMT_S, FMT_SS, FMT_SP, FMT_STRING, 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_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_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_DC,
FMT_DP, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ FMT_DP, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT
} }
format_token; format_token;
@ -74,6 +74,14 @@ struct fnode
} }
integer; integer;
struct
{
char *string;
int string_len;
gfc_array_i4 *vlist;
}
udf; /* User Defined Format. */
int w; int w;
int k; int k;
int r; int r;

50
libgfortran/io/io.h
View File

@ -94,6 +94,30 @@ typedef struct array_loop_spec
} }
array_loop_spec; array_loop_spec;
/* User defined input/output iomsg length. */
#define IOMSG_LEN 256
/* Subroutine formatted_dtio (struct, unit, iotype, v_list, iostat,
iomsg, (_iotype), (_iomsg)) */
typedef void (*formatted_dtio)(void *, GFC_INTEGER_4 *, char *, gfc_array_i4 *,
GFC_INTEGER_4 *, char *,
gfc_charlen_type, gfc_charlen_type);
/* Subroutine unformatted_dtio (struct, unit, iostat, iomsg, (_iomsg)) */
typedef void (*unformatted_dtio)(void *, GFC_INTEGER_4 *, GFC_INTEGER_4 *,
char *, gfc_charlen_type);
/* The dtio calls for namelist require a CLASS object to be built. */
typedef struct gfc_class
{
void *data;
void *vptr;
index_type len;
}
gfc_class;
/* A structure to build a hash table for format data. */ /* A structure to build a hash table for format data. */
#define FORMAT_HASH_SIZE 16 #define FORMAT_HASH_SIZE 16
@ -136,6 +160,12 @@ typedef struct namelist_type
/* Address for the start of the object's data. */ /* Address for the start of the object's data. */
void * mem_pos; 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. */ /* Flag to show that a read is to be attempted for this node. */
int touched; int touched;
@ -462,7 +492,7 @@ typedef struct st_parameter_dt
/* Used for ungetc() style functionality. Possible values /* Used for ungetc() style functionality. Possible values
are an unsigned char, EOF, or EOF - 1 used to mark the are an unsigned char, EOF, or EOF - 1 used to mark the
field as not valid. */ field as not valid. */
int last_char; int last_char; /* No longer used, moved to gfc_unit. */
char nml_delim; char nml_delim;
int repeat_count; int repeat_count;
@ -484,6 +514,8 @@ typedef struct st_parameter_dt
largest kind. */ largest kind. */
char value[32]; char value[32];
GFC_IO_INT size_used; GFC_IO_INT size_used;
formatted_dtio fdtio_ptr;
unformatted_dtio ufdtio_ptr;
} p; } p;
/* This pad size must be equal to the pad_size declared in /* This pad size must be equal to the pad_size declared in
trans-io.c (gfc_build_io_library_fndecls). The above structure trans-io.c (gfc_build_io_library_fndecls). The above structure
@ -607,6 +639,10 @@ typedef struct gfc_unit
/* Function pointer, points to list_read worker functions. */ /* Function pointer, points to list_read worker functions. */
int (*next_char_fn_ptr) (st_parameter_dt *); int (*next_char_fn_ptr) (st_parameter_dt *);
void (*push_char_fn_ptr) (st_parameter_dt *, int); 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; gfc_unit;
@ -728,6 +764,12 @@ internal_proto(read_radix);
extern void read_decimal (st_parameter_dt *, const fnode *, char *, int); extern void read_decimal (st_parameter_dt *, const fnode *, char *, int);
internal_proto(read_decimal); 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 */ /* list_read.c */
extern void list_formatted_read (st_parameter_dt *, bt, void *, int, size_t, extern void list_formatted_read (st_parameter_dt *, bt, void *, int, size_t,
@ -790,6 +832,12 @@ internal_proto(write_x);
extern void write_z (st_parameter_dt *, const fnode *, const char *, int); extern void write_z (st_parameter_dt *, const fnode *, const char *, int);
internal_proto(write_z); 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, extern void list_formatted_write (st_parameter_dt *, bt, void *, int, size_t,
size_t); size_t);
internal_proto(list_formatted_write); internal_proto(list_formatted_write);

99
libgfortran/io/list_read.c
View File

@ -84,7 +84,7 @@ push_char_default (st_parameter_dt *dtp, int c)
if (dtp->u.p.saved_string == NULL) if (dtp->u.p.saved_string == NULL)
{ {
// Plain malloc should suffice here, zeroing not needed? /* Plain malloc should suffice here, zeroing not needed? */
dtp->u.p.saved_string = xcalloc (SCRATCH_SIZE, 1); dtp->u.p.saved_string = xcalloc (SCRATCH_SIZE, 1);
dtp->u.p.saved_length = SCRATCH_SIZE; dtp->u.p.saved_length = SCRATCH_SIZE;
dtp->u.p.saved_used = 0; dtp->u.p.saved_used = 0;
@ -170,11 +170,11 @@ check_buffers (st_parameter_dt *dtp)
int c; int c;
c = '\0'; c = '\0';
if (dtp->u.p.last_char != EOF - 1) if (dtp->u.p.current_unit->last_char != EOF - 1)
{ {
dtp->u.p.at_eol = 0; dtp->u.p.at_eol = 0;
c = dtp->u.p.last_char; c = dtp->u.p.current_unit->last_char;
dtp->u.p.last_char = EOF - 1; dtp->u.p.current_unit->last_char = EOF - 1;
goto done; goto done;
} }
@ -369,7 +369,7 @@ utf_done:
static void static void
unget_char (st_parameter_dt *dtp, int c) unget_char (st_parameter_dt *dtp, int c)
{ {
dtp->u.p.last_char = c; dtp->u.p.current_unit->last_char = c;
} }
@ -385,7 +385,7 @@ eat_spaces (st_parameter_dt *dtp)
This is an optimization unique to character arrays with large This is an optimization unique to character arrays with large
character lengths (PR38199). This code eliminates numerous calls character lengths (PR38199). This code eliminates numerous calls
to next_character. */ to next_character. */
if (is_array_io (dtp) && (dtp->u.p.last_char == EOF - 1)) if (is_array_io (dtp) && (dtp->u.p.current_unit->last_char == EOF - 1))
{ {
gfc_offset offset = stell (dtp->u.p.current_unit->s); gfc_offset offset = stell (dtp->u.p.current_unit->s);
gfc_offset i; gfc_offset i;
@ -2167,6 +2167,46 @@ list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p,
if (dtp->u.p.repeat_count > 0) if (dtp->u.p.repeat_count > 0)
memcpy (dtp->u.p.value, p, size); memcpy (dtp->u.p.value, p, size);
break; 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: default:
internal_error (&dtp->common, "Bad type for list read"); internal_error (&dtp->common, "Bad type for list read");
} }
@ -3206,6 +3246,53 @@ get_name:
goto nml_err_ret; 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. /* Get the length, data length, base pointer and rank of the variable.
Set the default loop specification first. */ Set the default loop specification first. */

293
libgfortran/io/transfer.c
View File

@ -122,6 +122,15 @@ extern void transfer_array_write (st_parameter_dt *, gfc_array_char *, int,
gfc_charlen_type); gfc_charlen_type);
export_proto(transfer_array_write); 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_read (st_parameter_dt *, int);
static void us_write (st_parameter_dt *, int); static void us_write (st_parameter_dt *, int);
static void next_record_r_unf (st_parameter_dt *, int); static void next_record_r_unf (st_parameter_dt *, int);
@ -988,6 +997,40 @@ static void
unformatted_read (st_parameter_dt *dtp, bt type, unformatted_read (st_parameter_dt *dtp, bt type,
void *dest, int kind, size_t size, size_t nelems) 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) if (type == BT_CHARACTER)
size *= GFC_SIZE_OF_CHAR_KIND(kind); size *= GFC_SIZE_OF_CHAR_KIND(kind);
read_block_direct (dtp, dest, size * nelems); read_block_direct (dtp, dest, size * nelems);
@ -1016,12 +1059,46 @@ unformatted_read (st_parameter_dt *dtp, bt type,
/* Master function for unformatted writes. NOTE: For kind=10 the size is 16 /* 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 bytes on 64 bit machines. The unused bytes are not initialized and never
used, which can show an error with memory checking analyzers like used, which can show an error with memory checking analyzers like
valgrind. */ valgrind. We us BT_CLASS to denote a User Defined I/O call. */
static void static void
unformatted_write (st_parameter_dt *dtp, bt type, unformatted_write (st_parameter_dt *dtp, bt type,
void *source, int kind, size_t size, size_t nelems) 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) if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
|| kind == 1) || kind == 1)
{ {
@ -1099,6 +1176,9 @@ type_name (bt type)
case BT_COMPLEX: case BT_COMPLEX:
p = "COMPLEX"; p = "COMPLEX";
break; break;
case BT_CLASS:
p = "CLASS or DERIVED";
break;
default: default:
internal_error (NULL, "type_name(): Bad type"); internal_error (NULL, "type_name(): Bad type");
} }
@ -1322,6 +1402,65 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind
read_f (dtp, f, p, kind); read_f (dtp, f, p, kind);
break; 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: case FMT_E:
if (n == 0) if (n == 0)
goto need_read_data; goto need_read_data;
@ -1630,7 +1769,8 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
&& ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O && ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O
|| t == FMT_Z || t == FMT_F || t == FMT_E || t == FMT_Z || t == FMT_F || t == FMT_E
|| t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_EN || t == FMT_ES || t == FMT_G
|| t == FMT_L || t == FMT_A || t == FMT_D)) || t == FMT_L || t == FMT_A || t == FMT_D
|| t == FMT_DT))
|| t == FMT_STRING)) || t == FMT_STRING))
{ {
if (dtp->u.p.skips > 0) if (dtp->u.p.skips > 0)
@ -1733,6 +1873,63 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
write_d (dtp, f, p, kind); write_d (dtp, f, p, kind);
break; 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: case FMT_E:
if (n == 0) if (n == 0)
goto need_data; goto need_data;
@ -2198,6 +2395,25 @@ transfer_array_write (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
transfer_array (dtp, desc, kind, charlen); 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. */ /* Preposition a sequential unformatted file while reading. */
static void static void
@ -2384,6 +2600,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
dtp->u.p.size_used = 0; /* Initialize the count. */ dtp->u.p.size_used = 0; /* Initialize the count. */
dtp->u.p.current_unit = get_unit (dtp, 1); dtp->u.p.current_unit = get_unit (dtp, 1);
if (dtp->u.p.current_unit->s == NULL) if (dtp->u.p.current_unit->s == NULL)
{ /* Open the unit with some default flags. */ { /* Open the unit with some default flags. */
st_parameter_open opp; st_parameter_open opp;
@ -2542,7 +2759,6 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
"EOF marker, possibly use REWIND or BACKSPACE"); "EOF marker, possibly use REWIND or BACKSPACE");
return; return;
} }
} }
/* Process the ADVANCE option. */ /* Process the ADVANCE option. */
@ -2834,7 +3050,8 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
{ {
if ((cf & IOPARM_DT_LIST_FORMAT) != 0) if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
{ {
dtp->u.p.last_char = EOF - 1; 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; dtp->u.p.transfer = list_formatted_read;
} }
else else
@ -3540,6 +3757,18 @@ finalize_transfer (st_parameter_dt *dtp)
{ {
GFC_INTEGER_4 cf = dtp->common.flags; 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) if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
*dtp->size = dtp->u.p.size_used; *dtp->size = dtp->u.p.size_used;
@ -3556,15 +3785,6 @@ finalize_transfer (st_parameter_dt *dtp)
goto done; 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; dtp->u.p.transfer = NULL;
if (dtp->u.p.current_unit == NULL) if (dtp->u.p.current_unit == NULL)
goto done; goto done;
@ -3760,7 +3980,8 @@ st_write_done (st_parameter_dt *dtp)
/* Deal with endfile conditions associated with sequential files. */ /* Deal with endfile conditions associated with sequential files. */
if (dtp->u.p.current_unit != NULL if (dtp->u.p.current_unit != NULL
&& dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL) && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
&& dtp->u.p.current_unit->child_dtio == 0)
switch (dtp->u.p.current_unit->endfile) switch (dtp->u.p.current_unit->endfile)
{ {
case AT_ENDFILE: /* Remain at the endfile record. */ case AT_ENDFILE: /* Remain at the endfile record. */
@ -3807,15 +4028,10 @@ st_wait (st_parameter_wait *wtp __attribute__((unused)))
/* Receives the scalar information for namelist objects and stores it /* Receives the scalar information for namelist objects and stores it
in a linked list of namelist_info types. */ in a linked list of namelist_info types. */
extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *, static void
GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4); set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
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 len, gfc_charlen_type string_length,
GFC_INTEGER_4 dtype) GFC_INTEGER_4 dtype, void *dtio_sub, void *vtable)
{ {
namelist_info *t1 = NULL; namelist_info *t1 = NULL;
namelist_info *nml; namelist_info *nml;
@ -3824,6 +4040,8 @@ st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
nml = (namelist_info*) xmalloc (sizeof (namelist_info)); nml = (namelist_info*) xmalloc (sizeof (namelist_info));
nml->mem_pos = var_addr; nml->mem_pos = var_addr;
nml->dtio_sub = dtio_sub;
nml->vtable = vtable;
nml->var_name = (char*) xmalloc (var_name_len + 1); nml->var_name = (char*) xmalloc (var_name_len + 1);
memcpy (nml->var_name, var_name, var_name_len); memcpy (nml->var_name, var_name, var_name_len);
@ -3863,6 +4081,37 @@ st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
} }
} }
extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
export_proto(st_set_nml_var);
void
st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
GFC_INTEGER_4 len, gfc_charlen_type string_length,
GFC_INTEGER_4 dtype)
{
set_nml_var (dtp, var_addr, var_name, len, string_length,
dtype, NULL, NULL);
}
/* Essentially the same as previous but carrying the dtio procedure
and the vtable as additional arguments. */
extern void st_set_nml_dtio_var (st_parameter_dt *dtp, void *, char *,
GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4,
void *, void *);
export_proto(st_set_nml_dtio_var);
void
st_set_nml_dtio_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
GFC_INTEGER_4 len, gfc_charlen_type string_length,
GFC_INTEGER_4 dtype, void *dtio_sub, void *vtable)
{
set_nml_var (dtp, var_addr, var_name, len, string_length,
dtype, dtio_sub, vtable);
}
/* Store the dimensional information for the namelist object. */ /* Store the dimensional information for the namelist object. */
extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4, extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
index_type, index_type, index_type, index_type,

4
libgfortran/io/unit.c
View File

@ -348,7 +348,7 @@ retry:
} }
found: found:
if (p != NULL) if (p != NULL && (p->child_dtio == 0))
{ {
/* Fast path. */ /* Fast path. */
if (! __gthread_mutex_trylock (&p->lock)) if (! __gthread_mutex_trylock (&p->lock))
@ -363,7 +363,7 @@ found:
__gthread_mutex_unlock (&unit_lock); __gthread_mutex_unlock (&unit_lock);
if (p != NULL) if (p != NULL && (p->child_dtio == 0))
{ {
__gthread_mutex_lock (&p->lock); __gthread_mutex_lock (&p->lock);
if (p->closed) if (p->closed)

2
libgfortran/io/unix.c
View File

@ -1121,7 +1121,7 @@ tempfile_open (const char *tempdir, char **fname)
) )
slash = ""; slash = "";
// Take care that the template is longer in the mktemp() branch. /* Take care that the template is longer in the mktemp() branch. */
char * template = xmalloc (tempdirlen + 23); char * template = xmalloc (tempdirlen + 23);
#ifdef HAVE_MKSTEMP #ifdef HAVE_MKSTEMP

88
libgfortran/io/write.c
View File

@ -1710,6 +1710,46 @@ list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
case BT_COMPLEX: case BT_COMPLEX:
write_complex (dtp, p, kind, size); write_complex (dtp, p, kind, size);
break; 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: default:
internal_error (&dtp->common, "list_formatted_write(): Bad type"); internal_error (&dtp->common, "list_formatted_write(): Bad type");
} }
@ -1985,7 +2025,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
break; break;
case BT_DERIVED: case BT_DERIVED:
case BT_CLASS:
/* To treat a derived type, we need to build two strings: /* To treat a derived type, we need to build two strings:
ext_name = the name, including qualifiers that prepends ext_name = the name, including qualifiers that prepends
component names in the output - passed to component names in the output - passed to
@ -1995,6 +2035,52 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
components. */ components. */
/* First ext_name => get length of all possible 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_name_len = base_name ? strlen (base_name) : 0;
base_var_name_len = base ? strlen (base->var_name) : 0; base_var_name_len = base ? strlen (base->var_name) : 0;