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 | e73d3ca6d1caf9c1187eeb1236dffd42f15ec043 (patch) | |
| tree | ce325707843eb632b75074b035f68aa4267822d0 /gcc | |
| parent | b816477a5ad7277b3a588e9a58cbcd764152b8d2 (diff) | |
| download | gcc-e73d3ca6d1caf9c1187eeb1236dffd42f15ec043.zip gcc-e73d3ca6d1caf9c1187eeb1236dffd42f15ec043.tar.gz gcc-e73d3ca6d1caf9c1187eeb1236dffd42f15ec043.tar.bz2 | |
[multiple changes]
2016-08-31 Paul Thomas <pault@gcc.gnu.org>
Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/48298
* decl.c (access_attr_decl): Include case INTERFACE_DTIO as
appropriate.
* gfortran.h : Add INTRINSIC_FORMATTED and
INTRINSIC_UNFORMATTED to gfc_intrinsic_op. Add INTERFACE_DTIO
to interface type. Add new enum 'dtio_codes'. Add bitfield
'has_dtio_procs' to symbol_attr. Add prototypes
'gfc_check_dtio_interfaces' and 'gfc_find_specific_dtio_proc'.
* interface.c (dtio_op): New function.
(gfc_match_generic_spec): Match generic DTIO interfaces.
(gfc_match_interface): Treat DTIO interfaces in the same way as
(gfc_current_interface_head): Add INTERFACE_DTIO appropriately.
(check_dtio_arg_TKR_intent): New function.
(check_dtio_interface1): New function.
(gfc_check_dtio_interfaces): New function.
(gfc_find_specific_dtio_proc): New function.
* io.c : Add FMT_DT to format_token.
(format_lex): Handle DTIO formatting.
* match.c (gfc_op2string): Add DTIO operators.
* resolve.c (derived_inaccessible): Ignore pointer components
to enclosing derived type.
(resolve_transfer): Resolve transfers that involve DTIO.
procedures. Find the specific subroutine for the transfer and
use its existence to over-ride some of the constraints on
derived types. If the transfer is recursive, require that the
subroutine be so qualified.
(dtio_procs_present): New function.
(resolve_fl_namelist): Remove inhibition of polymorphic objects
in namelists if DTIO read and write subroutines exist. Likewise
for derived types.
(resolve_types): Invoke 'gfc_verify_dtio_procedures'.
* symbol.c : Set 'dtio_procs' using 'minit'.
* trans-decl.c (gfc_finish_var_decl): If a derived-type/class
object is associated with DTIO procedures, make it TREE_STATIC.
* trans-expr.c (gfc_get_vptr_from_expr): If the expression
drills down to a PARM_DECL, extract the vptr correctly.
(gfc_conv_derived_to_class): Check 'info' in the test for
'useflags'. If the se expression exists and is a pointer, use
it as the class _data.
* trans-io.c : Add IOCALL_X_DERIVED to iocall and the function
prototype. Likewise for IOCALL_SET_NML_DTIO_VAL.
(set_parameter_tree): Renamed from 'set_parameter_const', now
returns void and has new tree argument. Calls modified to match
new interface.
(transfer_namelist_element): Transfer DTIO procedure pointer
and vpointer using the new function IOCALL_SET_NML_DTIO_VAL.
(get_dtio_proc): New function.
(transfer_expr): Add new argument for the vptr field of class
objects. Add the code to call the specific DTIO proc, convert
derived types to class and call IOCALL_X_DERIVED.
(trans_transfer): Add BT_CLASS to structures for treatment by
the scalarizer. Obtain the vptr for the dynamic type, both for
scalar and array transfer.
2016-08-31 Jerry DeLisle <jvdelisle@gcc.gnu.org>
Paul Thomas <pault@gcc.gnu.org>
PR libgfortran/48298
* gfortran.map : Flag _st_set_nml_dtio_var and
_gfortran_transfer_derived.
* io/format.c (format_lex): Detect DTIO formatting.
(parse_format_list): Parse the DTIO format.
(next_format): Include FMT_DT.
* io/format.h : Likewise. Add structure 'udf' to structure
'fnode' to carry the IOTYPE string and the 'vlist'.
* io/io.h : Add prototypes for the two types of DTIO subroutine
and a typedef for gfc_class. Also, add to 'namelist_type'
fields for the pointer to the DTIO procedure and the vtable.
Add fields to struct st_parameter_dt for pointers to the two
types of DTIO subroutine. Add to gfc_unit DTIO specific fields.
(internal_proto): Add prototype for 'read_user_defined' and
'write_user_defined'.
* io/list_read.c (check_buffers): Use the 'current_unit' field.
(unget_char): Likewise.
(eat_spaces): Likewise.
(list_formatted_read_scalar): For case BT_CLASS, call the DTIO
procedure.
(nml_get_obj_data): Likewise when DTIO procedure is present,.
* io/transfer.c : Export prototypes for 'transfer_derived' and
'transfer_derived_write'.
(unformatted_read): For case BT_CLASS, call the DTIO procedure.
(unformatted_write): Likewise.
(formatted_transfer_scalar_read): Likewise.
(formatted_transfer_scalar_write: Likewise.
(transfer_derived): New function.
(data_transfer_init): Set last_char if no child_dtio.
(finalize_transfer): Return if child_dtio set.
(st_write_done): Add condition for child_dtio not set.
Add extra arguments for st_set_nml_var prototype.
(set_nml_var): New function that contains the contents of the
old version of st_set_nml_var. Also sets the 'dtio_sub' and
'vtable' fields of the 'nml' structure.
(st_set_nml_var): Now just calls set_nml_var with 'dtio_sub'
and 'vtable' NULL.
(st_set_nml_dtio_var): New function that calls set_nml_var.
* io/unit.c (get_external_unit): If the found unit child_dtio
is non zero, don't do any mutex locking/unlocking. Just
return the unit.
* io/unix.c (tempfile_open): Revert to C style comment.
* io/write.c (list_formatted_write_scalar): Do the DTIO call.
(nml_write_obj): Add BT_CLASS and do the DTIO call.
2016-08-31 Jerry DeLisle <jvdelisle@gcc.gnu.org>
Paul Thomas <pault@gcc.gnu.org>
PR fortran/48298
* gfortran.dg/dtio_1.f90: New test.
* gfortran.dg/dtio_2.f90: New test.
* gfortran.dg/dtio_3.f90: New test.
* gfortran.dg/dtio_4.f90: New test.
* gfortran.dg/dtio_5.f90: New test.
* gfortran.dg/dtio_6.f90: New test.
* gfortran.dg/dtio_7.f90: New test.
* gfortran.dg/dtio_8.f90: New test.
* gfortran.dg/dtio_9.f90: New test.
* gfortran.dg/dtio_10.f90: New test.
From-SVN: r239880
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/fortran/ChangeLog | 58 | ||||
| -rw-r--r-- | gcc/fortran/decl.c | 4 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 23 | ||||
| -rw-r--r-- | gcc/fortran/interface.c | 393 | ||||
| -rw-r--r-- | gcc/fortran/io.c | 88 | ||||
| -rw-r--r-- | gcc/fortran/match.c | 6 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 136 | ||||
| -rw-r--r-- | gcc/fortran/symbol.c | 9 | ||||
| -rw-r--r-- | gcc/fortran/trans-decl.c | 10 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 22 | ||||
| -rw-r--r-- | gcc/fortran/trans-io.c | 266 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 15 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/dtio_1.f90 | 164 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/dtio_10.f90 | 27 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/dtio_2.f90 | 71 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/dtio_3.f90 | 172 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/dtio_4.f90 | 107 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/dtio_5.f90 | 278 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/dtio_6.f90 | 98 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/dtio_7.f90 | 139 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/dtio_8.f90 | 65 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/dtio_9.f90 | 66 |
22 files changed, 2111 insertions, 106 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index b4227be..62bdd9e 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 ce7254f..b524239 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 813f7d9..2acf64c 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 eba0454..fece316 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 0881261..53037e2 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 f3a4a43..9056cb7 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 0a92efe..72be6e5 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 c967f25..1b94622 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 96d413e..5bae8ca 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 e3559f4..19239fb 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 aefa96d..2c84349 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 cf97b39..3d385bd 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 0000000..f5b5263 --- /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 0000000..71354b7 --- /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 0000000..2041c5e --- /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 0000000..d6b992a --- /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 0000000..5323194 --- /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 0000000..6381d4d --- /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 0000000..089db6f --- /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 0000000..3351866 --- /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 0000000..6e9f841 --- /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 0000000..a6ddea8 --- /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 |