e73d3ca6d1
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
156 lines
3.6 KiB
C
156 lines
3.6 KiB
C
/* Copyright (C) 2009-2016 Free Software Foundation, Inc.
|
|
Contributed by Janne Blomqvist
|
|
|
|
This file is part of the GNU Fortran runtime library (libgfortran).
|
|
|
|
Libgfortran is free software; you can redistribute it and/or modify
|
|
it under the terms of the GNU General Public License as published by
|
|
the Free Software Foundation; either version 3, or (at your option)
|
|
any later version.
|
|
|
|
Libgfortran is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
GNU General Public License for more details.
|
|
|
|
Under Section 7 of GPL version 3, you are granted additional
|
|
permissions described in the GCC Runtime Library Exception, version
|
|
3.1, as published by the Free Software Foundation.
|
|
|
|
You should have received a copy of the GNU General Public License and
|
|
a copy of the GCC Runtime Library Exception along with this program;
|
|
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|
<http://www.gnu.org/licenses/>. */
|
|
|
|
#ifndef GFOR_FORMAT_H
|
|
#define GFOR_FORMAT_H
|
|
|
|
#include "io.h"
|
|
|
|
|
|
/* Format tokens. Only about half of these can be stored in the
|
|
format nodes. */
|
|
|
|
typedef enum
|
|
{
|
|
FMT_NONE = 0, FMT_UNKNOWN, FMT_SIGNED_INT, FMT_ZERO, FMT_POSINT, FMT_PERIOD,
|
|
FMT_COMMA, FMT_COLON, FMT_SLASH, FMT_DOLLAR, FMT_T, FMT_TR, FMT_TL,
|
|
FMT_LPAREN, FMT_RPAREN, FMT_X, FMT_S, FMT_SS, FMT_SP, FMT_STRING,
|
|
FMT_BADSTRING, FMT_P, FMT_I, FMT_B, FMT_BN, FMT_BZ, FMT_O, FMT_Z, FMT_F,
|
|
FMT_E, FMT_EN, FMT_ES, FMT_G, FMT_L, FMT_A, FMT_D, FMT_H, FMT_END, FMT_DC,
|
|
FMT_DP, FMT_STAR, FMT_RC, FMT_RD, FMT_RN, FMT_RP, FMT_RU, FMT_RZ, FMT_DT
|
|
}
|
|
format_token;
|
|
|
|
|
|
/* Format nodes. A format string is converted into a tree of these
|
|
structures, which is traversed as part of a data transfer statement. */
|
|
|
|
struct fnode
|
|
{
|
|
format_token format;
|
|
int repeat;
|
|
struct fnode *next;
|
|
char *source;
|
|
|
|
union
|
|
{
|
|
struct
|
|
{
|
|
int w, d, e;
|
|
}
|
|
real;
|
|
|
|
struct
|
|
{
|
|
int length;
|
|
char *p;
|
|
}
|
|
string;
|
|
|
|
struct
|
|
{
|
|
int w, m;
|
|
}
|
|
integer;
|
|
|
|
struct
|
|
{
|
|
char *string;
|
|
int string_len;
|
|
gfc_array_i4 *vlist;
|
|
}
|
|
udf; /* User Defined Format. */
|
|
|
|
int w;
|
|
int k;
|
|
int r;
|
|
int n;
|
|
|
|
struct fnode *child;
|
|
}
|
|
u;
|
|
|
|
/* Members for traversing the tree during data transfer. */
|
|
|
|
int count;
|
|
struct fnode *current;
|
|
|
|
};
|
|
|
|
|
|
/* A storage structures for format node data. */
|
|
|
|
#define FARRAY_SIZE 64
|
|
|
|
typedef struct fnode_array
|
|
{
|
|
struct fnode_array *next;
|
|
fnode array[FARRAY_SIZE];
|
|
}
|
|
fnode_array;
|
|
|
|
|
|
typedef struct format_data
|
|
{
|
|
char *format_string, *string;
|
|
const char *error;
|
|
char error_element;
|
|
format_token saved_token;
|
|
int value, format_string_len, reversion_ok;
|
|
fnode *avail;
|
|
const fnode *saved_format;
|
|
fnode_array *last;
|
|
fnode_array array;
|
|
}
|
|
format_data;
|
|
|
|
extern void parse_format (st_parameter_dt *);
|
|
internal_proto(parse_format);
|
|
|
|
extern const fnode *next_format (st_parameter_dt *);
|
|
internal_proto(next_format);
|
|
|
|
extern void unget_format (st_parameter_dt *, const fnode *);
|
|
internal_proto(unget_format);
|
|
|
|
extern void format_error (st_parameter_dt *, const fnode *, const char *);
|
|
internal_proto(format_error);
|
|
|
|
extern void free_format_data (struct format_data *);
|
|
internal_proto(free_format_data);
|
|
|
|
extern void free_format (st_parameter_dt *);
|
|
internal_proto(free_format);
|
|
|
|
extern void free_format_hash_table (gfc_unit *);
|
|
internal_proto(free_format_hash_table);
|
|
|
|
extern void init_format_hash (st_parameter_dt *);
|
|
internal_proto(init_format_hash);
|
|
|
|
extern void free_format_hash (st_parameter_dt *);
|
|
internal_proto(free_format_hash);
|
|
|
|
#endif
|