OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests 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>
* 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;
case INTERFACE_GENERIC:
case INTERFACE_DTIO:
if (gfc_get_symbol (name, NULL, &sym))
goto done;
@ -9378,6 +9379,7 @@ gfc_match_generic (void)
switch (op_type)
{
case INTERFACE_GENERIC:
case INTERFACE_DTIO:
snprintf (bind_name, sizeof (bind_name), "%s", name);
break;
@ -9413,6 +9415,7 @@ gfc_match_generic (void)
switch (op_type)
{
case INTERFACE_DTIO:
case INTERFACE_USER_OP:
case INTERFACE_GENERIC:
{
@ -9467,6 +9470,7 @@ gfc_match_generic (void)
switch (op_type)
{
case INTERFACE_DTIO:
case INTERFACE_GENERIC:
case INTERFACE_USER_OP:
{

23
gcc/fortran/gfortran.h
View File

@ -177,8 +177,10 @@ enum gfc_intrinsic_op
/* .EQ., .NE., .GT., .GE., .LT., .LE. (OS = Old-Style) */
INTRINSIC_EQ_OS, INTRINSIC_NE_OS, INTRINSIC_GT_OS, INTRINSIC_GE_OS,
INTRINSIC_LT_OS, INTRINSIC_LE_OS,
INTRINSIC_NOT, INTRINSIC_USER, INTRINSIC_ASSIGN,
INTRINSIC_PARENTHESES, GFC_INTRINSIC_END /* Sentinel */
INTRINSIC_NOT, INTRINSIC_USER, INTRINSIC_ASSIGN, INTRINSIC_PARENTHESES,
/* User defined derived type pseudo operator. */
INTRINSIC_FORMATTED, INTRINSIC_UNFORMATTED,
GFC_INTRINSIC_END /* Sentinel */
};
/* This macro is the number of intrinsic operators that exist.
@ -261,7 +263,8 @@ enum gfc_statement
enum interface_type
{
INTERFACE_NAMELESS = 1, INTERFACE_GENERIC,
INTERFACE_INTRINSIC_OP, INTERFACE_USER_OP, INTERFACE_ABSTRACT
INTERFACE_INTRINSIC_OP, INTERFACE_USER_OP, INTERFACE_ABSTRACT,
INTERFACE_DTIO
};
/* Symbol flavors: these are all mutually exclusive.
@ -313,6 +316,12 @@ extern const mstring access_types[];
extern const mstring ifsrc_types[];
extern const mstring save_status[];
/* Strings for DTIO procedure names. In symbol.c. */
extern const mstring dtio_procs[];
enum dtio_codes
{ DTIO_RF = 0, DTIO_WF, DTIO_RUF, DTIO_WUF };
/* Enumeration of all the generic intrinsic functions. Used by the
backend for identification of a function. */
@ -784,7 +793,7 @@ typedef struct
unsigned implicit_pure:1;
/* This is set for a procedure that contains expressions referencing
arrays coming from outside its namespace.
arrays coming from outside its namespace.
This is used to force the creation of a temporary when the LHS of
an array assignment may be used by an elemental procedure appearing
on the RHS. */
@ -841,7 +850,8 @@ typedef struct
entities. */
unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1,
private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1,
event_comp:1, defined_assign_comp:1, unlimited_polymorphic:1;
event_comp:1, defined_assign_comp:1, unlimited_polymorphic:1,
has_dtio_procs:1;
/* This is a temporary selector for SELECT TYPE or an associate
variable for SELECT_TYPE or ASSOCIATE. */
@ -3170,6 +3180,9 @@ bool gfc_check_operator_interface (gfc_symbol*, gfc_intrinsic_op, locus);
int gfc_has_vector_subscript (gfc_expr*);
gfc_intrinsic_op gfc_equivalent_op (gfc_intrinsic_op);
bool gfc_check_typebound_override (gfc_symtree*, gfc_symtree*);
void gfc_check_dtio_interfaces (gfc_symbol*);
gfc_symbol* gfc_find_specific_dtio_proc (gfc_symbol*, bool, bool);
/* io.c */
extern gfc_st_label format_asterisk;

393
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
interface is found, the 'name' or 'op' pointers may be set.
This subroutine doesn't return MATCH_NO. */
@ -162,6 +175,40 @@ gfc_match_generic_spec (interface_type *type,
return MATCH_YES;
}
if (gfc_match (" read ( %n )", buffer) == MATCH_YES)
{
*op = dtio_op (buffer);
if (*op == INTRINSIC_FORMATTED)
{
strcpy (name, gfc_code2string (dtio_procs, DTIO_RF));
*type = INTERFACE_DTIO;
}
if (*op == INTRINSIC_UNFORMATTED)
{
strcpy (name, gfc_code2string (dtio_procs, DTIO_RUF));
*type = INTERFACE_DTIO;
}
if (*op != INTRINSIC_NONE)
return MATCH_YES;
}
if (gfc_match (" write ( %n )", buffer) == MATCH_YES)
{
*op = dtio_op (buffer);
if (*op == INTRINSIC_FORMATTED)
{
strcpy (name, gfc_code2string (dtio_procs, DTIO_WF));
*type = INTERFACE_DTIO;
}
if (*op == INTRINSIC_UNFORMATTED)
{
strcpy (name, gfc_code2string (dtio_procs, DTIO_WUF));
*type = INTERFACE_DTIO;
}
if (*op != INTRINSIC_NONE)
return MATCH_YES;
}
if (gfc_match_name (buffer) == MATCH_YES)
{
strcpy (name, buffer);
@ -209,6 +256,7 @@ gfc_match_interface (void)
switch (type)
{
case INTERFACE_DTIO:
case INTERFACE_GENERIC:
if (gfc_get_symbol (name, NULL, &sym))
return MATCH_ERROR;
@ -349,7 +397,7 @@ gfc_match_end_interface (void)
if (strcmp(s2, "none") == 0)
gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> "
"at %C, ", s1);
else
else
gfc_error ("Expecting %<END INTERFACE OPERATOR (%s)%> at %C, "
"but got %s", s1, s2);
}
@ -371,6 +419,7 @@ gfc_match_end_interface (void)
break;
case INTERFACE_DTIO:
case INTERFACE_GENERIC:
if (type != current_interface.type
|| strcmp (current_interface.sym->name, name) != 0)
@ -3957,7 +4006,7 @@ gfc_extend_expr (gfc_expr *e)
else
return MATCH_YES;
}
if (i == INTRINSIC_USER)
{
for (ns = gfc_current_ns; ns; ns = ns->parent)
@ -4148,60 +4197,60 @@ gfc_add_interface (gfc_symbol *new_sym)
{
case INTRINSIC_EQ:
case INTRINSIC_EQ_OS:
if (!gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym,
if (!gfc_check_new_interface (ns->op[INTRINSIC_EQ], new_sym,
gfc_current_locus)
|| !gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS],
|| !gfc_check_new_interface (ns->op[INTRINSIC_EQ_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
if (!gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym,
if (!gfc_check_new_interface (ns->op[INTRINSIC_NE], new_sym,
gfc_current_locus)
|| !gfc_check_new_interface (ns->op[INTRINSIC_NE_OS],
|| !gfc_check_new_interface (ns->op[INTRINSIC_NE_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_GT:
case INTRINSIC_GT_OS:
if (!gfc_check_new_interface (ns->op[INTRINSIC_GT],
if (!gfc_check_new_interface (ns->op[INTRINSIC_GT],
new_sym, gfc_current_locus)
|| !gfc_check_new_interface (ns->op[INTRINSIC_GT_OS],
|| !gfc_check_new_interface (ns->op[INTRINSIC_GT_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_GE:
case INTRINSIC_GE_OS:
if (!gfc_check_new_interface (ns->op[INTRINSIC_GE],
if (!gfc_check_new_interface (ns->op[INTRINSIC_GE],
new_sym, gfc_current_locus)
|| !gfc_check_new_interface (ns->op[INTRINSIC_GE_OS],
|| !gfc_check_new_interface (ns->op[INTRINSIC_GE_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_LT:
case INTRINSIC_LT_OS:
if (!gfc_check_new_interface (ns->op[INTRINSIC_LT],
if (!gfc_check_new_interface (ns->op[INTRINSIC_LT],
new_sym, gfc_current_locus)
|| !gfc_check_new_interface (ns->op[INTRINSIC_LT_OS],
|| !gfc_check_new_interface (ns->op[INTRINSIC_LT_OS],
new_sym, gfc_current_locus))
return false;
break;
case INTRINSIC_LE:
case INTRINSIC_LE_OS:
if (!gfc_check_new_interface (ns->op[INTRINSIC_LE],
if (!gfc_check_new_interface (ns->op[INTRINSIC_LE],
new_sym, gfc_current_locus)
|| !gfc_check_new_interface (ns->op[INTRINSIC_LE_OS],
|| !gfc_check_new_interface (ns->op[INTRINSIC_LE_OS],
new_sym, gfc_current_locus))
return false;
break;
default:
if (!gfc_check_new_interface (ns->op[current_interface.op],
if (!gfc_check_new_interface (ns->op[current_interface.op],
new_sym, gfc_current_locus))
return false;
}
@ -4210,13 +4259,14 @@ gfc_add_interface (gfc_symbol *new_sym)
break;
case INTERFACE_GENERIC:
case INTERFACE_DTIO:
for (ns = current_interface.ns; ns; ns = ns->parent)
{
gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
if (sym == NULL)
continue;
if (!gfc_check_new_interface (sym->generic,
if (!gfc_check_new_interface (sym->generic,
new_sym, gfc_current_locus))
return false;
}
@ -4225,7 +4275,7 @@ gfc_add_interface (gfc_symbol *new_sym)
break;
case INTERFACE_USER_OP:
if (!gfc_check_new_interface (current_interface.uop->op,
if (!gfc_check_new_interface (current_interface.uop->op,
new_sym, gfc_current_locus))
return false;
@ -4257,6 +4307,7 @@ gfc_current_interface_head (void)
break;
case INTERFACE_GENERIC:
case INTERFACE_DTIO:
return current_interface.sym->generic;
break;
@ -4280,6 +4331,7 @@ gfc_set_current_interface_head (gfc_interface *i)
break;
case INTERFACE_GENERIC:
case INTERFACE_DTIO:
current_interface.sym->generic = i;
break;
@ -4496,3 +4548,310 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
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_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END,
FMT_ERROR, FMT_DC, FMT_DP, FMT_T, FMT_TR, FMT_TL, FMT_STAR, FMT_RC,
FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ
FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT
};
/* Local variables for checking format strings. The saved_token is
@ -463,6 +463,44 @@ format_lex (void)
return FMT_ERROR;
token = FMT_DC;
}
else if (c == 'T')
{
if (!gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DT format "
"specifier not allowed at %C"))
return FMT_ERROR;
token = FMT_DT;
c = next_char_not_space (&error);
if (c == '\'' || c == '"')
{
delim = c;
value = 0;
for (;;)
{
c = next_char (INSTRING_WARN);
if (c == '\0')
{
token = FMT_END;
break;
}
if (c == delim)
{
c = next_char (NONSTRING);
if (c == '\0')
{
token = FMT_END;
break;
}
unget_char ();
break;
}
}
}
else
unget_char ();
}
else
{
token = FMT_D;
@ -652,6 +690,54 @@ format_item_1:
return false;
goto between_desc;
case FMT_DT:
t = format_lex ();
if (t == FMT_ERROR)
goto fail;
switch (t)
{
case FMT_RPAREN:
level--;
if (level < 0)
goto finished;
goto between_desc;
case FMT_COMMA:
goto format_item;
case FMT_LPAREN:
dtio_vlist:
t = format_lex ();
if (t == FMT_ERROR)
goto fail;
if (t != FMT_POSINT)
{
error = posint_required;
goto syntax;
}
t = format_lex ();
if (t == FMT_ERROR)
goto fail;
if (t == FMT_COMMA)
goto dtio_vlist;
if (t != FMT_RPAREN)
{
error = _("Right parenthesis expected at %C");
goto syntax;
}
goto between_desc;
default:
error = unexpected_element;
goto syntax;
}
goto format_item;
case FMT_SIGN:
case FMT_BLANK:
case FMT_DP:

6
gcc/fortran/match.c
View File

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

136
gcc/fortran/resolve.c
View File

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

9
gcc/fortran/symbol.c
View File

@ -87,6 +87,15 @@ const mstring save_status[] =
minit ("IMPLICIT-SAVE", SAVE_IMPLICIT),
};
/* Set the mstrings for DTIO procedure names. */
const mstring dtio_procs[] =
{
minit ("_dtio_formatted_read", DTIO_RF),
minit ("_dtio_formatted_write", DTIO_WF),
minit ("_dtio_unformatted_read", DTIO_RUF),
minit ("_dtio_unformatted_write", DTIO_WUF),
};
/* This is to make sure the backend generates setup code in the correct
order. */

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)))
TREE_STATIC (decl) = 1;
/* If derived-type variables with DTIO procedures are not made static
some bits of code referencing them get optimized away.
TODO Understand why this is so and fix it. */
if (!sym->attr.use_assoc
&& ((sym->ts.type == BT_DERIVED
&& sym->ts.u.derived->attr.has_dtio_procs)
|| (sym->ts.type == BT_CLASS
&& CLASS_DATA (sym)->ts.u.derived->attr.has_dtio_procs)))
TREE_STATIC (decl) = 1;
if (sym->attr.volatile_)
{
TREE_THIS_VOLATILE (decl) = 1;

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

@ -430,9 +430,17 @@ gfc_get_vptr_from_expr (tree expr)
else
type = NULL_TREE;
}
if (TREE_CODE (tmp) == VAR_DECL)
if (TREE_CODE (tmp) == VAR_DECL
|| TREE_CODE (tmp) == PARM_DECL)
break;
}
if (POINTER_TYPE_P (TREE_TYPE (tmp)))
tmp = build_fold_indirect_ref_loc (input_location, tmp);
if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
return gfc_class_vptr_get (tmp);
return NULL_TREE;
}
@ -511,7 +519,14 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
if (optional)
cond_optional = gfc_conv_expr_present (e->symtree->n.sym);
if (parmse->ss && parmse->ss->info->useflags)
if (parmse->expr && POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
{
/* If there is a ready made pointer to a derived type, use it
rather than evaluating the expression again. */
tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
gfc_add_modify (&parmse->pre, ctree, tmp);
}
else if (parmse->ss && parmse->ss->info && parmse->ss->info->useflags)
{
/* For an array reference in an elemental procedure call we need
to retain the ss to provide the scalarized array reference. */
@ -522,7 +537,6 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
cond_optional, tmp,
fold_convert (TREE_TYPE (tmp), null_pointer_node));
gfc_add_modify (&parmse->pre, ctree, tmp);
}
else
{
@ -2319,7 +2333,7 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
On the other hand, if the context is a UNION or a MAP (a
RECORD_TYPE within a UNION_TYPE) always use the given FIELD_DECL. */
if (context != TREE_TYPE (decl)
if (context != TREE_TYPE (decl)
&& !( TREE_CODE (TREE_TYPE (field)) == UNION_TYPE /* Field is union */
|| TREE_CODE (context) == UNION_TYPE)) /* Field is map */
{

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

@ -132,6 +132,7 @@ enum iocall
IOCALL_X_COMPLEX128_WRITE,
IOCALL_X_ARRAY,
IOCALL_X_ARRAY_WRITE,
IOCALL_X_DERIVED,
IOCALL_OPEN,
IOCALL_CLOSE,
IOCALL_INQUIRE,
@ -142,6 +143,7 @@ enum iocall
IOCALL_ENDFILE,
IOCALL_FLUSH,
IOCALL_SET_NML_VAL,
IOCALL_SET_NML_DTIO_VAL,
IOCALL_SET_NML_VAL_DIM,
IOCALL_WAIT,
IOCALL_NUM
@ -397,6 +399,10 @@ gfc_build_io_library_fndecls (void)
void_type_node, 4, dt_parm_type, pvoid_type_node,
integer_type_node, gfc_charlen_type_node);
iocall[IOCALL_X_DERIVED] = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("transfer_derived")), ".wrR",
void_type_node, 2, dt_parm_type, pvoid_type_node, pchar_type_node);
/* Library entry points */
iocall[IOCALL_READ] = gfc_build_library_function_decl_with_spec (
@ -468,6 +474,12 @@ gfc_build_io_library_fndecls (void)
void_type_node, 6, dt_parm_type, pvoid_type_node, pvoid_type_node,
gfc_int4_type_node, gfc_charlen_type_node, gfc_int4_type_node);
iocall[IOCALL_SET_NML_DTIO_VAL] = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("st_set_nml_dtio_var")), ".w.R",
void_type_node, 8, dt_parm_type, pvoid_type_node, pvoid_type_node,
gfc_int4_type_node, gfc_charlen_type_node, gfc_int4_type_node,
pvoid_type_node, pvoid_type_node);
iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("st_set_nml_var_dim")), ".w",
void_type_node, 5, dt_parm_type, gfc_int4_type_node,
@ -475,12 +487,8 @@ gfc_build_io_library_fndecls (void)
}
/* Generate code to store an integer constant into the
st_parameter_XXX structure. */
static unsigned int
set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
unsigned int val)
static void
set_parameter_tree (stmtblock_t *block, tree var, enum iofield type, tree value)
{
tree tmp;
gfc_st_parameter_field *p = &st_parameter_field[type];
@ -491,7 +499,21 @@ set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
var, p->field, NULL_TREE);
gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (p->field), val));
gfc_add_modify (block, tmp, value);
}
/* Generate code to store an integer constant into the
st_parameter_XXX structure. */
static unsigned int
set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
unsigned int val)
{
gfc_st_parameter_field *p = &st_parameter_field[type];
set_parameter_tree (block, var, type,
build_int_cst (TREE_TYPE (p->field), val));
return p->mask;
}
@ -637,7 +659,7 @@ set_parameter_value_inquire (stmtblock_t *block, tree var,
body = gfc_finish_block (&newblock);
cond3 = gfc_unlikely (cond3, PRED_FORTRAN_FAIL_IO);
cond3 = gfc_unlikely (cond3, PRED_FORTRAN_FAIL_IO);
var = build3_v (COND_EXPR, cond3, body, build_empty_stmt (input_location));
gfc_add_expr_to_block (&se.pre, var);
}
@ -697,13 +719,7 @@ set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
gfc_add_modify (postblock, se.expr, tmp);
}
if (p->param_type == IOPARM_ptype_common)
var = fold_build3_loc (input_location, COMPONENT_REF,
st_parameter[IOPARM_ptype_common].type,
var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
var, p->field, NULL_TREE);
gfc_add_modify (block, tmp, addr);
set_parameter_tree (block, var, type, addr);
return p->mask;
}
@ -1618,6 +1634,8 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
tree dt_parm_addr;
tree decl = NULL_TREE;
tree gfc_int4_type_node = gfc_get_int_type (4);
tree dtio_proc = null_pointer_node;
tree vtable = null_pointer_node;
int n_dim;
int itype;
int rank = 0;
@ -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);
/* Check if the derived type has a specific DTIO for the mode.
Note that although namelist io is forbidden to have a format
list, the specific subroutine is of the formatted kind. */
if (ts->type == BT_DERIVED)
{
gfc_symbol *dtio_sub = NULL;
gfc_symbol *vtab;
dtio_sub = gfc_find_specific_dtio_proc (ts->u.derived,
last_dt == WRITE,
true);
if (dtio_sub != NULL)
{
dtio_proc = gfc_get_symbol_decl (dtio_sub);
dtio_proc = gfc_build_addr_expr (NULL, dtio_proc);
vtab = gfc_find_derived_vtab (ts->u.derived);
vtable = vtab->backend_decl;
if (vtable == NULL_TREE)
vtable = gfc_get_symbol_decl (vtab);
vtable = gfc_build_addr_expr (pvoid_type_node, vtable);
}
}
if (ts->type == BT_CHARACTER)
tmp = ts->u.cl->backend_decl;
else
tmp = build_int_cst (gfc_charlen_type_node, 0);
tmp = build_call_expr_loc (input_location,
iocall[IOCALL_SET_NML_VAL], 6,
dt_parm_addr, addr_expr, string,
build_int_cst (gfc_int4_type_node, ts->kind),
tmp, dtype);
if (dtio_proc == NULL_TREE)
tmp = build_call_expr_loc (input_location,
iocall[IOCALL_SET_NML_VAL], 6,
dt_parm_addr, addr_expr, string,
build_int_cst (gfc_int4_type_node, ts->kind),
tmp, dtype);
else
tmp = build_call_expr_loc (input_location,
iocall[IOCALL_SET_NML_DTIO_VAL], 8,
dt_parm_addr, addr_expr, string,
build_int_cst (gfc_int4_type_node, ts->kind),
tmp, dtype, dtio_proc, vtable);
gfc_add_expr_to_block (block, tmp);
/* If the object is an array, transfer rank times:
@ -1685,7 +1733,8 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
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;
@ -1995,7 +2044,8 @@ gfc_trans_dt_end (gfc_code * code)
}
static void
transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code);
transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
gfc_code * code, tree vptr);
/* Given an array field in a derived type variable, generate the code
for the loop that iterates over array elements, and the code that
@ -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
it to the IO routines. */
tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
transfer_expr (&se, &cm->ts, tmp, NULL);
transfer_expr (&se, &cm->ts, tmp, NULL, NULL_TREE);
/* We are done now with the loop body. Wrap up the scalarizer and
return. */
@ -2081,10 +2131,53 @@ transfer_array_component (tree expr, gfc_component * cm, locus * where)
return gfc_finish_block (&block);
}
/* Helper function for transfer_expr that looks for the DTIO procedure
either as a typebound binding or in a generic interface. If present,
the address expression of the procedure is returned. It is assumed
that the procedure interface has been checked during resolution. */
static tree
get_dtio_proc (gfc_typespec * ts, gfc_code * code, gfc_symbol **dtio_sub)
{
gfc_symbol *derived;
bool formatted = false;
gfc_dt *dt = code->ext.dt;
if (dt && dt->format_expr)
{
char *fmt;
fmt = gfc_widechar_to_char (dt->format_expr->value.character.string,
-1);
if (strtok (fmt, "DT") != NULL)
formatted = true;
}
else if (dt && dt->format_label == &format_asterisk)
{
/* List directed io must call the formatted DTIO procedure. */
formatted = true;
}
if (ts->type == BT_DERIVED)
derived = ts->u.derived;
else
derived = ts->u.derived->components->ts.u.derived;
*dtio_sub = gfc_find_specific_dtio_proc (derived, last_dt == WRITE,
formatted);
if (*dtio_sub)
return gfc_build_addr_expr (NULL, gfc_get_symbol_decl (*dtio_sub));
return NULL_TREE;
}
/* Generate the call for a scalar transfer node. */
static void
transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
gfc_code * code, tree vptr)
{
tree tmp, function, arg2, arg3, field, expr;
gfc_component *c;
@ -2212,43 +2305,81 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
break;
case_bt_struct:
case BT_CLASS:
if (ts->u.derived->components == NULL)
return;
if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
{
gfc_symbol *derived;
gfc_symbol *dtio_sub = NULL;
/* Test for a specific DTIO subroutine. */
if (ts->type == BT_DERIVED)
derived = ts->u.derived;
else
derived = ts->u.derived->components->ts.u.derived;
/* Recurse into the elements of the derived type. */
expr = gfc_evaluate_now (addr_expr, &se->pre);
expr = build_fold_indirect_ref_loc (input_location,
if (derived->attr.has_dtio_procs)
arg2 = get_dtio_proc (ts, code, &dtio_sub);
if (dtio_sub != NULL)
{
tree decl;
decl = build_fold_indirect_ref_loc (input_location,
se->expr);
/* Remember that the first dummy of the DTIO subroutines
is CLASS(derived) for extensible derived types, so the
conversion must be done here for derived type and for
scalarized CLASS array element io-list objects. */
if ((ts->type == BT_DERIVED
&& !(ts->u.derived->attr.sequence
|| ts->u.derived->attr.is_bind_c))
|| (ts->type == BT_CLASS
&& !GFC_CLASS_TYPE_P (TREE_TYPE (decl))))
gfc_conv_derived_to_class (se, code->expr1,
dtio_sub->formal->sym->ts,
vptr, false, false);
addr_expr = se->expr;
function = iocall[IOCALL_X_DERIVED];
break;
}
else if (ts->type == BT_DERIVED)
{
/* Recurse into the elements of the derived type. */
expr = gfc_evaluate_now (addr_expr, &se->pre);
expr = build_fold_indirect_ref_loc (input_location,
expr);
/* Make sure that the derived type has been built. An external
function, if only referenced in an io statement, requires this
check (see PR58771). */
if (ts->u.derived->backend_decl == NULL_TREE)
(void) gfc_typenode_for_spec (ts);
/* Make sure that the derived type has been built. An external
function, if only referenced in an io statement, requires this
check (see PR58771). */
if (ts->u.derived->backend_decl == NULL_TREE)
(void) gfc_typenode_for_spec (ts);
for (c = ts->u.derived->components; c; c = c->next)
{
field = c->backend_decl;
gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
for (c = ts->u.derived->components; c; c = c->next)
{
field = c->backend_decl;
gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
tmp = fold_build3_loc (UNKNOWN_LOCATION,
COMPONENT_REF, TREE_TYPE (field),
expr, field, NULL_TREE);
tmp = fold_build3_loc (UNKNOWN_LOCATION,
COMPONENT_REF, TREE_TYPE (field),
expr, field, NULL_TREE);
if (c->attr.dimension)
{
tmp = transfer_array_component (tmp, c, & code->loc);
gfc_add_expr_to_block (&se->pre, tmp);
}
else
{
if (!c->attr.pointer)
tmp = gfc_build_addr_expr (NULL_TREE, tmp);
transfer_expr (se, &c->ts, tmp, code);
}
if (c->attr.dimension)
{
tmp = transfer_array_component (tmp, c, & code->loc);
gfc_add_expr_to_block (&se->pre, tmp);
}
else
{
if (!c->attr.pointer)
tmp = gfc_build_addr_expr (NULL_TREE, tmp);
transfer_expr (se, &c->ts, tmp, code, NULL_TREE);
}
}
return;
}
/* If a CLASS object gets through to here, fall through and ICE. */
}
return;
default:
gfc_internal_error ("Bad IO basetype (%d)", ts->type);
}
@ -2303,6 +2434,7 @@ gfc_trans_transfer (gfc_code * code)
gfc_ss *ss;
gfc_se se;
tree tmp;
tree vptr;
int n;
gfc_start_block (&block);
@ -2315,8 +2447,18 @@ gfc_trans_transfer (gfc_code * code)
if (expr->rank == 0)
{
/* Transfer a scalar value. */
gfc_conv_expr_reference (&se, expr);
transfer_expr (&se, &expr->ts, se.expr, code);
if (expr->ts.type == BT_CLASS)
{
se.want_pointer = 1;
gfc_conv_expr (&se, expr);
vptr = gfc_get_vptr_from_expr (se.expr);
}
else
{
vptr = NULL_TREE;
gfc_conv_expr_reference (&se, expr);
}
transfer_expr (&se, &expr->ts, se.expr, code, vptr);
}
else
{
@ -2330,7 +2472,8 @@ gfc_trans_transfer (gfc_code * code)
gcc_assert (ref && ref->type == REF_ARRAY);
}
if (!gfc_bt_struct (expr->ts.type)
if (!(gfc_bt_struct (expr->ts.type)
|| expr->ts.type == BT_CLASS)
&& ref && ref->next == NULL
&& !is_subref_array (expr))
{
@ -2378,9 +2521,12 @@ gfc_trans_transfer (gfc_code * code)
gfc_copy_loopinfo_to_se (&se, &loop);
se.ss = ss;
gfc_conv_expr_reference (&se, expr);
transfer_expr (&se, &expr->ts, se.expr, code);
if (expr->ts.type == BT_CLASS)
vptr = gfc_get_vptr_from_expr (ss->info->data.array.descriptor);
else
vptr = NULL_TREE;
transfer_expr (&se, &expr->ts, se.expr, code, vptr);
}
finish_block_label:

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>
* 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

50
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>
* configure.ac (nvptx-*): Hardwire newlib.
@ -120,7 +168,7 @@
(read_character): Remove condition testing c = '!' which is now inside
the is_separator macro. (parse_real): Reject '!' unless in namelist mode.
(read_complex): Reject '!' unless in namelist mode. (read_real): Likewise
reject '!'.
reject '!'.
2016-02-12 Jerry DeLisle <jvdelisle@gcc.gnu.org>

20
libgfortran/gfortran.map
View File

@ -1091,7 +1091,7 @@ GFORTRAN_1.1 {
_gfortran_transpose_char4;
_gfortran_unpack0_char4;
_gfortran_unpack1_char4;
} GFORTRAN_1.0;
} GFORTRAN_1.0;
GFORTRAN_1.2 {
@ -1099,12 +1099,12 @@ GFORTRAN_1.2 {
_gfortran_clz128;
_gfortran_ctz128;
_gfortran_is_extension_of;
} GFORTRAN_1.1;
} GFORTRAN_1.1;
GFORTRAN_1.3 {
global:
_gfortran_error_stop_string;
} GFORTRAN_1.2;
} GFORTRAN_1.2;
GFORTRAN_1.4 {
global:
@ -1187,13 +1187,13 @@ GFORTRAN_1.4 {
_gfortran_cshift0_16_char4;
_gfortran_eoshift0_16_char4;
_gfortran_eoshift2_16_char4;
} GFORTRAN_1.3;
} GFORTRAN_1.3;
GFORTRAN_1.5 {
global:
_gfortran_ftell2;
_gfortran_backtrace;
} GFORTRAN_1.4;
} GFORTRAN_1.4;
GFORTRAN_1.6 {
global:
@ -1274,7 +1274,7 @@ GFORTRAN_1.6 {
__ieee_exceptions_MOD_ieee_support_flag_noarg;
__ieee_exceptions_MOD_ieee_support_halting;
__ieee_exceptions_MOD_ieee_usual;
} GFORTRAN_1.5;
} GFORTRAN_1.5;
GFORTRAN_1.7 {
global:
@ -1287,7 +1287,13 @@ GFORTRAN_1.7 {
_gfortran_mvbits_i16;
_gfortran_shape_1;
_gfortran_shape_2;
} GFORTRAN_1.6;
} GFORTRAN_1.6;
GFORTRAN_1.8 {
global:
_gfortran_st_set_nml_dtio_var;
_gfortran_transfer_derived;
} GFORTRAN_1.7;
F2C_1.0 {
global:

87
libgfortran/io/format.c
View File

@ -70,7 +70,7 @@ free_format_hash_table (gfc_unit *u)
free (u->format_hash_table[i].key);
}
u->format_hash_table[i].key = NULL;
u->format_hash_table[i].key_len = 0;
u->format_hash_table[i].key_len = 0;
u->format_hash_table[i].hashed_fmt = NULL;
}
}
@ -84,7 +84,7 @@ reset_node (fnode *fn)
fn->count = 0;
fn->current = NULL;
if (fn->format != FMT_LPAREN)
return;
@ -261,11 +261,20 @@ void
free_format_data (format_data *fmt)
{
fnode_array *fa, *fa_next;
fnode *fnp;
if (fmt == NULL)
return;
/* Free vlist descriptors in the fnode_array if one was allocated. */
for (fnp = fmt->array.array; fnp->format != FMT_NONE; fnp++)
if (fnp->format == FMT_DT)
{
if (GFC_DESCRIPTOR_DATA(fnp->u.udf.vlist))
free (GFC_DESCRIPTOR_DATA(fnp->u.udf.vlist));
free (fnp->u.udf.vlist);
}
for (fa = fmt->array.next; fa; fa = fa_next)
{
fa_next = fa->next;
@ -545,6 +554,9 @@ format_lex (format_data *fmt)
case 'C':
token = FMT_DC;
break;
case 'T':
token = FMT_DT;
break;
default:
token = FMT_D;
unget_char (fmt);
@ -740,7 +752,7 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
tail->u.string.length = fmt->value;
tail->repeat = 1;
goto optional_comma;
case FMT_RC:
case FMT_RD:
case FMT_RN:
@ -806,6 +818,7 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
case FMT_EN:
case FMT_ES:
case FMT_D:
case FMT_DT:
case FMT_L:
case FMT_A:
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
things that can/must follow the descriptor */
data_desc:
switch (t)
{
case FMT_L:
@ -997,7 +1011,57 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
}
break;
case FMT_DT:
*seen_dd = true;
get_fnode (fmt, &head, &tail, t);
tail->repeat = repeat;
t = format_lex (fmt);
/* Initialize the vlist to a zero size array. */
tail->u.udf.vlist= xmalloc (sizeof(gfc_array_i4));
GFC_DESCRIPTOR_DATA(tail->u.udf.vlist) = NULL;
GFC_DIMENSION_SET(tail->u.udf.vlist->dim[0],1, 0, 0);
if (t == FMT_STRING)
{
/* Get pointer to the optional format string. */
tail->u.udf.string = fmt->string;
tail->u.udf.string_len = fmt->value;
t = format_lex (fmt);
}
if (t == FMT_LPAREN)
{
/* Temporary buffer to hold the vlist values. */
GFC_INTEGER_4 temp[FARRAY_SIZE];
int i = 0;
loop:
t = format_lex (fmt);
if (t != FMT_POSINT)
{
fmt->error = posint_required;
goto finished;
}
/* Save the positive integer value. */
temp[i++] = fmt->value;
t = format_lex (fmt);
if (t == FMT_COMMA)
goto loop;
if (t == FMT_RPAREN)
{
/* We have parsed the complete vlist so initialize the
array descriptor and save it in the format node. */
gfc_array_i4 *vp = tail->u.udf.vlist;
GFC_DESCRIPTOR_DATA(vp) = xmalloc (i * sizeof(GFC_INTEGER_4));
GFC_DIMENSION_SET(vp->dim[0],1, i, 1);
memcpy (GFC_DESCRIPTOR_DATA(vp), temp, i * sizeof(GFC_INTEGER_4));
break;
}
fmt->error = unexpected_element;
goto finished;
}
fmt->saved_token = t;
break;
case FMT_H:
if (repeat > fmt->format_string_len)
{
@ -1219,9 +1283,12 @@ parse_format (st_parameter_dt *dtp)
format_data *fmt;
bool format_cache_ok, seen_data_desc = false;
/* Don't cache for internal units and set an arbitrary limit on the size of
format strings we will cache. (Avoids memory issues.) */
format_cache_ok = !is_internal_unit (dtp);
/* Don't cache for internal units and set an arbitrary limit on the
size of format strings we will cache. (Avoids memory issues.)
Also, the format_hash_table resides in the current_unit, so
child_dtio procedures would overwrite the parent table */
format_cache_ok = !is_internal_unit (dtp)
&& (dtp->u.p.current_unit->child_dtio == 0);
/* Lookup format string to see if it has already been parsed. */
if (format_cache_ok)
@ -1257,6 +1324,10 @@ parse_format (st_parameter_dt *dtp)
fmt->reversion_ok = 0;
fmt->saved_format = NULL;
/* Initialize the fnode_array. */
memset (&(fmt->array), 0, sizeof(fmt->array));
/* Allocate the first format node as the root of the tree. */
fmt->last = &fmt->array;
@ -1392,7 +1463,7 @@ next_format (st_parameter_dt *dtp)
if (!fmt->reversion_ok &&
(t == FMT_I || t == FMT_B || t == FMT_O || t == FMT_Z || t == FMT_F ||
t == FMT_E || t == FMT_EN || t == FMT_ES || t == FMT_G || t == FMT_L ||
t == FMT_A || t == FMT_D))
t == FMT_A || t == FMT_D || t == FMT_DT))
fmt->reversion_ok = 1;
return f;
}

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_BADSTRING, FMT_P, FMT_I, FMT_B, FMT_BN, FMT_BZ, FMT_O, FMT_Z, FMT_F,
FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_DC,
FMT_DP, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ
FMT_DP, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT
}
format_token;
@ -74,6 +74,14 @@ struct fnode
}
integer;
struct
{
char *string;
int string_len;
gfc_array_i4 *vlist;
}
udf; /* User Defined Format. */
int w;
int k;
int r;

50
libgfortran/io/io.h
View File

@ -94,6 +94,30 @@ typedef struct 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. */
#define FORMAT_HASH_SIZE 16
@ -136,6 +160,12 @@ typedef struct namelist_type
/* Address for the start of the object's data. */
void * mem_pos;
/* Address of specific DTIO subroutine. */
void * dtio_sub;
/* Address of vtable if dtio_sub non-null. */
void * vtable;
/* Flag to show that a read is to be attempted for this node. */
int touched;
@ -462,7 +492,7 @@ typedef struct st_parameter_dt
/* Used for ungetc() style functionality. Possible values
are an unsigned char, EOF, or EOF - 1 used to mark the
field as not valid. */
int last_char;
int last_char; /* No longer used, moved to gfc_unit. */
char nml_delim;
int repeat_count;
@ -484,6 +514,8 @@ typedef struct st_parameter_dt
largest kind. */
char value[32];
GFC_IO_INT size_used;
formatted_dtio fdtio_ptr;
unformatted_dtio ufdtio_ptr;
} p;
/* This pad size must be equal to the pad_size declared in
trans-io.c (gfc_build_io_library_fndecls). The above structure
@ -607,6 +639,10 @@ typedef struct gfc_unit
/* Function pointer, points to list_read worker functions. */
int (*next_char_fn_ptr) (st_parameter_dt *);
void (*push_char_fn_ptr) (st_parameter_dt *, int);
/* DTIO Parent/Child procedure, 0 = parent, >0 = child level. */
int child_dtio;
int last_char;
}
gfc_unit;
@ -728,6 +764,12 @@ internal_proto(read_radix);
extern void read_decimal (st_parameter_dt *, const fnode *, char *, int);
internal_proto(read_decimal);
extern void read_user_defined (st_parameter_dt *, void *);
internal_proto(read_user_defined);
extern void read_user_defined (st_parameter_dt *, void *);
internal_proto(read_user_defined);
/* list_read.c */
extern void list_formatted_read (st_parameter_dt *, bt, void *, int, size_t,
@ -790,6 +832,12 @@ internal_proto(write_x);
extern void write_z (st_parameter_dt *, const fnode *, const char *, int);
internal_proto(write_z);
extern void write_user_defined (st_parameter_dt *, void *);
internal_proto(write_user_defined);
extern void write_user_defined (st_parameter_dt *, void *);
internal_proto(write_user_defined);
extern void list_formatted_write (st_parameter_dt *, bt, void *, int, size_t,
size_t);
internal_proto(list_formatted_write);

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)
{
// Plain malloc should suffice here, zeroing not needed?
/* Plain malloc should suffice here, zeroing not needed? */
dtp->u.p.saved_string = xcalloc (SCRATCH_SIZE, 1);
dtp->u.p.saved_length = SCRATCH_SIZE;
dtp->u.p.saved_used = 0;
@ -170,11 +170,11 @@ check_buffers (st_parameter_dt *dtp)
int c;
c = '\0';
if (dtp->u.p.last_char != EOF - 1)
if (dtp->u.p.current_unit->last_char != EOF - 1)
{
dtp->u.p.at_eol = 0;
c = dtp->u.p.last_char;
dtp->u.p.last_char = EOF - 1;
c = dtp->u.p.current_unit->last_char;
dtp->u.p.current_unit->last_char = EOF - 1;
goto done;
}
@ -369,7 +369,7 @@ utf_done:
static void
unget_char (st_parameter_dt *dtp, int c)
{
dtp->u.p.last_char = c;
dtp->u.p.current_unit->last_char = c;
}
@ -385,7 +385,7 @@ eat_spaces (st_parameter_dt *dtp)
This is an optimization unique to character arrays with large
character lengths (PR38199). This code eliminates numerous calls
to next_character. */
if (is_array_io (dtp) && (dtp->u.p.last_char == EOF - 1))
if (is_array_io (dtp) && (dtp->u.p.current_unit->last_char == EOF - 1))
{
gfc_offset offset = stell (dtp->u.p.current_unit->s);
gfc_offset i;
@ -2167,6 +2167,46 @@ list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p,
if (dtp->u.p.repeat_count > 0)
memcpy (dtp->u.p.value, p, size);
break;
case BT_CLASS:
{
int unit = dtp->u.p.current_unit->unit_number;
char iotype[] = "LISTDIRECTED";
gfc_charlen_type iotype_len = 12;
char tmp_iomsg[IOMSG_LEN] = "";
char *child_iomsg;
gfc_charlen_type child_iomsg_len;
int noiostat;
int *child_iostat = NULL;
gfc_array_i4 vlist;
GFC_DESCRIPTOR_DATA(&vlist) = NULL;
GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
/* Set iostat, intent(out). */
noiostat = 0;
child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
dtp->common.iostat : &noiostat;
/* Set iomsge, intent(inout). */
if (dtp->common.flags & IOPARM_HAS_IOMSG)
{
child_iomsg = dtp->common.iomsg;
child_iomsg_len = dtp->common.iomsg_len;
}
else
{
child_iomsg = tmp_iomsg;
child_iomsg_len = IOMSG_LEN;
}
/* Call the user defined formatted READ procedure. */
dtp->u.p.current_unit->child_dtio++;
dtp->u.p.fdtio_ptr (p, &unit, iotype, &vlist,
child_iostat, child_iomsg,
iotype_len, child_iomsg_len);
dtp->u.p.current_unit->child_dtio--;
}
break;
default:
internal_error (&dtp->common, "Bad type for list read");
}
@ -3206,6 +3246,53 @@ get_name:
goto nml_err_ret;
}
else if (nl->dtio_sub != NULL)
{
int unit = dtp->u.p.current_unit->unit_number;
char iotype[] = "NAMELIST";
gfc_charlen_type iotype_len = 8;
char tmp_iomsg[IOMSG_LEN] = "";
char *child_iomsg;
gfc_charlen_type child_iomsg_len;
int noiostat;
int *child_iostat = NULL;
gfc_array_i4 vlist;
gfc_class list_obj;
formatted_dtio dtio_ptr = (formatted_dtio)nl->dtio_sub;
GFC_DESCRIPTOR_DATA(&vlist) = NULL;
GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
list_obj.data = (void *)nl->mem_pos;
list_obj.vptr = nl->vtable;
list_obj.len = 0;
/* Set iostat, intent(out). */
noiostat = 0;
child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
dtp->common.iostat : &noiostat;
/* Set iomsg, intent(inout). */
if (dtp->common.flags & IOPARM_HAS_IOMSG)
{
child_iomsg = dtp->common.iomsg;
child_iomsg_len = dtp->common.iomsg_len;
}
else
{
child_iomsg = tmp_iomsg;
child_iomsg_len = IOMSG_LEN;
}
/* Call the user defined formatted READ procedure. */
dtp->u.p.current_unit->child_dtio++;
dtio_ptr ((void *)&list_obj, &unit, iotype, &vlist,
child_iostat, child_iomsg,
iotype_len, child_iomsg_len);
dtp->u.p.current_unit->child_dtio--;
return true;
}
/* Get the length, data length, base pointer and rank of the variable.
Set the default loop specification first. */

457
libgfortran/io/transfer.c
View File

@ -57,7 +57,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
transfer_complex
transfer_real128
transfer_complex128
and for WRITE
transfer_integer_write
@ -122,6 +122,15 @@ extern void transfer_array_write (st_parameter_dt *, gfc_array_char *, int,
gfc_charlen_type);
export_proto(transfer_array_write);
/* User defined derived type input/output. */
extern void
transfer_derived (st_parameter_dt *dtp, void *dtio_source, void *dtio_proc);
export_proto(transfer_derived);
extern void
transfer_derived_write (st_parameter_dt *dtp, void *dtio_source, void *dtio_proc);
export_proto(transfer_derived_write);
static void us_read (st_parameter_dt *, int);
static void us_write (st_parameter_dt *, int);
static void next_record_r_unf (st_parameter_dt *, int);
@ -315,7 +324,7 @@ read_sf (st_parameter_dt *dtp, int * length)
the rest of the I/O statement. Set the corresponding flag. */
if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
dtp->u.p.eor_condition = 1;
/* If we encounter a CR, it might be a CRLF. */
if (q == '\r') /* Probably a CRLF */
{
@ -548,7 +557,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t nbytes)
if (is_stream_io (dtp))
{
have_read_record = sread (dtp->u.p.current_unit->s, buf,
have_read_record = sread (dtp->u.p.current_unit->s, buf,
nbytes);
if (unlikely (have_read_record < 0))
{
@ -556,7 +565,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t nbytes)
return;
}
dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record;
dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record;
if (unlikely ((ssize_t) nbytes != have_read_record))
{
@ -590,7 +599,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t nbytes)
return;
}
if (to_read_record != (ssize_t) nbytes)
if (to_read_record != (ssize_t) nbytes)
{
/* Short read, e.g. if we hit EOF. Apparently, we read
more than was written to the last record. */
@ -639,7 +648,7 @@ read_block_direct (st_parameter_dt *dtp, void *buf, size_t nbytes)
dtp->u.p.current_unit->bytes_left_subrecord -= to_read_subrecord;
have_read_subrecord = sread (dtp->u.p.current_unit->s,
have_read_subrecord = sread (dtp->u.p.current_unit->s,
buf + have_read_record, to_read_subrecord);
if (unlikely (have_read_subrecord < 0))
{
@ -760,7 +769,7 @@ write_block (st_parameter_dt *dtp, int length)
return NULL;
}
}
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
dtp->u.p.size_used += (GFC_IO_INT) length;
@ -793,7 +802,7 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
return false;
}
dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written;
dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written;
return true;
}
@ -811,7 +820,7 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
if (buf == NULL && nbytes == 0)
return true;
have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes);
have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes);
if (unlikely (have_written < 0))
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
@ -849,7 +858,7 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
dtp->u.p.current_unit->bytes_left_subrecord -=
(gfc_offset) to_write_subrecord;
to_write_subrecord = swrite (dtp->u.p.current_unit->s,
to_write_subrecord = swrite (dtp->u.p.current_unit->s,
buf + have_written, to_write_subrecord);
if (unlikely (to_write_subrecord < 0))
{
@ -857,7 +866,7 @@ write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
return false;
}
dtp->u.p.current_unit->strm_pos += (gfc_offset) to_write_subrecord;
dtp->u.p.current_unit->strm_pos += (gfc_offset) to_write_subrecord;
nbytes -= to_write_subrecord;
have_written += to_write_subrecord;
@ -903,7 +912,7 @@ reverse_memcpy (void *dest, const void *src, size_t n)
static void
bswap_array (void *dest, const void *src, size_t size, size_t nelems)
{
const char *ps;
const char *ps;
char *pd;
switch (size)
@ -988,6 +997,40 @@ static void
unformatted_read (st_parameter_dt *dtp, bt type,
void *dest, int kind, size_t size, size_t nelems)
{
if (type == BT_CLASS)
{
int unit = dtp->u.p.current_unit->unit_number;
char tmp_iomsg[IOMSG_LEN] = "";
char *child_iomsg;
gfc_charlen_type child_iomsg_len;
int noiostat;
int *child_iostat = NULL;
/* Set iostat, intent(out). */
noiostat = 0;
child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
dtp->common.iostat : &noiostat;
/* Set iomsg, intent(inout). */
if (dtp->common.flags & IOPARM_HAS_IOMSG)
{
child_iomsg = dtp->common.iomsg;
child_iomsg_len = dtp->common.iomsg_len;
}
else
{
child_iomsg = tmp_iomsg;
child_iomsg_len = IOMSG_LEN;
}
/* Call the user defined unformatted READ procedure. */
dtp->u.p.current_unit->child_dtio++;
dtp->u.p.ufdtio_ptr (dest, &unit, child_iostat, child_iomsg,
child_iomsg_len);
dtp->u.p.current_unit->child_dtio--;
return;
}
if (type == BT_CHARACTER)
size *= GFC_SIZE_OF_CHAR_KIND(kind);
read_block_direct (dtp, dest, size * nelems);
@ -1016,13 +1059,47 @@ unformatted_read (st_parameter_dt *dtp, bt type,
/* Master function for unformatted writes. NOTE: For kind=10 the size is 16
bytes on 64 bit machines. The unused bytes are not initialized and never
used, which can show an error with memory checking analyzers like
valgrind. */
valgrind. We us BT_CLASS to denote a User Defined I/O call. */
static void
unformatted_write (st_parameter_dt *dtp, bt type,
void *source, int kind, size_t size, size_t nelems)
{
if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
if (type == BT_CLASS)
{
int unit = dtp->u.p.current_unit->unit_number;
char tmp_iomsg[IOMSG_LEN] = "";
char *child_iomsg;
gfc_charlen_type child_iomsg_len;
int noiostat;
int *child_iostat = NULL;
/* Set iostat, intent(out). */
noiostat = 0;
child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
dtp->common.iostat : &noiostat;
/* Set iomsg, intent(inout). */
if (dtp->common.flags & IOPARM_HAS_IOMSG)
{
child_iomsg = dtp->common.iomsg;
child_iomsg_len = dtp->common.iomsg_len;
}
else
{
child_iomsg = tmp_iomsg;
child_iomsg_len = IOMSG_LEN;
}
/* Call the user defined unformatted WRITE procedure. */
dtp->u.p.current_unit->child_dtio++;
dtp->u.p.ufdtio_ptr (source, &unit, child_iostat, child_iomsg,
child_iomsg_len);
dtp->u.p.current_unit->child_dtio--;
return;
}
if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
|| kind == 1)
{
size_t stride = type == BT_CHARACTER ?
@ -1045,13 +1122,13 @@ unformatted_write (st_parameter_dt *dtp, bt type,
nelems *= size;
size = kind;
}
/* Break up complex into its constituent reals. */
if (type == BT_COMPLEX)
{
nelems *= 2;
size /= 2;
}
}
/* By now, all complex variables have been split into their
constituent reals. */
@ -1099,6 +1176,9 @@ type_name (bt type)
case BT_COMPLEX:
p = "COMPLEX";
break;
case BT_CLASS:
p = "CLASS or DERIVED";
break;
default:
internal_error (NULL, "type_name(): Bad type");
}
@ -1115,7 +1195,7 @@ static void
write_constant_string (st_parameter_dt *dtp, const fnode *f)
{
char c, delimiter, *p, *q;
int length;
int length;
length = f->u.string.length;
if (length == 0)
@ -1124,7 +1204,7 @@ write_constant_string (st_parameter_dt *dtp, const fnode *f)
p = write_block (dtp, length);
if (p == NULL)
return;
q = f->u.string.p;
delimiter = q[-1];
@ -1151,7 +1231,7 @@ require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
return 0;
/* Adjust item_count before emitting error message. */
snprintf (buffer, BUFLEN,
snprintf (buffer, BUFLEN,
"Expected %s for item %d in formatted transfer, got %s",
type_name (expected), dtp->u.p.item_count - 1, type_name (actual));
@ -1170,7 +1250,7 @@ require_numeric_type (st_parameter_dt *dtp, bt actual, const fnode *f)
return 0;
/* Adjust item_count before emitting error message. */
snprintf (buffer, BUFLEN,
snprintf (buffer, BUFLEN,
"Expected numeric type for item %d in formatted transfer, got %s",
dtp->u.p.item_count - 1, type_name (actual));
@ -1273,7 +1353,7 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind
case FMT_O:
if (n == 0)
goto need_read_data;
goto need_read_data;
if (!(compile_options.allow_std & GFC_STD_GNU)
&& require_numeric_type (dtp, type, f))
return;
@ -1322,6 +1402,65 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind
read_f (dtp, f, p, kind);
break;
case FMT_DT:
if (n == 0)
goto need_read_data;
if (require_type (dtp, BT_CLASS, type, f))
return;
int unit = dtp->u.p.current_unit->unit_number;
char dt[] = "DT";
char tmp_iomsg[IOMSG_LEN] = "";
char *child_iomsg;
gfc_charlen_type child_iomsg_len;
int noiostat;
int *child_iostat = NULL;
char *iotype = f->u.udf.string;
gfc_charlen_type iotype_len = f->u.udf.string_len;
/* Build the iotype string. */
if (iotype_len == 0)
{
iotype_len = 2;
iotype = dt;
}
else
{
iotype_len += 2;
iotype = xmalloc (iotype_len);
iotype[0] = dt[0];
iotype[1] = dt[1];
memcpy (iotype + 2, f->u.udf.string, f->u.udf.string_len);
}
/* Set iostat, intent(out). */
noiostat = 0;
child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
dtp->common.iostat : &noiostat;
/* Set iomsg, intent(inout). */
if (dtp->common.flags & IOPARM_HAS_IOMSG)
{
child_iomsg = dtp->common.iomsg;
child_iomsg_len = dtp->common.iomsg_len;
}
else
{
child_iomsg = tmp_iomsg;
child_iomsg_len = IOMSG_LEN;
}
/* Call the user defined formatted READ procedure. */
dtp->u.p.current_unit->child_dtio++;
dtp->u.p.fdtio_ptr (p, &unit, iotype, f->u.udf.vlist,
child_iostat, child_iomsg,
iotype_len, child_iomsg_len);
dtp->u.p.current_unit->child_dtio--;
if (f->u.udf.string_len != 0)
free (iotype);
/* Note: vlist is freed in free_format_data. */
break;
case FMT_E:
if (n == 0)
goto need_read_data;
@ -1438,7 +1577,7 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind
}
if (dtp->u.p.skips < 0)
{
if (is_internal_unit (dtp))
if (is_internal_unit (dtp))
sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR);
else
fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
@ -1624,13 +1763,14 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
/* Now discharge T, TR and X movements to the right. This is delayed
until a data producing format to suppress trailing spaces. */
t = f->format;
if (dtp->u.p.mode == WRITING && dtp->u.p.skips != 0
&& ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O
|| t == FMT_Z || t == FMT_F || t == FMT_E
|| t == FMT_EN || t == FMT_ES || t == FMT_G
|| t == FMT_L || t == FMT_A || t == FMT_D))
|| t == FMT_L || t == FMT_A || t == FMT_D
|| t == FMT_DT))
|| t == FMT_STRING))
{
if (dtp->u.p.skips > 0)
@ -1639,13 +1779,13 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
tmp = (int)(dtp->u.p.current_unit->recl
- dtp->u.p.current_unit->bytes_left);
dtp->u.p.max_pos =
dtp->u.p.max_pos =
dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp;
dtp->u.p.skips = 0;
}
if (dtp->u.p.skips < 0)
{
if (is_internal_unit (dtp))
if (is_internal_unit (dtp))
sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR);
else
fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
@ -1684,7 +1824,7 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
case FMT_O:
if (n == 0)
goto need_data;
goto need_data;
if (!(compile_options.allow_std & GFC_STD_GNU)
&& require_numeric_type (dtp, type, f))
return;
@ -1733,6 +1873,63 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin
write_d (dtp, f, p, kind);
break;
case FMT_DT:
if (n == 0)
goto need_data;
int unit = dtp->u.p.current_unit->unit_number;
char dt[] = "DT";
char tmp_iomsg[IOMSG_LEN] = "";
char *child_iomsg;
gfc_charlen_type child_iomsg_len;
int noiostat;
int *child_iostat = NULL;
char *iotype = f->u.udf.string;
gfc_charlen_type iotype_len = f->u.udf.string_len;
/* Build the iotype string. */
if (iotype_len == 0)
{
iotype_len = 2;
iotype = dt;
}
else
{
iotype_len += 2;
iotype = xmalloc (iotype_len);
iotype[0] = dt[0];
iotype[1] = dt[1];
memcpy (iotype + 2, f->u.udf.string, f->u.udf.string_len);
}
/* Set iostat, intent(out). */
noiostat = 0;
child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
dtp->common.iostat : &noiostat;
/* Set iomsg, intent(inout). */
if (dtp->common.flags & IOPARM_HAS_IOMSG)
{
child_iomsg = dtp->common.iomsg;
child_iomsg_len = dtp->common.iomsg_len;
}
else
{
child_iomsg = tmp_iomsg;
child_iomsg_len = IOMSG_LEN;
}
/* Call the user defined formatted WRITE procedure. */
dtp->u.p.current_unit->child_dtio++;
dtp->u.p.fdtio_ptr (p, &unit, iotype, f->u.udf.vlist,
child_iostat, child_iomsg,
iotype_len, child_iomsg_len);
dtp->u.p.current_unit->child_dtio--;
if (f->u.udf.string_len != 0)
free (iotype);
/* Note: vlist is freed in free_format_data. */
break;
case FMT_E:
if (n == 0)
goto need_data;
@ -2198,6 +2395,25 @@ transfer_array_write (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
transfer_array (dtp, desc, kind, charlen);
}
/* User defined input/output iomsg. */
#define IOMSG_LEN 256
void
transfer_derived (st_parameter_dt *parent, void *dtio_source, void *dtio_proc)
{
if (parent->u.p.current_unit)
{
if (parent->u.p.current_unit->flags.form == FORM_UNFORMATTED)
parent->u.p.ufdtio_ptr = (unformatted_dtio) dtio_proc;
else
parent->u.p.fdtio_ptr = (formatted_dtio) dtio_proc;
}
parent->u.p.transfer (parent, BT_CLASS, dtio_source, 0, 0, 1);
}
/* Preposition a sequential unformatted file while reading. */
static void
@ -2340,7 +2556,7 @@ pre_position (st_parameter_dt *dtp)
was specified, we continue from where we last left off. I.e.
there is nothing to do here. */
break;
case UNFORMATTED_SEQUENTIAL:
if (dtp->u.p.mode == READING)
us_read (dtp, 0);
@ -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.current_unit = get_unit (dtp, 1);
if (dtp->u.p.current_unit->s == NULL)
{ /* Open the unit with some default flags. */
st_parameter_open opp;
@ -2431,15 +2648,15 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
case GFC_CONVERT_NATIVE:
case GFC_CONVERT_SWAP:
break;
case GFC_CONVERT_BIG:
conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
break;
case GFC_CONVERT_LITTLE:
conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
break;
default:
internal_error (&opp.common, "Illegal value for CONVERT");
break;
@ -2542,7 +2759,6 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
"EOF marker, possibly use REWIND or BACKSPACE");
return;
}
}
/* Process the ADVANCE option. */
@ -2589,7 +2805,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
return;
}
if ((cf & IOPARM_DT_HAS_SIZE) != 0
if ((cf & IOPARM_DT_HAS_SIZE) != 0
&& dtp->u.p.advance_status != ADVANCE_NO)
{
generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
@ -2653,7 +2869,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
= !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED :
find_option (&dtp->common, dtp->sign, dtp->sign_len, sign_opt,
"Bad SIGN parameter in data transfer statement");
if (dtp->u.p.sign_status == SIGN_UNSPECIFIED)
dtp->u.p.sign_status = dtp->u.p.current_unit->flags.sign;
@ -2663,7 +2879,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
find_option (&dtp->common, dtp->blank, dtp->blank_len,
blank_opt,
"Bad BLANK parameter in data transfer statement");
if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
@ -2703,28 +2919,28 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
/* Check the POS= specifier: that it is in range and that it is used with a
unit that has been connected for STREAM access. F2003 9.5.1.10. */
if (((cf & IOPARM_DT_HAS_POS) != 0))
{
if (is_stream_io (dtp))
{
if (dtp->pos <= 0)
{
generate_error (&dtp->common, LIBERROR_BAD_OPTION,
"POS=specifier must be positive");
return;
}
if (dtp->pos >= dtp->u.p.current_unit->maxrec)
{
generate_error (&dtp->common, LIBERROR_BAD_OPTION,
"POS=specifier too large");
return;
}
dtp->rec = dtp->pos;
if (dtp->u.p.mode == READING)
{
/* Reset the endfile flag; if we hit EOF during reading
@ -2732,7 +2948,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
rather than worrying about it here. */
dtp->u.p.current_unit->endfile = NO_ENDFILE;
}
if (dtp->pos != dtp->u.p.current_unit->strm_pos)
{
fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
@ -2752,7 +2968,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
return;
}
}
/* Sanity checks on the record number. */
if ((cf & IOPARM_DT_HAS_REC) != 0)
@ -2789,11 +3005,11 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
/* Position the file. */
if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
* dtp->u.p.current_unit->recl, SEEK_SET) < 0)
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return;
}
* dtp->u.p.current_unit->recl, SEEK_SET) < 0)
{
generate_error (&dtp->common, LIBERROR_OS, NULL);
return;
}
/* TODO: This is required to maintain compatibility between
4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */
@ -2822,7 +3038,7 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
dtp->u.p.max_pos = dtp->u.p.current_unit->saved_pos;
pre_position (dtp);
/* Set up the subroutine that will handle the transfers. */
@ -2834,8 +3050,9 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
{
if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
{
dtp->u.p.last_char = EOF - 1;
dtp->u.p.transfer = list_formatted_read;
if (dtp->u.p.current_unit->child_dtio == 0)
dtp->u.p.current_unit->last_char = EOF - 1;
dtp->u.p.transfer = list_formatted_read;
}
else
dtp->u.p.transfer = formatted_transfer;
@ -2896,14 +3113,14 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
returns the index of the last element of the array, and also returns
starting record, where the first I/O goes to (necessary in case of
negative strides). */
gfc_offset
init_loop_spec (gfc_array_char *desc, array_loop_spec *ls,
gfc_offset *start_record)
{
int rank = GFC_DESCRIPTOR_RANK(desc);
int i;
gfc_offset index;
gfc_offset index;
int empty;
empty = 0;
@ -2916,7 +3133,7 @@ init_loop_spec (gfc_array_char *desc, array_loop_spec *ls,
ls[i].start = GFC_DESCRIPTOR_LBOUND(desc,i);
ls[i].end = GFC_DESCRIPTOR_UBOUND(desc,i);
ls[i].step = GFC_DESCRIPTOR_STRIDE(desc,i);
empty = empty || (GFC_DESCRIPTOR_UBOUND(desc,i)
empty = empty || (GFC_DESCRIPTOR_UBOUND(desc,i)
< GFC_DESCRIPTOR_LBOUND(desc,i));
if (GFC_DESCRIPTOR_STRIDE(desc,i) > 0)
@ -2941,13 +3158,13 @@ init_loop_spec (gfc_array_char *desc, array_loop_spec *ls,
/* Determine the index to the next record in an internal unit array by
by incrementing through the array_loop_spec. */
gfc_offset
next_array_record (st_parameter_dt *dtp, array_loop_spec *ls, int *finished)
{
int i, carry;
gfc_offset index;
carry = 1;
index = 0;
@ -2992,13 +3209,13 @@ skip_record (st_parameter_dt *dtp, ssize_t bytes)
/* Direct access files do not generate END conditions,
only I/O errors. */
if (sseek (dtp->u.p.current_unit->s,
if (sseek (dtp->u.p.current_unit->s,
dtp->u.p.current_unit->bytes_left_subrecord, SEEK_CUR) < 0)
{
/* Seeking failed, fall back to seeking by reading data. */
while (dtp->u.p.current_unit->bytes_left_subrecord > 0)
{
rlength =
rlength =
(MAX_READ < dtp->u.p.current_unit->bytes_left_subrecord) ?
MAX_READ : dtp->u.p.current_unit->bytes_left_subrecord;
@ -3066,7 +3283,7 @@ next_record_r (st_parameter_dt *dtp, int done)
/* No records in unformatted STREAM I/O. */
case UNFORMATTED_STREAM:
return;
case UNFORMATTED_SEQUENTIAL:
next_record_r_unf (dtp, 1);
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
@ -3107,13 +3324,13 @@ next_record_r (st_parameter_dt *dtp, int done)
}
dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
}
else
else
{
bytes_left = (int) dtp->u.p.current_unit->bytes_left;
bytes_left = min_off (bytes_left,
bytes_left = min_off (bytes_left,
ssize (dtp->u.p.current_unit->s)
- stell (dtp->u.p.current_unit->s));
if (sseek (dtp->u.p.current_unit->s,
if (sseek (dtp->u.p.current_unit->s,
bytes_left, SEEK_CUR) < 0)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
@ -3121,16 +3338,16 @@ next_record_r (st_parameter_dt *dtp, int done)
}
dtp->u.p.current_unit->bytes_left
= dtp->u.p.current_unit->recl;
}
}
break;
}
else
else
{
do
{
errno = 0;
cc = fbuf_getc (dtp->u.p.current_unit);
if (cc == EOF)
if (cc == EOF)
{
if (errno != 0)
generate_error (&dtp->common, LIBERROR_OS, NULL);
@ -3144,10 +3361,10 @@ next_record_r (st_parameter_dt *dtp, int done)
}
break;
}
if (is_stream_io (dtp))
dtp->u.p.current_unit->strm_pos++;
p = (char) cc;
}
while (p != '\n');
@ -3240,7 +3457,7 @@ next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
/* Seek to the head and overwrite the bogus length with the real
length. */
if (unlikely (sseek (dtp->u.p.current_unit->s, - m - record_marker,
if (unlikely (sseek (dtp->u.p.current_unit->s, - m - record_marker,
SEEK_CUR) < 0))
goto io_error;
@ -3301,7 +3518,7 @@ sset (stream * s, int c, ssize_t nbyte)
return trans;
bytes_left -= trans;
}
return nbyte - bytes_left;
}
@ -3330,8 +3547,8 @@ next_record_w (st_parameter_dt *dtp, int done)
fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
fbuf_flush (dtp->u.p.current_unit, WRITING);
if (sset (dtp->u.p.current_unit->s, ' ',
dtp->u.p.current_unit->bytes_left)
if (sset (dtp->u.p.current_unit->s, ' ',
dtp->u.p.current_unit->bytes_left)
!= dtp->u.p.current_unit->bytes_left)
goto io_error;
@ -3362,7 +3579,7 @@ next_record_w (st_parameter_dt *dtp, int done)
int finished;
length = (int) dtp->u.p.current_unit->bytes_left;
/* If the farthest position reached is greater than current
position, adjust the position and set length to pad out
whats left. Otherwise just pad whats left.
@ -3372,7 +3589,7 @@ next_record_w (st_parameter_dt *dtp, int done)
if (max_pos > m)
{
length = (int) (max_pos - m);
if (sseek (dtp->u.p.current_unit->s,
if (sseek (dtp->u.p.current_unit->s,
length, SEEK_CUR) < 0)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
@ -3399,7 +3616,7 @@ next_record_w (st_parameter_dt *dtp, int done)
&finished);
if (finished)
dtp->u.p.current_unit->endfile = AT_ENDFILE;
/* Now seek to this record */
record = record * dtp->u.p.current_unit->recl;
@ -3425,7 +3642,7 @@ next_record_w (st_parameter_dt *dtp, int done)
if (max_pos > m)
{
length = (int) (max_pos - m);
if (sseek (dtp->u.p.current_unit->s,
if (sseek (dtp->u.p.current_unit->s,
length, SEEK_CUR) < 0)
{
generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
@ -3540,6 +3757,18 @@ finalize_transfer (st_parameter_dt *dtp)
{
GFC_INTEGER_4 cf = dtp->common.flags;
if ((dtp->u.p.ionml != NULL)
&& (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
{
if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
namelist_read (dtp);
else
namelist_write (dtp);
}
if (dtp->u.p.current_unit && (dtp->u.p.current_unit->child_dtio > 0))
return;
if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
*dtp->size = dtp->u.p.size_used;
@ -3556,15 +3785,6 @@ finalize_transfer (st_parameter_dt *dtp)
goto done;
}
if ((dtp->u.p.ionml != NULL)
&& (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
{
if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
namelist_read (dtp);
else
namelist_write (dtp);
}
dtp->u.p.transfer = NULL;
if (dtp->u.p.current_unit == NULL)
goto done;
@ -3607,7 +3827,7 @@ finalize_transfer (st_parameter_dt *dtp)
write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
tmp = (int)(dtp->u.p.current_unit->recl
- dtp->u.p.current_unit->bytes_left);
dtp->u.p.max_pos =
dtp->u.p.max_pos =
dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp;
dtp->u.p.skips = 0;
}
@ -3618,9 +3838,9 @@ finalize_transfer (st_parameter_dt *dtp)
fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
goto done;
}
else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
&& dtp->u.p.mode == WRITING && !is_internal_unit (dtp))
fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
dtp->u.p.current_unit->saved_pos = 0;
@ -3648,9 +3868,9 @@ finalize_transfer (st_parameter_dt *dtp)
data transfer, it just updates the length counter. */
static void
iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)),
iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)),
void *dest __attribute__ ((unused)),
int kind __attribute__((unused)),
int kind __attribute__((unused)),
size_t size, size_t nelems)
{
if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
@ -3722,7 +3942,7 @@ void
st_read_done (st_parameter_dt *dtp)
{
finalize_transfer (dtp);
if (is_internal_unit (dtp) || dtp->u.p.format_not_saved)
{
free_format_data (dtp->u.p.fmt);
@ -3735,7 +3955,7 @@ st_read_done (st_parameter_dt *dtp)
unlock_unit (dtp->u.p.current_unit);
free_internal_unit (dtp);
library_end ();
}
@ -3759,8 +3979,9 @@ st_write_done (st_parameter_dt *dtp)
/* Deal with endfile conditions associated with sequential files. */
if (dtp->u.p.current_unit != NULL
&& dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
if (dtp->u.p.current_unit != NULL
&& dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
&& dtp->u.p.current_unit->child_dtio == 0)
switch (dtp->u.p.current_unit->endfile)
{
case AT_ENDFILE: /* Remain at the endfile record. */
@ -3773,7 +3994,7 @@ st_write_done (st_parameter_dt *dtp)
case NO_ENDFILE:
/* Get rid of whatever is after this record. */
if (!is_internal_unit (dtp))
unit_truncate (dtp->u.p.current_unit,
unit_truncate (dtp->u.p.current_unit,
stell (dtp->u.p.current_unit->s),
&dtp->common);
dtp->u.p.current_unit->endfile = AT_ENDFILE;
@ -3790,7 +4011,7 @@ st_write_done (st_parameter_dt *dtp)
if (dtp->u.p.current_unit != NULL)
unlock_unit (dtp->u.p.current_unit);
free_internal_unit (dtp);
library_end ();
@ -3807,15 +4028,10 @@ st_wait (st_parameter_wait *wtp __attribute__((unused)))
/* Receives the scalar information for namelist objects and stores it
in a linked list of namelist_info types. */
extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
export_proto(st_set_nml_var);
void
st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
GFC_INTEGER_4 len, gfc_charlen_type string_length,
GFC_INTEGER_4 dtype)
static void
set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
GFC_INTEGER_4 len, gfc_charlen_type string_length,
GFC_INTEGER_4 dtype, void *dtio_sub, void *vtable)
{
namelist_info *t1 = NULL;
namelist_info *nml;
@ -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->mem_pos = var_addr;
nml->dtio_sub = dtio_sub;
nml->vtable = vtable;
nml->var_name = (char*) xmalloc (var_name_len + 1);
memcpy (nml->var_name, var_name, var_name_len);
@ -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. */
extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
index_type, index_type,
@ -3911,7 +4160,7 @@ hit_eof (st_parameter_dt * dtp)
else
dtp->u.p.current_unit->endfile = AT_ENDFILE;
break;
case AFTER_ENDFILE:
generate_error (&dtp->common, LIBERROR_ENDFILE, NULL);
dtp->u.p.current_unit->current_record = 0;

32
libgfortran/io/unit.c
View File

@ -348,7 +348,7 @@ retry:
}
found:
if (p != NULL)
if (p != NULL && (p->child_dtio == 0))
{
/* Fast path. */
if (! __gthread_mutex_trylock (&p->lock))
@ -363,7 +363,7 @@ found:
__gthread_mutex_unlock (&unit_lock);
if (p != NULL)
if (p != NULL && (p->child_dtio == 0))
{
__gthread_mutex_lock (&p->lock);
if (p->closed)
@ -464,7 +464,7 @@ get_internal_unit (st_parameter_dt *dtp)
else
len = string_len_trim_char4 (dtp->internal_unit_len,
(const gfc_char4_t*) dtp->internal_unit);
dtp->internal_unit_len = len;
dtp->internal_unit_len = len;
iunit->recl = dtp->internal_unit_len;
}
@ -524,7 +524,7 @@ get_internal_unit (st_parameter_dt *dtp)
dtp->u.p.at_eof = 0;
/* This flag tells us the unit is assigned to internal I/O. */
dtp->u.p.unit_is_internal = 1;
return iunit;
@ -544,13 +544,13 @@ free_internal_unit (st_parameter_dt *dtp)
if (dtp->u.p.current_unit != NULL)
{
free (dtp->u.p.current_unit->ls);
free (dtp->u.p.current_unit->s);
destroy_unit_mutex (dtp->u.p.current_unit);
}
}
/* get_unit()-- Returns the unit structure associated with the integer
@ -612,14 +612,14 @@ init_units (void)
u->flags.encoding = ENCODING_DEFAULT;
u->flags.async = ASYNC_NO;
u->flags.round = ROUND_UNSPECIFIED;
u->recl = options.default_recl;
u->endfile = NO_ENDFILE;
u->filename = strdup (stdin_name);
fbuf_init (u, 0);
__gthread_mutex_unlock (&u->lock);
}
@ -644,9 +644,9 @@ init_units (void)
u->recl = options.default_recl;
u->endfile = AT_ENDFILE;
u->filename = strdup (stdout_name);
fbuf_init (u, 0);
__gthread_mutex_unlock (&u->lock);
@ -674,7 +674,7 @@ init_units (void)
u->endfile = AT_ENDFILE;
u->filename = strdup (stderr_name);
fbuf_init (u, 256); /* 256 bytes should be enough, probably not doing
any kind of exotic formatting to stderr. */
@ -694,7 +694,7 @@ static int
close_unit_1 (gfc_unit *u, int locked)
{
int i, rc;
/* If there are previously written bytes from a write with ADVANCE="no"
Reposition the buffer before closing. */
if (u->previous_nonadvancing_write)
@ -715,7 +715,7 @@ close_unit_1 (gfc_unit *u, int locked)
free (u->filename);
u->filename = NULL;
free_format_hash_table (u);
free_format_hash_table (u);
fbuf_destroy (u);
if (!locked)
@ -788,7 +788,7 @@ unit_truncate (gfc_unit * u, gfc_offset pos, st_parameter_common * common)
else
fbuf_flush (u, u->mode);
}
/* struncate() should flush the stream buffer if necessary, so don't
bother calling sflush() here. */
ret = struncate (u->s, pos);
@ -838,7 +838,7 @@ filename_from_unit (int n)
void
finish_last_advance_record (gfc_unit *u)
{
if (u->saved_pos > 0)
fbuf_seek (u, u->saved_pos, SEEK_CUR);

2
libgfortran/io/unix.c
View File

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

158
libgfortran/io/write.c
View File

@ -44,7 +44,7 @@ static void
memcpy4 (gfc_char4_t *dest, const char *source, int k)
{
int j;
const char *p = source;
for (j = 0; j < k; j++)
*dest++ = (gfc_char4_t) *p++;
@ -63,7 +63,7 @@ write_default_char4 (st_parameter_dt *dtp, const gfc_char4_t *source,
int j, k = 0;
gfc_char4_t c;
uchar d;
/* Take care of preceding blanks. */
if (w_len > src_len)
{
@ -153,7 +153,7 @@ write_utf8_char4 (st_parameter_dt *dtp, gfc_char4_t *source,
static const uchar masks[6] = { 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC };
static const uchar limits[6] = { 0x80, 0xE0, 0xF0, 0xF8, 0xFC, 0xFE };
int nbytes;
uchar buf[6], d, *q;
uchar buf[6], d, *q;
/* Take care of preceding blanks. */
if (w_len > src_len)
@ -273,7 +273,7 @@ write_a (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
bytes = 0;
}
/* Write out the CR_LF sequence. */
/* Write out the CR_LF sequence. */
q++;
p = write_block (dtp, 2);
if (p == NULL)
@ -381,7 +381,7 @@ write_a_char4 (st_parameter_dt *dtp, const fnode *f, const char *source, int len
bytes = 0;
}
/* Write out the CR_LF sequence. */
/* Write out the CR_LF sequence. */
write_default_char4 (dtp, crlf, 2, 0);
}
else
@ -528,7 +528,7 @@ write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
GFC_INTEGER_LARGEST n;
wlen = (f->format == FMT_G && f->u.w == 0) ? 1 : f->u.w;
p = write_block (dtp, wlen);
if (p == NULL)
return;
@ -694,7 +694,7 @@ write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
if (n < 0)
n = -n;
nsign = sign == S_NONE ? 0 : 1;
/* conv calls itoa which sets the negative sign needed
by write_integer. The sign '+' or '-' is set below based on sign
calculated above, so we just point past the sign in the string
@ -847,7 +847,7 @@ btoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
{
char *q;
int i, j;
q = buffer;
if (big_endian)
{
@ -893,7 +893,7 @@ btoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
if (*n == 0)
return "0";
/* Move past any leading zeros. */
/* Move past any leading zeros. */
while (*buffer == '0')
buffer++;
@ -968,7 +968,7 @@ otoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
if (*n == 0)
return "0";
/* Move past any leading zeros. */
/* Move past any leading zeros. */
while (*q == '0')
q++;
@ -986,9 +986,9 @@ ztoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
char *q;
uint8_t h, l;
int i;
q = buffer;
if (big_endian)
{
const char *p = s;
@ -1021,11 +1021,11 @@ ztoa_big (const char *s, char *buffer, int len, GFC_UINTEGER_LARGEST *n)
}
*q = '\0';
if (*n == 0)
return "0";
/* Move past any leading zeros. */
/* Move past any leading zeros. */
while (*buffer == '0')
buffer++;
@ -1067,7 +1067,7 @@ write_o (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
const char *p;
char itoa_buf[GFC_OTOA_BUF_SIZE];
GFC_UINTEGER_LARGEST n = 0;
if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
{
p = otoa_big (source, itoa_buf, len, &n);
@ -1407,12 +1407,12 @@ write_float_0 (st_parameter_dt *dtp, const fnode *f, const char *source, int kin
/* Precision for snprintf call. */
int precision = get_precision (dtp, f, source, kind);
/* String buffer to hold final result. */
result = select_string (f, str_buf, &res_len);
buffer = select_buffer (precision, buf_stack, &buf_size);
get_float_string (dtp, f, source , kind, 0, buffer,
precision, buf_size, result, &res_len);
write_float_string (dtp, result, res_len);
@ -1525,13 +1525,13 @@ write_real (st_parameter_dt *dtp, const char *source, int kind)
/* Precision for snprintf call. */
int precision = get_precision (dtp, &f, source, kind);
/* String buffer to hold final result. */
result = select_string (&f, str_buf, &res_len);
/* scratch buffer to hold final result. */
buffer = select_buffer (precision, buf_stack, &buf_size);
get_float_string (dtp, &f, source , kind, 1, buffer,
precision, buf_size, result, &res_len);
write_float_string (dtp, result, res_len);
@ -1554,7 +1554,7 @@ write_real_g0 (st_parameter_dt *dtp, const char *source, int kind, int d)
char str_buf[BUF_STACK_SZ];
char *buffer, *result;
size_t buf_size, res_len;
int comp_d;
int comp_d;
set_fnode_default (dtp, &f, kind);
if (d > 0)
@ -1570,7 +1570,7 @@ write_real_g0 (st_parameter_dt *dtp, const char *source, int kind, int d)
/* Precision for snprintf call. */
int precision = get_precision (dtp, &f, source, kind);
/* String buffer to hold final result. */
result = select_string (&f, str_buf, &res_len);
@ -1608,36 +1608,36 @@ write_complex (st_parameter_dt *dtp, const char *source, int kind, size_t size)
dtp->u.p.scale_factor = 1;
set_fnode_default (dtp, &f, kind);
/* Set width for two values, parenthesis, and comma. */
width = 2 * f.u.real.w + 3;
/* Set for no blanks so we get a string result with no leading
blanks. We will pad left later. */
dtp->u.p.g0_no_blanks = 1;
/* Precision for snprintf call. */
int precision = get_precision (dtp, &f, source, kind);
/* String buffers to hold final result. */
result1 = select_string (&f, str1_buf, &res_len1);
result2 = select_string (&f, str2_buf, &res_len2);
buffer = select_buffer (precision, buf_stack, &buf_size);
get_float_string (dtp, &f, source , kind, 0, buffer,
precision, buf_size, result1, &res_len1);
get_float_string (dtp, &f, source + size / 2 , kind, 0, buffer,
precision, buf_size, result2, &res_len2);
lblanks = width - res_len1 - res_len2 - 3;
write_x (dtp, lblanks, lblanks);
write_char (dtp, '(');
write_float_string (dtp, result1, res_len1);
write_char (dtp, semi_comma);
write_float_string (dtp, result2, res_len2);
write_char (dtp, ')');
dtp->u.p.scale_factor = orig_scale;
dtp->u.p.g0_no_blanks = 0;
if (buf_size > BUF_STACK_SZ)
@ -1710,6 +1710,46 @@ list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
case BT_COMPLEX:
write_complex (dtp, p, kind, size);
break;
case BT_CLASS:
{
int unit = dtp->u.p.current_unit->unit_number;
char iotype[] = "LISTDIRECTED";
gfc_charlen_type iotype_len = 12;
char tmp_iomsg[IOMSG_LEN] = "";
char *child_iomsg;
gfc_charlen_type child_iomsg_len;
int noiostat;
int *child_iostat = NULL;
gfc_array_i4 vlist;
GFC_DESCRIPTOR_DATA(&vlist) = NULL;
GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
/* Set iostat, intent(out). */
noiostat = 0;
child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
dtp->common.iostat : &noiostat;
/* Set iomsge, intent(inout). */
if (dtp->common.flags & IOPARM_HAS_IOMSG)
{
child_iomsg = dtp->common.iomsg;
child_iomsg_len = dtp->common.iomsg_len;
}
else
{
child_iomsg = tmp_iomsg;
child_iomsg_len = IOMSG_LEN;
}
/* Call the user defined formatted WRITE procedure. */
dtp->u.p.current_unit->child_dtio++;
dtp->u.p.fdtio_ptr (p, &unit, iotype, &vlist,
child_iostat, child_iomsg,
iotype_len, child_iomsg_len);
dtp->u.p.current_unit->child_dtio--;
}
break;
default:
internal_error (&dtp->common, "list_formatted_write(): Bad type");
}
@ -1844,7 +1884,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
size_t base_name_len;
size_t base_var_name_len;
size_t tot_len;
/* Set the character to be used to separate values
to a comma or semi-colon. */
@ -1903,7 +1943,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
break;
default:
obj_size = len;
obj_size = len;
}
if (obj->var_rank)
@ -1985,7 +2025,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
break;
case BT_DERIVED:
case BT_CLASS:
/* To treat a derived type, we need to build two strings:
ext_name = the name, including qualifiers that prepends
component names in the output - passed to
@ -1995,19 +2035,65 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
components. */
/* First ext_name => get length of all possible components */
if (obj->dtio_sub != NULL)
{
int unit = dtp->u.p.current_unit->unit_number;
char iotype[] = "NAMELIST";
gfc_charlen_type iotype_len = 8;
char tmp_iomsg[IOMSG_LEN] = "";
char *child_iomsg;
gfc_charlen_type child_iomsg_len;
int noiostat;
int *child_iostat = NULL;
gfc_array_i4 vlist;
gfc_class list_obj;
formatted_dtio dtio_ptr = (formatted_dtio)obj->dtio_sub;
GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
list_obj.data = p;
list_obj.vptr = obj->vtable;
list_obj.len = 0;
/* Set iostat, intent(out). */
noiostat = 0;
child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
dtp->common.iostat : &noiostat;
/* Set iomsg, intent(inout). */
if (dtp->common.flags & IOPARM_HAS_IOMSG)
{
child_iomsg = dtp->common.iomsg;
child_iomsg_len = dtp->common.iomsg_len;
}
else
{
child_iomsg = tmp_iomsg;
child_iomsg_len = IOMSG_LEN;
}
namelist_write_newline (dtp);
/* Call the user defined formatted WRITE procedure. */
dtp->u.p.current_unit->child_dtio++;
dtio_ptr ((void *)&list_obj, &unit, iotype, &vlist,
child_iostat, child_iomsg,
iotype_len, child_iomsg_len);
dtp->u.p.current_unit->child_dtio--;
goto obj_loop;
}
base_name_len = base_name ? strlen (base_name) : 0;
base_var_name_len = base ? strlen (base->var_name) : 0;
ext_name_len = base_name_len + base_var_name_len
ext_name_len = base_name_len + base_var_name_len
+ strlen (obj->var_name) + obj->var_rank * NML_DIGITS + 1;
ext_name = xmalloc (ext_name_len);
if (base_name)
memcpy (ext_name, base_name, base_name_len);
clen = strlen (obj->var_name + base_var_name_len);
memcpy (ext_name + base_name_len,
memcpy (ext_name + base_name_len,
obj->var_name + base_var_name_len, clen);
/* Append the qualifier. */
tot_len = base_name_len + clen;
@ -2018,7 +2104,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
ext_name[tot_len] = '(';
tot_len++;
}
snprintf (ext_name + tot_len, ext_name_len - tot_len, "%d",
snprintf (ext_name + tot_len, ext_name_len - tot_len, "%d",
(int) obj->ls[dim_i].idx);
tot_len += strlen (ext_name + tot_len);
ext_name[tot_len] = ((int) dim_i == obj->var_rank - 1) ? ')' : ',';