diff options
| author | Paul Thomas <pault@gcc.gnu.org> | 2016-08-31 05:36:22 +0000 |
|---|---|---|
| committer | Paul Thomas <pault@gcc.gnu.org> | 2016-08-31 05:36:22 +0000 |
| commit | fa15608175e1a96963ff16e859e9d60be35c790f (patch) | |
| tree | ce325707843eb632b75074b035f68aa4267822d0 | |
| parent | a7a768b67786dd5f2196c856816a0debb20b0e56 (diff) | |
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.
git-svn-id: https://gcc.gnu.org/svn/gcc/trunk@239880 138bc75d-0d04-0410-961f-82ee72b054a4
32 files changed, 2895 insertions, 287 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index b4227be7c6b..62bdd9e387b 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -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. diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index ce7254f09c8..b5242394cef 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -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: { diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 813f7d9f10a..2acf64c7b7d 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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; diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index eba0454458e..fece3168dc7 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -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; +} diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index 08812613aec..53037e22a1b 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -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: diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index f3a4a43a34c..9056cb75dac 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -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; } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 0a92efe7784..72be6e57330 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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); diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index c967f25c858..1b94622bf4b 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -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. */ diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 96d413eb8c2..5bae8ca2b19 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -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; diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index e3559f4e00e..19239fb51f2 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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 */ { diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index aefa96dfbbb..2c843497295 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -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, - expr); + if (derived->attr.has_dtio_procs) + arg2 = get_dtio_proc (ts, code, &dtio_sub); - /* 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); + 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); - for (c = ts->u.derived->components; c; c = c->next) - { - field = c->backend_decl; - gcc_assert (field && TREE_CODE (field) == FIELD_DECL); - - tmp = fold_build3_loc (UNKNOWN_LOCATION, - COMPONENT_REF, TREE_TYPE (field), - expr, field, NULL_TREE); - - if (c->attr.dimension) - { - tmp = transfer_array_component (tmp, c, & code->loc); - gfc_add_expr_to_block (&se->pre, tmp); - } - else - { - if (!c->attr.pointer) - tmp = gfc_build_addr_expr (NULL_TREE, tmp); - transfer_expr (se, &c->ts, tmp, code); - } + /* Make sure that the derived type has been built. An external + function, if only referenced in an io statement, requires this + check (see PR58771). */ + if (ts->u.derived->backend_decl == NULL_TREE) + (void) gfc_typenode_for_spec (ts); + + for (c = ts->u.derived->components; c; c = c->next) + { + field = c->backend_decl; + gcc_assert (field && TREE_CODE (field) == FIELD_DECL); + + tmp = fold_build3_loc (UNKNOWN_LOCATION, + COMPONENT_REF, TREE_TYPE (field), + expr, field, NULL_TREE); + + if (c->attr.dimension) + { + tmp = transfer_array_component (tmp, c, & code->loc); + gfc_add_expr_to_block (&se->pre, tmp); + } + else + { + if (!c->attr.pointer) + tmp = gfc_build_addr_expr (NULL_TREE, tmp); + transfer_expr (se, &c->ts, tmp, code, NULL_TREE); + } + } + return; + } + /* If a CLASS object gets through to here, fall through and ICE. */ } - 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: diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index cf97b393f12..3d385bdc38b 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -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 diff --git a/gcc/testsuite/gfortran.dg/dtio_1.f90 b/gcc/testsuite/gfortran.dg/dtio_1.f90 new file mode 100644 index 00000000000..f5b526393f3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dtio_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/dtio_10.f90 b/gcc/testsuite/gfortran.dg/dtio_10.f90 new file mode 100644 index 00000000000..71354b7876f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dtio_10.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/dtio_2.f90 b/gcc/testsuite/gfortran.dg/dtio_2.f90 new file mode 100644 index 00000000000..2041c5ec608 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dtio_2.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/dtio_3.f90 b/gcc/testsuite/gfortran.dg/dtio_3.f90 new file mode 100644 index 00000000000..d6b992aaf40 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dtio_3.f90 @@ -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
diff --git a/gcc/testsuite/gfortran.dg/dtio_4.f90 b/gcc/testsuite/gfortran.dg/dtio_4.f90 new file mode 100644 index 00000000000..5323194af80 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dtio_4.f90 @@ -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
diff --git a/gcc/testsuite/gfortran.dg/dtio_5.f90 b/gcc/testsuite/gfortran.dg/dtio_5.f90 new file mode 100644 index 00000000000..6381d4ddd98 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dtio_5.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/dtio_6.f90 b/gcc/testsuite/gfortran.dg/dtio_6.f90 new file mode 100644 index 00000000000..089db6facf0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dtio_6.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/dtio_7.f90 b/gcc/testsuite/gfortran.dg/dtio_7.f90 new file mode 100644 index 00000000000..33518667488 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dtio_7.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/dtio_8.f90 b/gcc/testsuite/gfortran.dg/dtio_8.f90 new file mode 100644 index 00000000000..6e9f841fe89 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dtio_8.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/dtio_9.f90 b/gcc/testsuite/gfortran.dg/dtio_9.f90 new file mode 100644 index 00000000000..a6ddea8dce2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dtio_9.f90 @@ -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 diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index fc9a45416c8..394f7d35e7b 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -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> diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map index 5f011de68a1..ba01f254c80 100644 --- a/libgfortran/gfortran.map +++ b/libgfortran/gfortran.map @@ -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: diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c index dd05b7a253a..31bc642910a 100644 --- a/libgfortran/io/format.c +++ b/libgfortran/io/format.c @@ -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; } diff --git a/libgfortran/io/format.h b/libgfortran/io/format.h index 7c81df5bc25..3a63e53ea46 100644 --- a/libgfortran/io/format.h +++ b/libgfortran/io/format.h @@ -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; diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h index 494459f92b3..ff75741effd 100644 --- a/libgfortran/io/io.h +++ b/libgfortran/io/io.h @@ -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); diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c index 244430d9765..a42f12b7269 100644 --- a/libgfortran/io/list_read.c +++ b/libgfortran/io/list_read.c @@ -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. */ diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index 4da0606b5d1..98072d0b889 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -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; diff --git a/libgfortran/io/unit.c b/libgfortran/io/unit.c index e0e7b09f6bc..fde9ac752d4 100644 --- a/libgfortran/io/unit.c +++ b/libgfortran/io/unit.c @@ -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); diff --git a/libgfortran/io/unix.c b/libgfortran/io/unix.c index bdec1e89f52..29818cd7a14 100644 --- a/libgfortran/io/unix.c +++ b/libgfortran/io/unix.c @@ -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 diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c index db27f2dc39f..15f7158dbb7 100644 --- a/libgfortran/io/write.c +++ b/libgfortran/io/write.c @@ -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) ? ')' : ','; |