/* IO Code translation/library interface
- Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+ Free Software Foundation, Inc.
Contributed by Paul Brook
This file is part of GCC.
GCC 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 2, or (at your option) any later
+Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
for more details.
You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
-#include "tree-gimple.h"
#include "ggc.h"
#include "toplev.h"
-#include "real.h"
#include "gfortran.h"
#include "trans.h"
#include "trans-stmt.h"
#include "trans-types.h"
#include "trans-const.h"
-
/* Members of the ioparm structure. */
-static GTY(()) tree ioparm_unit;
-static GTY(()) tree ioparm_err;
-static GTY(()) tree ioparm_end;
-static GTY(()) tree ioparm_eor;
-static GTY(()) tree ioparm_list_format;
-static GTY(()) tree ioparm_library_return;
-static GTY(()) tree ioparm_iostat;
-static GTY(()) tree ioparm_exist;
-static GTY(()) tree ioparm_opened;
-static GTY(()) tree ioparm_number;
-static GTY(()) tree ioparm_named;
-static GTY(()) tree ioparm_rec;
-static GTY(()) tree ioparm_nextrec;
-static GTY(()) tree ioparm_size;
-static GTY(()) tree ioparm_recl_in;
-static GTY(()) tree ioparm_recl_out;
-static GTY(()) tree ioparm_iolength;
-static GTY(()) tree ioparm_file;
-static GTY(()) tree ioparm_file_len;
-static GTY(()) tree ioparm_status;
-static GTY(()) tree ioparm_status_len;
-static GTY(()) tree ioparm_access;
-static GTY(()) tree ioparm_access_len;
-static GTY(()) tree ioparm_form;
-static GTY(()) tree ioparm_form_len;
-static GTY(()) tree ioparm_blank;
-static GTY(()) tree ioparm_blank_len;
-static GTY(()) tree ioparm_position;
-static GTY(()) tree ioparm_position_len;
-static GTY(()) tree ioparm_action;
-static GTY(()) tree ioparm_action_len;
-static GTY(()) tree ioparm_delim;
-static GTY(()) tree ioparm_delim_len;
-static GTY(()) tree ioparm_pad;
-static GTY(()) tree ioparm_pad_len;
-static GTY(()) tree ioparm_format;
-static GTY(()) tree ioparm_format_len;
-static GTY(()) tree ioparm_advance;
-static GTY(()) tree ioparm_advance_len;
-static GTY(()) tree ioparm_name;
-static GTY(()) tree ioparm_name_len;
-static GTY(()) tree ioparm_internal_unit;
-static GTY(()) tree ioparm_internal_unit_len;
-static GTY(()) tree ioparm_sequential;
-static GTY(()) tree ioparm_sequential_len;
-static GTY(()) tree ioparm_direct;
-static GTY(()) tree ioparm_direct_len;
-static GTY(()) tree ioparm_formatted;
-static GTY(()) tree ioparm_formatted_len;
-static GTY(()) tree ioparm_unformatted;
-static GTY(()) tree ioparm_unformatted_len;
-static GTY(()) tree ioparm_read;
-static GTY(()) tree ioparm_read_len;
-static GTY(()) tree ioparm_write;
-static GTY(()) tree ioparm_write_len;
-static GTY(()) tree ioparm_readwrite;
-static GTY(()) tree ioparm_readwrite_len;
-static GTY(()) tree ioparm_namelist_name;
-static GTY(()) tree ioparm_namelist_name_len;
-static GTY(()) tree ioparm_namelist_read_mode;
-
-/* The global I/O variables */
-
-static GTY(()) tree ioparm_var;
-static GTY(()) tree locus_file;
-static GTY(()) tree locus_line;
+enum ioparam_type
+{
+ IOPARM_ptype_common,
+ IOPARM_ptype_open,
+ IOPARM_ptype_close,
+ IOPARM_ptype_filepos,
+ IOPARM_ptype_inquire,
+ IOPARM_ptype_dt,
+ IOPARM_ptype_wait,
+ IOPARM_ptype_num
+};
+
+enum iofield_type
+{
+ IOPARM_type_int4,
+ IOPARM_type_intio,
+ IOPARM_type_pint4,
+ IOPARM_type_pintio,
+ IOPARM_type_pchar,
+ IOPARM_type_parray,
+ IOPARM_type_pad,
+ IOPARM_type_char1,
+ IOPARM_type_char2,
+ IOPARM_type_common,
+ IOPARM_type_num
+};
+
+typedef struct GTY(()) gfc_st_parameter_field {
+ const char *name;
+ unsigned int mask;
+ enum ioparam_type param_type;
+ enum iofield_type type;
+ tree field;
+ tree field_len;
+}
+gfc_st_parameter_field;
+typedef struct GTY(()) gfc_st_parameter {
+ const char *name;
+ tree type;
+}
+gfc_st_parameter;
+
+enum iofield
+{
+#define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name,
+#include "ioparm.def"
+#undef IOPARM
+ IOPARM_field_num
+};
+
+static GTY(()) gfc_st_parameter st_parameter[] =
+{
+ { "common", NULL },
+ { "open", NULL },
+ { "close", NULL },
+ { "filepos", NULL },
+ { "inquire", NULL },
+ { "dt", NULL },
+ { "wait", NULL }
+};
+
+static GTY(()) gfc_st_parameter_field st_parameter_field[] =
+{
+#define IOPARM(param_type, name, mask, type) \
+ { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL },
+#include "ioparm.def"
+#undef IOPARM
+ { NULL, 0, (enum ioparam_type) 0, (enum iofield_type) 0, NULL, NULL }
+};
/* Library I/O subroutines */
-static GTY(()) tree iocall_read;
-static GTY(()) tree iocall_read_done;
-static GTY(()) tree iocall_write;
-static GTY(()) tree iocall_write_done;
-static GTY(()) tree iocall_x_integer;
-static GTY(()) tree iocall_x_logical;
-static GTY(()) tree iocall_x_character;
-static GTY(()) tree iocall_x_real;
-static GTY(()) tree iocall_x_complex;
-static GTY(()) tree iocall_open;
-static GTY(()) tree iocall_close;
-static GTY(()) tree iocall_inquire;
-static GTY(()) tree iocall_iolength;
-static GTY(()) tree iocall_iolength_done;
-static GTY(()) tree iocall_rewind;
-static GTY(()) tree iocall_backspace;
-static GTY(()) tree iocall_endfile;
-static GTY(()) tree iocall_set_nml_val_int;
-static GTY(()) tree iocall_set_nml_val_float;
-static GTY(()) tree iocall_set_nml_val_char;
-static GTY(()) tree iocall_set_nml_val_complex;
-static GTY(()) tree iocall_set_nml_val_log;
+enum iocall
+{
+ IOCALL_READ,
+ IOCALL_READ_DONE,
+ IOCALL_WRITE,
+ IOCALL_WRITE_DONE,
+ IOCALL_X_INTEGER,
+ IOCALL_X_LOGICAL,
+ IOCALL_X_CHARACTER,
+ IOCALL_X_CHARACTER_WIDE,
+ IOCALL_X_REAL,
+ IOCALL_X_COMPLEX,
+ IOCALL_X_ARRAY,
+ IOCALL_OPEN,
+ IOCALL_CLOSE,
+ IOCALL_INQUIRE,
+ IOCALL_IOLENGTH,
+ IOCALL_IOLENGTH_DONE,
+ IOCALL_REWIND,
+ IOCALL_BACKSPACE,
+ IOCALL_ENDFILE,
+ IOCALL_FLUSH,
+ IOCALL_SET_NML_VAL,
+ IOCALL_SET_NML_VAL_DIM,
+ IOCALL_WAIT,
+ IOCALL_NUM
+};
+
+static GTY(()) tree iocall[IOCALL_NUM];
/* Variable for keeping track of what the last data transfer statement
was. Used for deciding which subroutine to call when the data
transfer is complete. */
static enum { READ, WRITE, IOLENGTH } last_dt;
-#define ADD_FIELD(name, type) \
- ioparm_ ## name = gfc_add_field_to_struct \
- (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
- get_identifier (stringize(name)), type)
+/* The data transfer parameter block that should be shared by all
+ data transfer calls belonging to the same read/write/iolength. */
+static GTY(()) tree dt_parm;
+static stmtblock_t *dt_post_end_block;
+
+static void
+gfc_build_st_parameter (enum ioparam_type ptype, tree *types)
+{
+ unsigned int type;
+ gfc_st_parameter_field *p;
+ char name[64];
+ size_t len;
+ tree t = make_node (RECORD_TYPE);
+
+ len = strlen (st_parameter[ptype].name);
+ gcc_assert (len <= sizeof (name) - sizeof ("__st_parameter_"));
+ memcpy (name, "__st_parameter_", sizeof ("__st_parameter_"));
+ memcpy (name + sizeof ("__st_parameter_") - 1, st_parameter[ptype].name,
+ len + 1);
+ TYPE_NAME (t) = get_identifier (name);
+
+ for (type = 0, p = st_parameter_field; type < IOPARM_field_num; type++, p++)
+ if (p->param_type == ptype)
+ switch (p->type)
+ {
+ case IOPARM_type_int4:
+ case IOPARM_type_intio:
+ case IOPARM_type_pint4:
+ case IOPARM_type_pintio:
+ case IOPARM_type_parray:
+ case IOPARM_type_pchar:
+ case IOPARM_type_pad:
+ p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
+ get_identifier (p->name),
+ types[p->type]);
+ break;
+ case IOPARM_type_char1:
+ p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
+ get_identifier (p->name),
+ pchar_type_node);
+ /* FALLTHROUGH */
+ case IOPARM_type_char2:
+ len = strlen (p->name);
+ gcc_assert (len <= sizeof (name) - sizeof ("_len"));
+ memcpy (name, p->name, len);
+ memcpy (name + len, "_len", sizeof ("_len"));
+ p->field_len = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
+ get_identifier (name),
+ gfc_charlen_type_node);
+ if (p->type == IOPARM_type_char2)
+ p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
+ get_identifier (p->name),
+ pchar_type_node);
+ break;
+ case IOPARM_type_common:
+ p->field
+ = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
+ get_identifier (p->name),
+ st_parameter[IOPARM_ptype_common].type);
+ break;
+ case IOPARM_type_num:
+ gcc_unreachable ();
+ }
+
+ gfc_finish_type (t);
+ st_parameter[ptype].type = t;
+}
-#define ADD_STRING(name) \
- ioparm_ ## name = gfc_add_field_to_struct \
- (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
- get_identifier (stringize(name)), pchar_type_node); \
- ioparm_ ## name ## _len = gfc_add_field_to_struct \
- (&(TYPE_FIELDS (ioparm_type)), ioparm_type, \
- get_identifier (stringize(name) "_len"), gfc_charlen_type_node)
+
+/* Build code to test an error condition and call generate_error if needed.
+ Note: This builds calls to generate_error in the runtime library function.
+ The function generate_error is dependent on certain parameters in the
+ st_parameter_common flags to be set. (See libgfortran/runtime/error.c)
+ Therefore, the code to set these flags must be generated before
+ this function is used. */
+
+void
+gfc_trans_io_runtime_check (tree cond, tree var, int error_code,
+ const char * msgid, stmtblock_t * pblock)
+{
+ stmtblock_t block;
+ tree body;
+ tree tmp;
+ tree arg1, arg2, arg3;
+ char *message;
+
+ if (integer_zerop (cond))
+ return;
+
+ /* The code to generate the error. */
+ gfc_start_block (&block);
+
+ arg1 = gfc_build_addr_expr (NULL_TREE, var);
+
+ arg2 = build_int_cst (integer_type_node, error_code),
+
+ asprintf (&message, "%s", _(msgid));
+ arg3 = gfc_build_addr_expr (pchar_type_node,
+ gfc_build_localized_cstring_const (message));
+ gfc_free(message);
+
+ tmp = build_call_expr_loc (input_location,
+ gfor_fndecl_generate_error, 3, arg1, arg2, arg3);
+
+ gfc_add_expr_to_block (&block, tmp);
+
+ body = gfc_finish_block (&block);
+
+ if (integer_onep (cond))
+ {
+ gfc_add_expr_to_block (pblock, body);
+ }
+ else
+ {
+ /* Tell the compiler that this isn't likely. */
+ cond = fold_convert (long_integer_type_node, cond);
+ tmp = build_int_cst (long_integer_type_node, 0);
+ cond = build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
+ cond = fold_convert (boolean_type_node, cond);
+
+ tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (pblock, tmp);
+ }
+}
/* Create function decls for IO library functions. */
void
gfc_build_io_library_fndecls (void)
{
- tree gfc_int4_type_node;
- tree gfc_pint4_type_node;
- tree ioparm_type;
-
- gfc_int4_type_node = gfc_get_int_type (4);
- gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
-
- /* Build the st_parameter structure. Information associated with I/O
- calls are transferred here. This must match the one defined in the
- library exactly. */
-
- ioparm_type = make_node (RECORD_TYPE);
- TYPE_NAME (ioparm_type) = get_identifier ("_gfc_ioparm");
-
- ADD_FIELD (unit, gfc_int4_type_node);
- ADD_FIELD (err, gfc_int4_type_node);
- ADD_FIELD (end, gfc_int4_type_node);
- ADD_FIELD (eor, gfc_int4_type_node);
- ADD_FIELD (list_format, gfc_int4_type_node);
- ADD_FIELD (library_return, gfc_int4_type_node);
-
- ADD_FIELD (iostat, gfc_pint4_type_node);
- ADD_FIELD (exist, gfc_pint4_type_node);
- ADD_FIELD (opened, gfc_pint4_type_node);
- ADD_FIELD (number, gfc_pint4_type_node);
- ADD_FIELD (named, gfc_pint4_type_node);
- ADD_FIELD (rec, gfc_int4_type_node);
- ADD_FIELD (nextrec, gfc_pint4_type_node);
- ADD_FIELD (size, gfc_pint4_type_node);
-
- ADD_FIELD (recl_in, gfc_int4_type_node);
- ADD_FIELD (recl_out, gfc_pint4_type_node);
-
- ADD_FIELD (iolength, gfc_pint4_type_node);
-
- ADD_STRING (file);
- ADD_STRING (status);
-
- ADD_STRING (access);
- ADD_STRING (form);
- ADD_STRING (blank);
- ADD_STRING (position);
- ADD_STRING (action);
- ADD_STRING (delim);
- ADD_STRING (pad);
- ADD_STRING (format);
- ADD_STRING (advance);
- ADD_STRING (name);
- ADD_STRING (internal_unit);
- ADD_STRING (sequential);
-
- ADD_STRING (direct);
- ADD_STRING (formatted);
- ADD_STRING (unformatted);
- ADD_STRING (read);
- ADD_STRING (write);
- ADD_STRING (readwrite);
-
- ADD_STRING (namelist_name);
- ADD_FIELD (namelist_read_mode, gfc_int4_type_node);
-
- gfc_finish_type (ioparm_type);
-
- ioparm_var = build_decl (VAR_DECL, get_identifier (PREFIX("ioparm")),
- ioparm_type);
- DECL_EXTERNAL (ioparm_var) = 1;
- TREE_PUBLIC (ioparm_var) = 1;
-
- locus_line = build_decl (VAR_DECL, get_identifier (PREFIX("line")),
- gfc_int4_type_node);
- DECL_EXTERNAL (locus_line) = 1;
- TREE_PUBLIC (locus_line) = 1;
-
- locus_file = build_decl (VAR_DECL, get_identifier (PREFIX("filename")),
- pchar_type_node);
- DECL_EXTERNAL (locus_file) = 1;
- TREE_PUBLIC (locus_file) = 1;
+ tree types[IOPARM_type_num], pad_idx, gfc_int4_type_node;
+ tree gfc_intio_type_node;
+ tree parm_type, dt_parm_type;
+ HOST_WIDE_INT pad_size;
+ unsigned int ptype;
+
+ types[IOPARM_type_int4] = gfc_int4_type_node = gfc_get_int_type (4);
+ types[IOPARM_type_intio] = gfc_intio_type_node
+ = gfc_get_int_type (gfc_intio_kind);
+ types[IOPARM_type_pint4] = build_pointer_type (gfc_int4_type_node);
+ types[IOPARM_type_pintio]
+ = build_pointer_type (gfc_intio_type_node);
+ types[IOPARM_type_parray] = pchar_type_node;
+ types[IOPARM_type_pchar] = pchar_type_node;
+ pad_size = 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node));
+ pad_size += 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node));
+ pad_idx = build_index_type (build_int_cst (NULL_TREE, pad_size - 1));
+ types[IOPARM_type_pad] = build_array_type (char_type_node, pad_idx);
+
+ /* pad actually contains pointers and integers so it needs to have an
+ alignment that is at least as large as the needed alignment for those
+ types. See the st_parameter_dt structure in libgfortran/io/io.h for
+ what really goes into this space. */
+ TYPE_ALIGN (types[IOPARM_type_pad]) = MAX (TYPE_ALIGN (pchar_type_node),
+ TYPE_ALIGN (gfc_get_int_type (gfc_intio_kind)));
+
+ for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++)
+ gfc_build_st_parameter ((enum ioparam_type) ptype, types);
/* Define the transfer functions. */
- iocall_x_integer =
+ dt_parm_type = build_pointer_type (st_parameter[IOPARM_ptype_dt].type);
+
+ iocall[IOCALL_X_INTEGER] =
gfc_build_library_function_decl (get_identifier
(PREFIX("transfer_integer")),
- void_type_node, 2, pvoid_type_node,
- gfc_int4_type_node);
+ void_type_node, 3, dt_parm_type,
+ pvoid_type_node, gfc_int4_type_node);
- iocall_x_logical =
+ iocall[IOCALL_X_LOGICAL] =
gfc_build_library_function_decl (get_identifier
(PREFIX("transfer_logical")),
- void_type_node, 2, pvoid_type_node,
- gfc_int4_type_node);
+ void_type_node, 3, dt_parm_type,
+ pvoid_type_node, gfc_int4_type_node);
- iocall_x_character =
+ iocall[IOCALL_X_CHARACTER] =
gfc_build_library_function_decl (get_identifier
(PREFIX("transfer_character")),
- void_type_node, 2, pvoid_type_node,
+ void_type_node, 3, dt_parm_type,
+ pvoid_type_node, gfc_int4_type_node);
+
+ iocall[IOCALL_X_CHARACTER_WIDE] =
+ gfc_build_library_function_decl (get_identifier
+ (PREFIX("transfer_character_wide")),
+ void_type_node, 4, dt_parm_type,
+ pvoid_type_node, gfc_charlen_type_node,
gfc_int4_type_node);
- iocall_x_real =
+ iocall[IOCALL_X_REAL] =
gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
- void_type_node, 2,
+ void_type_node, 3, dt_parm_type,
pvoid_type_node, gfc_int4_type_node);
- iocall_x_complex =
+ iocall[IOCALL_X_COMPLEX] =
gfc_build_library_function_decl (get_identifier
(PREFIX("transfer_complex")),
- void_type_node, 2, pvoid_type_node,
- gfc_int4_type_node);
+ void_type_node, 3, dt_parm_type,
+ pvoid_type_node, gfc_int4_type_node);
+
+ iocall[IOCALL_X_ARRAY] =
+ gfc_build_library_function_decl (get_identifier
+ (PREFIX("transfer_array")),
+ void_type_node, 4, dt_parm_type,
+ pvoid_type_node, integer_type_node,
+ gfc_charlen_type_node);
/* Library entry points */
- iocall_read =
+ iocall[IOCALL_READ] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
- void_type_node, 0);
+ void_type_node, 1, dt_parm_type);
- iocall_write =
+ iocall[IOCALL_WRITE] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
- void_type_node, 0);
- iocall_open =
+ void_type_node, 1, dt_parm_type);
+
+ parm_type = build_pointer_type (st_parameter[IOPARM_ptype_open].type);
+ iocall[IOCALL_OPEN] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
- void_type_node, 0);
+ void_type_node, 1, parm_type);
- iocall_close =
+
+ parm_type = build_pointer_type (st_parameter[IOPARM_ptype_close].type);
+ iocall[IOCALL_CLOSE] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
- void_type_node, 0);
+ void_type_node, 1, parm_type);
- iocall_inquire =
+ parm_type = build_pointer_type (st_parameter[IOPARM_ptype_inquire].type);
+ iocall[IOCALL_INQUIRE] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
- gfc_int4_type_node, 0);
+ gfc_int4_type_node, 1, parm_type);
- iocall_iolength =
+ iocall[IOCALL_IOLENGTH] =
gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
- void_type_node, 0);
+ void_type_node, 1, dt_parm_type);
+
+ parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type);
+ iocall[IOCALL_WAIT] =
+ gfc_build_library_function_decl (get_identifier (PREFIX("st_wait")),
+ gfc_int4_type_node, 1, parm_type);
- iocall_rewind =
+ parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
+ iocall[IOCALL_REWIND] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
- gfc_int4_type_node, 0);
+ gfc_int4_type_node, 1, parm_type);
- iocall_backspace =
+ iocall[IOCALL_BACKSPACE] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
- gfc_int4_type_node, 0);
+ gfc_int4_type_node, 1, parm_type);
- iocall_endfile =
+ iocall[IOCALL_ENDFILE] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
- gfc_int4_type_node, 0);
+ gfc_int4_type_node, 1, parm_type);
+
+ iocall[IOCALL_FLUSH] =
+ gfc_build_library_function_decl (get_identifier (PREFIX("st_flush")),
+ gfc_int4_type_node, 1, parm_type);
+
/* Library helpers */
- iocall_read_done =
+ iocall[IOCALL_READ_DONE] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
- gfc_int4_type_node, 0);
+ gfc_int4_type_node, 1, dt_parm_type);
- iocall_write_done =
+ iocall[IOCALL_WRITE_DONE] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
- gfc_int4_type_node, 0);
+ gfc_int4_type_node, 1, dt_parm_type);
- iocall_iolength_done =
+ iocall[IOCALL_IOLENGTH_DONE] =
gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
- gfc_int4_type_node, 0);
-
- iocall_set_nml_val_int =
- gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_int")),
- void_type_node, 4,
- pvoid_type_node, pvoid_type_node,
- gfc_int4_type_node,gfc_int4_type_node);
-
- iocall_set_nml_val_float =
- gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_float")),
- void_type_node, 4,
- pvoid_type_node, pvoid_type_node,
- gfc_int4_type_node,gfc_int4_type_node);
- iocall_set_nml_val_char =
- gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_char")),
- void_type_node, 5,
- pvoid_type_node, pvoid_type_node,
- gfc_int4_type_node, gfc_int4_type_node,
- gfc_charlen_type_node);
- iocall_set_nml_val_complex =
- gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_complex")),
- void_type_node, 4,
- pvoid_type_node, pvoid_type_node,
- gfc_int4_type_node,gfc_int4_type_node);
- iocall_set_nml_val_log =
- gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_log")),
- void_type_node, 4,
- pvoid_type_node, pvoid_type_node,
- gfc_int4_type_node,gfc_int4_type_node);
+ gfc_int4_type_node, 1, dt_parm_type);
+
+
+ iocall[IOCALL_SET_NML_VAL] =
+ gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
+ 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_VAL_DIM] =
+ gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
+ void_type_node, 5, dt_parm_type,
+ gfc_int4_type_node, gfc_array_index_type,
+ gfc_array_index_type, gfc_array_index_type);
}
-/* Generate code to store an non-string I/O parameter into the
- ioparm structure. This is a pass by value. */
+/* Generate code to store an integer constant into the
+ st_parameter_XXX structure. */
-static void
-set_parameter_value (stmtblock_t * block, tree var, gfc_expr * e)
+static unsigned int
+set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
+ unsigned int val)
+{
+ tree tmp;
+ gfc_st_parameter_field *p = &st_parameter_field[type];
+
+ if (p->param_type == IOPARM_ptype_common)
+ var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
+ var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+ tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
+ NULL_TREE);
+ gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (p->field), val));
+ return p->mask;
+}
+
+
+/* Generate code to store a non-string I/O parameter into the
+ st_parameter_XXX structure. This is a pass by value. */
+
+static unsigned int
+set_parameter_value (stmtblock_t *block, tree var, enum iofield type,
+ gfc_expr *e)
{
gfc_se se;
tree tmp;
+ gfc_st_parameter_field *p = &st_parameter_field[type];
+ tree dest_type = TREE_TYPE (p->field);
gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, e, TREE_TYPE (var));
+ gfc_conv_expr_val (&se, e);
+
+ /* If we're storing a UNIT number, we need to check it first. */
+ if (type == IOPARM_common_unit && e->ts.kind > 4)
+ {
+ tree cond, val;
+ int i;
+
+ /* Don't evaluate the UNIT number multiple times. */
+ se.expr = gfc_evaluate_now (se.expr, &se.pre);
+
+ /* UNIT numbers should be greater than the min. */
+ i = gfc_validate_kind (BT_INTEGER, 4, false);
+ val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].pedantic_min_int, 4);
+ cond = fold_build2 (LT_EXPR, boolean_type_node, se.expr,
+ fold_convert (TREE_TYPE (se.expr), val));
+ gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT,
+ "Unit number in I/O statement too small",
+ &se.pre);
+
+ /* UNIT numbers should be less than the max. */
+ val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4);
+ cond = fold_build2 (GT_EXPR, boolean_type_node, se.expr,
+ fold_convert (TREE_TYPE (se.expr), val));
+ gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT,
+ "Unit number in I/O statement too large",
+ &se.pre);
+
+ }
+
+ se.expr = convert (dest_type, se.expr);
gfc_add_block_to_block (block, &se.pre);
- tmp = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
- gfc_add_modify_expr (block, tmp, se.expr);
+ if (p->param_type == IOPARM_ptype_common)
+ var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
+ var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+
+ tmp = fold_build3 (COMPONENT_REF, dest_type, var, p->field, NULL_TREE);
+ gfc_add_modify (block, tmp, se.expr);
+ return p->mask;
}
-/* Generate code to store an non-string I/O parameter into the
- ioparm structure. This is pass by reference. */
+/* Generate code to store a non-string I/O parameter into the
+ st_parameter_XXX structure. This is pass by reference. */
-static void
-set_parameter_ref (stmtblock_t * block, tree var, gfc_expr * e)
+static unsigned int
+set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
+ tree var, enum iofield type, gfc_expr *e)
{
gfc_se se;
- tree tmp;
+ tree tmp, addr;
+ gfc_st_parameter_field *p = &st_parameter_field[type];
+ gcc_assert (e->ts.type == BT_INTEGER || e->ts.type == BT_LOGICAL);
gfc_init_se (&se, NULL);
- se.want_pointer = 1;
+ gfc_conv_expr_lhs (&se, e);
- gfc_conv_expr_type (&se, e, TREE_TYPE (var));
gfc_add_block_to_block (block, &se.pre);
- tmp = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
- gfc_add_modify_expr (block, tmp, se.expr);
+ if (TYPE_MODE (TREE_TYPE (se.expr))
+ == TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field))))
+ {
+ addr = convert (TREE_TYPE (p->field), gfc_build_addr_expr (NULL_TREE, se.expr));
+
+ /* If this is for the iostat variable initialize the
+ user variable to LIBERROR_OK which is zero. */
+ if (type == IOPARM_common_iostat)
+ gfc_add_modify (block, se.expr,
+ build_int_cst (TREE_TYPE (se.expr), LIBERROR_OK));
+ }
+ else
+ {
+ /* The type used by the library has different size
+ from the type of the variable supplied by the user.
+ Need to use a temporary. */
+ tree tmpvar = gfc_create_var (TREE_TYPE (TREE_TYPE (p->field)),
+ st_parameter_field[type].name);
+
+ /* If this is for the iostat variable, initialize the
+ user variable to LIBERROR_OK which is zero. */
+ if (type == IOPARM_common_iostat)
+ gfc_add_modify (block, tmpvar,
+ build_int_cst (TREE_TYPE (tmpvar), LIBERROR_OK));
+
+ addr = gfc_build_addr_expr (NULL_TREE, tmpvar);
+ /* After the I/O operation, we set the variable from the temporary. */
+ tmp = convert (TREE_TYPE (se.expr), tmpvar);
+ gfc_add_modify (postblock, se.expr, tmp);
+ }
+
+ if (p->param_type == IOPARM_ptype_common)
+ var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
+ var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+ tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
+ var, p->field, NULL_TREE);
+ gfc_add_modify (block, tmp, addr);
+ return p->mask;
+}
+
+/* Given an array expr, find its address and length to get a string. If the
+ array is full, the string's address is the address of array's first element
+ and the length is the size of the whole array. If it is an element, the
+ string's address is the element's address and the length is the rest size of
+ the array. */
+
+static void
+gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
+{
+ tree size;
+
+ if (e->rank == 0)
+ {
+ tree type, array, tmp;
+ gfc_symbol *sym;
+ int rank;
+
+ /* If it is an element, we need its address and size of the rest. */
+ gcc_assert (e->expr_type == EXPR_VARIABLE);
+ gcc_assert (e->ref->u.ar.type == AR_ELEMENT);
+ sym = e->symtree->n.sym;
+ rank = sym->as->rank - 1;
+ gfc_conv_expr (se, e);
+
+ array = sym->backend_decl;
+ type = TREE_TYPE (array);
+
+ if (GFC_ARRAY_TYPE_P (type))
+ size = GFC_TYPE_ARRAY_SIZE (type);
+ else
+ {
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+ size = gfc_conv_array_stride (array, rank);
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ gfc_conv_array_ubound (array, rank),
+ gfc_conv_array_lbound (array, rank));
+ tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
+ gfc_index_one_node);
+ size = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
+ }
+ gcc_assert (size);
+
+ size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
+ TREE_OPERAND (se->expr, 1));
+ se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
+ tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
+ size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
+ fold_convert (gfc_array_index_type, tmp));
+ se->string_length = fold_convert (gfc_charlen_type_node, size);
+ return;
+ }
+
+ gfc_conv_array_parameter (se, e, gfc_walk_expr (e), true, NULL, NULL, &size);
+ se->string_length = fold_convert (gfc_charlen_type_node, size);
}
/* Generate code to store a string and its length into the
- ioparm structure. */
+ st_parameter_XXX structure. */
-static void
+static unsigned int
set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
- tree var_len, gfc_expr * e)
+ enum iofield type, gfc_expr * e)
{
gfc_se se;
tree tmp;
- tree msg;
tree io;
tree len;
+ gfc_st_parameter_field *p = &st_parameter_field[type];
gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, e);
- io = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
- len = build3 (COMPONENT_REF, TREE_TYPE (var_len), ioparm_var, var_len,
- NULL_TREE);
+ if (p->param_type == IOPARM_ptype_common)
+ var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
+ var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+ io = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
+ var, p->field, NULL_TREE);
+ len = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field_len),
+ var, p->field_len, NULL_TREE);
/* Integer variable assigned a format label. */
- if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1)
+ if (e->ts.type == BT_INTEGER
+ && e->rank == 0
+ && e->symtree->n.sym->attr.assign == 1)
{
- msg =
- gfc_build_cstring_const ("Assigned label is not a format label");
+ char * msg;
+ tree cond;
+
+ gfc_conv_label_variable (&se, e);
tmp = GFC_DECL_STRING_LEN (se.expr);
- tmp = build2 (LE_EXPR, boolean_type_node,
- tmp, convert (TREE_TYPE (tmp), integer_minus_one_node));
- gfc_trans_runtime_check (tmp, msg, &se.pre);
- gfc_add_modify_expr (&se.pre, io, GFC_DECL_ASSIGN_ADDR (se.expr));
- gfc_add_modify_expr (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
+ cond = fold_build2 (LT_EXPR, boolean_type_node,
+ tmp, build_int_cst (TREE_TYPE (tmp), 0));
+
+ asprintf(&msg, "Label assigned to variable '%s' (%%ld) is not a format "
+ "label", e->symtree->name);
+ gfc_trans_runtime_check (true, false, cond, &se.pre, &e->where, msg,
+ fold_convert (long_integer_type_node, tmp));
+ gfc_free (msg);
+
+ gfc_add_modify (&se.pre, io,
+ fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr)));
+ gfc_add_modify (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
}
else
{
+ /* General character. */
+ if (e->ts.type == BT_CHARACTER && e->rank == 0)
+ gfc_conv_expr (&se, e);
+ /* Array assigned Hollerith constant or character array. */
+ else if (e->rank > 0 || (e->symtree && e->symtree->n.sym->as->rank > 0))
+ gfc_convert_array_to_string (&se, e);
+ else
+ gcc_unreachable ();
+
gfc_conv_string_parameter (&se);
- gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
- gfc_add_modify_expr (&se.pre, len, se.string_length);
+ gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
+ gfc_add_modify (&se.pre, len, se.string_length);
}
gfc_add_block_to_block (block, &se.pre);
gfc_add_block_to_block (postblock, &se.post);
-
+ return p->mask;
}
-/* Set a member of the ioparm structure to one. */
-static void
-set_flag (stmtblock_t *block, tree var)
+/* Generate code to store the character (array) and the character length
+ for an internal unit. */
+
+static unsigned int
+set_internal_unit (stmtblock_t * block, stmtblock_t * post_block,
+ tree var, gfc_expr * e)
{
- tree tmp, type = TREE_TYPE (var);
+ gfc_se se;
+ tree io;
+ tree len;
+ tree desc;
+ tree tmp;
+ gfc_st_parameter_field *p;
+ unsigned int mask;
- tmp = build3 (COMPONENT_REF, type, ioparm_var, var, NULL_TREE);
- gfc_add_modify_expr (block, tmp, convert (type, integer_one_node));
-}
+ gfc_init_se (&se, NULL);
+
+ p = &st_parameter_field[IOPARM_dt_internal_unit];
+ mask = p->mask;
+ io = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
+ var, p->field, NULL_TREE);
+ len = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field_len),
+ var, p->field_len, NULL_TREE);
+ p = &st_parameter_field[IOPARM_dt_internal_unit_desc];
+ desc = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
+ var, p->field, NULL_TREE);
+
+ gcc_assert (e->ts.type == BT_CHARACTER);
+
+ /* Character scalars. */
+ if (e->rank == 0)
+ {
+ gfc_conv_expr (&se, e);
+ gfc_conv_string_parameter (&se);
+ tmp = se.expr;
+ se.expr = build_int_cst (pchar_type_node, 0);
+ }
+
+ /* Character array. */
+ else if (e->rank > 0)
+ {
+ se.ss = gfc_walk_expr (e);
+
+ if (is_subref_array (e))
+ {
+ /* Use a temporary for components of arrays of derived types
+ or substring array references. */
+ gfc_conv_subref_array_arg (&se, e, 0,
+ last_dt == READ ? INTENT_IN : INTENT_OUT, false);
+ tmp = build_fold_indirect_ref_loc (input_location,
+ se.expr);
+ se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
+ tmp = gfc_conv_descriptor_data_get (tmp);
+ }
+ else
+ {
+ /* Return the data pointer and rank from the descriptor. */
+ gfc_conv_expr_descriptor (&se, e, se.ss);
+ tmp = gfc_conv_descriptor_data_get (se.expr);
+ se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
+ }
+ }
+ else
+ gcc_unreachable ();
+ /* The cast is needed for character substrings and the descriptor
+ data. */
+ gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), tmp));
+ gfc_add_modify (&se.pre, len,
+ fold_convert (TREE_TYPE (len), se.string_length));
+ gfc_add_modify (&se.pre, desc, se.expr);
+
+ gfc_add_block_to_block (block, &se.pre);
+ gfc_add_block_to_block (post_block, &se.post);
+ return mask;
+}
/* Add a case to a IO-result switch. */
be created anyway. */
static void
-io_result (stmtblock_t * block, gfc_st_label * err_label,
+io_result (stmtblock_t * block, tree var, gfc_st_label * err_label,
gfc_st_label * end_label, gfc_st_label * eor_label)
{
stmtblock_t body;
tree tmp, rc;
+ gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
/* If no labels are specified, ignore the result instead
of building an empty switch. */
tmp = gfc_finish_block (&body);
- rc = build3 (COMPONENT_REF, TREE_TYPE (ioparm_library_return), ioparm_var,
- ioparm_library_return, NULL_TREE);
+ var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
+ var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+ rc = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
+ var, p->field, NULL_TREE);
+ rc = fold_build2 (BIT_AND_EXPR, TREE_TYPE (rc),
+ rc, build_int_cst (TREE_TYPE (rc),
+ IOPARM_common_libreturn_mask));
tmp = build3_v (SWITCH_EXPR, rc, tmp, NULL_TREE);
library call goes awry, we can tell the user where the problem is. */
static void
-set_error_locus (stmtblock_t * block, locus * where)
+set_error_locus (stmtblock_t * block, tree var, locus * where)
{
gfc_file *f;
- tree tmp;
+ tree str, locus_file;
int line;
+ gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename];
+ locus_file = fold_build3 (COMPONENT_REF,
+ st_parameter[IOPARM_ptype_common].type,
+ var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
+ locus_file = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
+ locus_file, p->field, NULL_TREE);
f = where->lb->file;
- tmp = gfc_build_cstring_const (f->filename);
+ str = gfc_build_cstring_const (f->filename);
- tmp = gfc_build_addr_expr (pchar_type_node, tmp);
- gfc_add_modify_expr (block, locus_file, tmp);
+ str = gfc_build_addr_expr (pchar_type_node, str);
+ gfc_add_modify (block, locus_file, str);
-#ifdef USE_MAPPED_LOCATION
line = LOCATION_LINE (where->lb->location);
-#else
- line = where->lb->linenum;
-#endif
- gfc_add_modify_expr (block, locus_line, build_int_cst (NULL_TREE, line));
+ set_parameter_const (block, var, IOPARM_common_line, line);
}
{
stmtblock_t block, post_block;
gfc_open *p;
- tree tmp;
+ tree tmp, var;
+ unsigned int mask = 0;
- gfc_init_block (&block);
+ gfc_start_block (&block);
gfc_init_block (&post_block);
- set_error_locus (&block, &code->loc);
+ var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm");
+
+ set_error_locus (&block, var, &code->loc);
p = code->ext.open;
- if (p->unit)
- set_parameter_value (&block, ioparm_unit, p->unit);
+ if (p->iomsg)
+ mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+ p->iomsg);
+
+ if (p->iostat)
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
+ p->iostat);
+
+ if (p->err)
+ mask |= IOPARM_common_err;
if (p->file)
- set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
+ mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);
if (p->status)
- set_string (&block, &post_block, ioparm_status,
- ioparm_status_len, p->status);
+ mask |= set_string (&block, &post_block, var, IOPARM_open_status,
+ p->status);
if (p->access)
- set_string (&block, &post_block, ioparm_access,
- ioparm_access_len, p->access);
+ mask |= set_string (&block, &post_block, var, IOPARM_open_access,
+ p->access);
if (p->form)
- set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form);
+ mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);
if (p->recl)
- set_parameter_value (&block, ioparm_recl_in, p->recl);
+ mask |= set_parameter_value (&block, var, IOPARM_open_recl_in, p->recl);
if (p->blank)
- set_string (&block, &post_block, ioparm_blank, ioparm_blank_len,
- p->blank);
+ mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
+ p->blank);
if (p->position)
- set_string (&block, &post_block, ioparm_position,
- ioparm_position_len, p->position);
+ mask |= set_string (&block, &post_block, var, IOPARM_open_position,
+ p->position);
if (p->action)
- set_string (&block, &post_block, ioparm_action,
- ioparm_action_len, p->action);
+ mask |= set_string (&block, &post_block, var, IOPARM_open_action,
+ p->action);
if (p->delim)
- set_string (&block, &post_block, ioparm_delim, ioparm_delim_len,
- p->delim);
+ mask |= set_string (&block, &post_block, var, IOPARM_open_delim,
+ p->delim);
if (p->pad)
- set_string (&block, &post_block, ioparm_pad, ioparm_pad_len, p->pad);
+ mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
- if (p->iostat)
- set_parameter_ref (&block, ioparm_iostat, p->iostat);
+ if (p->decimal)
+ mask |= set_string (&block, &post_block, var, IOPARM_open_decimal,
+ p->decimal);
- if (p->err)
- set_flag (&block, ioparm_err);
+ if (p->encoding)
+ mask |= set_string (&block, &post_block, var, IOPARM_open_encoding,
+ p->encoding);
- tmp = gfc_build_function_call (iocall_open, NULL_TREE);
+ if (p->round)
+ mask |= set_string (&block, &post_block, var, IOPARM_open_round, p->round);
+
+ if (p->sign)
+ mask |= set_string (&block, &post_block, var, IOPARM_open_sign, p->sign);
+
+ if (p->asynchronous)
+ mask |= set_string (&block, &post_block, var, IOPARM_open_asynchronous,
+ p->asynchronous);
+
+ if (p->convert)
+ mask |= set_string (&block, &post_block, var, IOPARM_open_convert,
+ p->convert);
+
+ if (p->newunit)
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_open_newunit,
+ p->newunit);
+
+ set_parameter_const (&block, var, IOPARM_common_flags, mask);
+
+ if (p->unit)
+ set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
+ else
+ set_parameter_const (&block, var, IOPARM_common_unit, 0);
+
+ tmp = gfc_build_addr_expr (NULL_TREE, var);
+ tmp = build_call_expr_loc (input_location,
+ iocall[IOCALL_OPEN], 1, tmp);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &post_block);
- io_result (&block, p->err, NULL, NULL);
+ io_result (&block, var, p->err, NULL, NULL);
return gfc_finish_block (&block);
}
{
stmtblock_t block, post_block;
gfc_close *p;
- tree tmp;
+ tree tmp, var;
+ unsigned int mask = 0;
- gfc_init_block (&block);
+ gfc_start_block (&block);
gfc_init_block (&post_block);
- set_error_locus (&block, &code->loc);
- p = code->ext.close;
+ var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm");
- if (p->unit)
- set_parameter_value (&block, ioparm_unit, p->unit);
+ set_error_locus (&block, var, &code->loc);
+ p = code->ext.close;
- if (p->status)
- set_string (&block, &post_block, ioparm_status,
- ioparm_status_len, p->status);
+ if (p->iomsg)
+ mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+ p->iomsg);
if (p->iostat)
- set_parameter_ref (&block, ioparm_iostat, p->iostat);
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
+ p->iostat);
if (p->err)
- set_flag (&block, ioparm_err);
+ mask |= IOPARM_common_err;
+
+ if (p->status)
+ mask |= set_string (&block, &post_block, var, IOPARM_close_status,
+ p->status);
+
+ set_parameter_const (&block, var, IOPARM_common_flags, mask);
- tmp = gfc_build_function_call (iocall_close, NULL_TREE);
+ if (p->unit)
+ set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
+ else
+ set_parameter_const (&block, var, IOPARM_common_unit, 0);
+
+ tmp = gfc_build_addr_expr (NULL_TREE, var);
+ tmp = build_call_expr_loc (input_location,
+ iocall[IOCALL_CLOSE], 1, tmp);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &post_block);
- io_result (&block, p->err, NULL, NULL);
+ io_result (&block, var, p->err, NULL, NULL);
return gfc_finish_block (&block);
}
static tree
build_filepos (tree function, gfc_code * code)
{
- stmtblock_t block;
+ stmtblock_t block, post_block;
gfc_filepos *p;
- tree tmp;
+ tree tmp, var;
+ unsigned int mask = 0;
p = code->ext.filepos;
- gfc_init_block (&block);
+ gfc_start_block (&block);
+ gfc_init_block (&post_block);
- set_error_locus (&block, &code->loc);
+ var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type,
+ "filepos_parm");
- if (p->unit)
- set_parameter_value (&block, ioparm_unit, p->unit);
+ set_error_locus (&block, var, &code->loc);
+
+ if (p->iomsg)
+ mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+ p->iomsg);
if (p->iostat)
- set_parameter_ref (&block, ioparm_iostat, p->iostat);
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
+ p->iostat);
if (p->err)
- set_flag (&block, ioparm_err);
+ mask |= IOPARM_common_err;
+
+ set_parameter_const (&block, var, IOPARM_common_flags, mask);
+
+ if (p->unit)
+ set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
+ else
+ set_parameter_const (&block, var, IOPARM_common_unit, 0);
- tmp = gfc_build_function_call (function, NULL);
+ tmp = gfc_build_addr_expr (NULL_TREE, var);
+ tmp = build_call_expr_loc (input_location,
+ function, 1, tmp);
gfc_add_expr_to_block (&block, tmp);
- io_result (&block, p->err, NULL, NULL);
+ gfc_add_block_to_block (&block, &post_block);
+
+ io_result (&block, var, p->err, NULL, NULL);
return gfc_finish_block (&block);
}
tree
gfc_trans_backspace (gfc_code * code)
{
-
- return build_filepos (iocall_backspace, code);
+ return build_filepos (iocall[IOCALL_BACKSPACE], code);
}
tree
gfc_trans_endfile (gfc_code * code)
{
-
- return build_filepos (iocall_endfile, code);
+ return build_filepos (iocall[IOCALL_ENDFILE], code);
}
tree
gfc_trans_rewind (gfc_code * code)
{
+ return build_filepos (iocall[IOCALL_REWIND], code);
+}
- return build_filepos (iocall_rewind, code);
+
+/* Translate a FLUSH statement. */
+
+tree
+gfc_trans_flush (gfc_code * code)
+{
+ return build_filepos (iocall[IOCALL_FLUSH], code);
+}
+
+
+/* Create a dummy iostat variable to catch any error due to bad unit. */
+
+static gfc_expr *
+create_dummy_iostat (void)
+{
+ gfc_symtree *st;
+ gfc_expr *e;
+
+ gfc_get_ha_sym_tree ("@iostat", &st);
+ st->n.sym->ts.type = BT_INTEGER;
+ st->n.sym->ts.kind = gfc_default_integer_kind;
+ gfc_set_sym_referenced (st->n.sym);
+ gfc_commit_symbol (st->n.sym);
+ st->n.sym->backend_decl
+ = gfc_create_var (gfc_get_int_type (st->n.sym->ts.kind),
+ st->n.sym->name);
+
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_VARIABLE;
+ e->symtree = st;
+ e->ts.type = BT_INTEGER;
+ e->ts.kind = st->n.sym->ts.kind;
+
+ return e;
}
{
stmtblock_t block, post_block;
gfc_inquire *p;
- tree tmp;
+ tree tmp, var;
+ unsigned int mask = 0, mask2 = 0;
- gfc_init_block (&block);
+ gfc_start_block (&block);
gfc_init_block (&post_block);
- set_error_locus (&block, &code->loc);
- p = code->ext.inquire;
+ var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type,
+ "inquire_parm");
- if (p->unit)
- set_parameter_value (&block, ioparm_unit, p->unit);
+ set_error_locus (&block, var, &code->loc);
+ p = code->ext.inquire;
- if (p->file)
- set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
+ if (p->iomsg)
+ mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+ p->iomsg);
if (p->iostat)
- set_parameter_ref (&block, ioparm_iostat, p->iostat);
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
+ p->iostat);
+
+ if (p->err)
+ mask |= IOPARM_common_err;
+
+ /* Sanity check. */
+ if (p->unit && p->file)
+ gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc);
+
+ if (p->file)
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_file,
+ p->file);
if (p->exist)
- set_parameter_ref (&block, ioparm_exist, p->exist);
+ {
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist,
+ p->exist);
+
+ if (p->unit && !p->iostat)
+ {
+ p->iostat = create_dummy_iostat ();
+ mask |= set_parameter_ref (&block, &post_block, var,
+ IOPARM_common_iostat, p->iostat);
+ }
+ }
if (p->opened)
- set_parameter_ref (&block, ioparm_opened, p->opened);
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened,
+ p->opened);
if (p->number)
- set_parameter_ref (&block, ioparm_number, p->number);
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number,
+ p->number);
if (p->named)
- set_parameter_ref (&block, ioparm_named, p->named);
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named,
+ p->named);
if (p->name)
- set_string (&block, &post_block, ioparm_name, ioparm_name_len, p->name);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_name,
+ p->name);
if (p->access)
- set_string (&block, &post_block, ioparm_access,
- ioparm_access_len, p->access);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_access,
+ p->access);
if (p->sequential)
- set_string (&block, &post_block, ioparm_sequential,
- ioparm_sequential_len, p->sequential);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential,
+ p->sequential);
if (p->direct)
- set_string (&block, &post_block, ioparm_direct,
- ioparm_direct_len, p->direct);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct,
+ p->direct);
if (p->form)
- set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_form,
+ p->form);
if (p->formatted)
- set_string (&block, &post_block, ioparm_formatted,
- ioparm_formatted_len, p->formatted);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted,
+ p->formatted);
if (p->unformatted)
- set_string (&block, &post_block, ioparm_unformatted,
- ioparm_unformatted_len, p->unformatted);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted,
+ p->unformatted);
if (p->recl)
- set_parameter_ref (&block, ioparm_recl_out, p->recl);
+ mask |= set_parameter_ref (&block, &post_block, var,
+ IOPARM_inquire_recl_out, p->recl);
if (p->nextrec)
- set_parameter_ref (&block, ioparm_nextrec, p->nextrec);
+ mask |= set_parameter_ref (&block, &post_block, var,
+ IOPARM_inquire_nextrec, p->nextrec);
if (p->blank)
- set_string (&block, &post_block, ioparm_blank, ioparm_blank_len,
- p->blank);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
+ p->blank);
+
+ if (p->delim)
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
+ p->delim);
if (p->position)
- set_string (&block, &post_block, ioparm_position,
- ioparm_position_len, p->position);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_position,
+ p->position);
if (p->action)
- set_string (&block, &post_block, ioparm_action,
- ioparm_action_len, p->action);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_action,
+ p->action);
if (p->read)
- set_string (&block, &post_block, ioparm_read, ioparm_read_len, p->read);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_read,
+ p->read);
if (p->write)
- set_string (&block, &post_block, ioparm_write,
- ioparm_write_len, p->write);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_write,
+ p->write);
if (p->readwrite)
- set_string (&block, &post_block, ioparm_readwrite,
- ioparm_readwrite_len, p->readwrite);
-
- if (p->delim)
- set_string (&block, &post_block, ioparm_delim, ioparm_delim_len,
- p->delim);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite,
+ p->readwrite);
if (p->pad)
- set_string (&block, &post_block, ioparm_pad, ioparm_pad_len,
- p->pad);
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad,
+ p->pad);
+
+ if (p->convert)
+ mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert,
+ p->convert);
- if (p->err)
- set_flag (&block, ioparm_err);
+ if (p->strm_pos)
+ mask |= set_parameter_ref (&block, &post_block, var,
+ IOPARM_inquire_strm_pos_out, p->strm_pos);
- tmp = gfc_build_function_call (iocall_inquire, NULL);
+ /* The second series of flags. */
+ if (p->asynchronous)
+ mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_asynchronous,
+ p->asynchronous);
+
+ if (p->decimal)
+ mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_decimal,
+ p->decimal);
+
+ if (p->encoding)
+ mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_encoding,
+ p->encoding);
+
+ if (p->round)
+ mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_round,
+ p->round);
+
+ if (p->sign)
+ mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_sign,
+ p->sign);
+
+ if (p->pending)
+ mask2 |= set_parameter_ref (&block, &post_block, var,
+ IOPARM_inquire_pending, p->pending);
+
+ if (p->size)
+ mask2 |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_size,
+ p->size);
+
+ if (p->id)
+ mask2 |= set_parameter_ref (&block, &post_block,var, IOPARM_inquire_id,
+ p->id);
+
+ if (mask2)
+ mask |= set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2);
+
+ set_parameter_const (&block, var, IOPARM_common_flags, mask);
+
+ if (p->unit)
+ set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
+ else
+ set_parameter_const (&block, var, IOPARM_common_unit, 0);
+
+ tmp = gfc_build_addr_expr (NULL_TREE, var);
+ tmp = build_call_expr_loc (input_location,
+ iocall[IOCALL_INQUIRE], 1, tmp);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &post_block);
- io_result (&block, p->err, NULL, NULL);
+ io_result (&block, var, p->err, NULL, NULL);
return gfc_finish_block (&block);
}
-static gfc_expr *
-gfc_new_nml_name_expr (const char * name)
+tree
+gfc_trans_wait (gfc_code * code)
{
- gfc_expr * nml_name;
- nml_name = gfc_get_expr();
- nml_name->ref = NULL;
- nml_name->expr_type = EXPR_CONSTANT;
- nml_name->ts.kind = gfc_default_character_kind;
- nml_name->ts.type = BT_CHARACTER;
- nml_name->value.character.length = strlen(name);
- nml_name->value.character.string = gfc_getmem (strlen (name) + 1);
- strcpy (nml_name->value.character.string, name);
-
- return nml_name;
+ stmtblock_t block, post_block;
+ gfc_wait *p;
+ tree tmp, var;
+ unsigned int mask = 0;
+
+ gfc_start_block (&block);
+ gfc_init_block (&post_block);
+
+ var = gfc_create_var (st_parameter[IOPARM_ptype_wait].type,
+ "wait_parm");
+
+ set_error_locus (&block, var, &code->loc);
+ p = code->ext.wait;
+
+ /* Set parameters here. */
+ if (p->iomsg)
+ mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+ p->iomsg);
+
+ if (p->iostat)
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
+ p->iostat);
+
+ if (p->err)
+ mask |= IOPARM_common_err;
+
+ if (p->id)
+ mask |= set_parameter_value (&block, var, IOPARM_wait_id, p->id);
+
+ set_parameter_const (&block, var, IOPARM_common_flags, mask);
+
+ if (p->unit)
+ set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
+
+ tmp = gfc_build_addr_expr (NULL_TREE, var);
+ tmp = build_call_expr_loc (input_location,
+ iocall[IOCALL_WAIT], 1, tmp);
+ gfc_add_expr_to_block (&block, tmp);
+
+ gfc_add_block_to_block (&block, &post_block);
+
+ io_result (&block, var, p->err, NULL, NULL);
+
+ return gfc_finish_block (&block);
+
}
-static gfc_expr *
-get_new_var_expr(gfc_symbol * sym)
+
+/* nml_full_name builds up the fully qualified name of a
+ derived type component. */
+
+static char*
+nml_full_name (const char* var_name, const char* cmp_name)
{
- gfc_expr * nml_var;
-
- nml_var = gfc_get_expr();
- nml_var->expr_type = EXPR_VARIABLE;
- nml_var->ts = sym->ts;
- if (sym->as)
- nml_var->rank = sym->as->rank;
- nml_var->symtree = (gfc_symtree *)gfc_getmem (sizeof (gfc_symtree));
- nml_var->symtree->n.sym = sym;
- nml_var->where = sym->declared_at;
- sym->attr.referenced = 1;
-
- return nml_var;
+ int full_name_length;
+ char * full_name;
+
+ full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
+ full_name = (char*)gfc_getmem (full_name_length + 1);
+ strcpy (full_name, var_name);
+ full_name = strcat (full_name, "%");
+ full_name = strcat (full_name, cmp_name);
+ return full_name;
}
-/* For a scalar variable STRING whose address is ADDR_EXPR, generate a
- call to iocall_set_nml_val. For derived type variable, recursively
- generate calls to iocall_set_nml_val for each leaf field. The leafs
- have no names -- their STRING field is null, and are interpreted by
- the run-time library as having only the value, as in the example:
+/* nml_get_addr_expr builds an address expression from the
+ gfc_symbol or gfc_component backend_decl's. An offset is
+ provided so that the address of an element of an array of
+ derived types is returned. This is used in the runtime to
+ determine that span of the derived type. */
+
+static tree
+nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
+ tree base_addr)
+{
+ tree decl = NULL_TREE;
+ tree tmp;
+ tree itmp;
+ int array_flagged;
+ int dummy_arg_flagged;
+
+ if (sym)
+ {
+ sym->attr.referenced = 1;
+ decl = gfc_get_symbol_decl (sym);
+
+ /* If this is the enclosing function declaration, use
+ the fake result instead. */
+ if (decl == current_function_decl)
+ decl = gfc_get_fake_result_decl (sym, 0);
+ else if (decl == DECL_CONTEXT (current_function_decl))
+ decl = gfc_get_fake_result_decl (sym, 1);
+ }
+ else
+ decl = c->backend_decl;
+
+ gcc_assert (decl && ((TREE_CODE (decl) == FIELD_DECL
+ || TREE_CODE (decl) == VAR_DECL
+ || TREE_CODE (decl) == PARM_DECL)
+ || TREE_CODE (decl) == COMPONENT_REF));
+
+ tmp = decl;
- &foo bzz=1,2,3,4,5/
+ /* Build indirect reference, if dummy argument. */
- Note that the first output field appears after the name of the
- variable, not of the field name. This causes a little complication
- documented below. */
+ dummy_arg_flagged = POINTER_TYPE_P (TREE_TYPE(tmp));
+
+ itmp = (dummy_arg_flagged) ? build_fold_indirect_ref_loc (input_location,
+ tmp) : tmp;
+
+ /* If an array, set flag and use indirect ref. if built. */
+
+ array_flagged = (TREE_CODE (TREE_TYPE (itmp)) == ARRAY_TYPE
+ && !TYPE_STRING_FLAG (TREE_TYPE (itmp)));
+
+ if (array_flagged)
+ tmp = itmp;
+
+ /* Treat the component of a derived type, using base_addr for
+ the derived type. */
+
+ if (TREE_CODE (decl) == FIELD_DECL)
+ tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
+ base_addr, tmp, NULL_TREE);
+
+ /* If we have a derived type component, a reference to the first
+ element of the array is built. This is done so that base_addr,
+ used in the build of the component reference, always points to
+ a RECORD_TYPE. */
+
+ if (array_flagged)
+ tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
+
+ /* Now build the address expression. */
+
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+
+ /* If scalar dummy, resolve indirect reference now. */
+
+ if (dummy_arg_flagged && !array_flagged)
+ tmp = build_fold_indirect_ref_loc (input_location,
+ tmp);
+
+ gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
+
+ return tmp;
+}
+
+/* For an object VAR_NAME whose base address is BASE_ADDR, generate a
+ call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
+ generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
+
+#define IARG(i) build_int_cst (gfc_array_index_type, i)
static void
-transfer_namelist_element (stmtblock_t * block, gfc_typespec * ts, tree addr_expr,
- tree string, tree string_length)
+transfer_namelist_element (stmtblock_t * block, const char * var_name,
+ gfc_symbol * sym, gfc_component * c,
+ tree base_addr)
{
- tree tmp, args, arg2;
- tree expr;
+ gfc_typespec * ts = NULL;
+ gfc_array_spec * as = NULL;
+ tree addr_expr = NULL;
+ tree dt = NULL;
+ tree string;
+ tree tmp;
+ tree dtype;
+ tree dt_parm_addr;
+ int n_dim;
+ int itype;
+ int rank = 0;
- gcc_assert (POINTER_TYPE_P (TREE_TYPE (addr_expr)));
+ gcc_assert (sym || c);
- if (ts->type == BT_DERIVED)
- {
- gfc_component *c;
- expr = gfc_build_indirect_ref (addr_expr);
-
- for (c = ts->derived->components; c; c = c->next)
- {
- tree field = c->backend_decl;
- gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
- tmp = build3 (COMPONENT_REF, TREE_TYPE (field),
- expr, field, NULL_TREE);
-
- if (c->dimension)
- gfc_todo_error ("NAMELIST IO of array in derived type");
- if (!c->pointer)
- tmp = gfc_build_addr_expr (NULL, tmp);
- transfer_namelist_element (block, &c->ts, tmp, string, string_length);
-
- /* The first output field bears the name of the topmost
- derived type variable. All other fields are anonymous
- and appear with nulls in their string and string_length
- fields. After the first use, we set string and
- string_length to null. */
- string = null_pointer_node;
- string_length = integer_zero_node;
- }
+ /* Build the namelist object name. */
- return;
- }
+ string = gfc_build_cstring_const (var_name);
+ string = gfc_build_addr_expr (pchar_type_node, string);
- args = gfc_chainon_list (NULL_TREE, addr_expr);
- args = gfc_chainon_list (args, string);
- args = gfc_chainon_list (args, string_length);
- arg2 = build_int_cst (gfc_array_index_type, ts->kind);
- args = gfc_chainon_list (args,arg2);
+ /* Build ts, as and data address using symbol or component. */
- switch (ts->type)
- {
- case BT_INTEGER:
- tmp = gfc_build_function_call (iocall_set_nml_val_int, args);
- break;
+ ts = (sym) ? &sym->ts : &c->ts;
+ as = (sym) ? sym->as : c->as;
- case BT_CHARACTER:
- expr = gfc_build_indirect_ref (addr_expr);
- gcc_assert (TREE_CODE (TREE_TYPE (expr)) == ARRAY_TYPE);
- args = gfc_chainon_list (args,
- TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (expr))));
- tmp = gfc_build_function_call (iocall_set_nml_val_char, args);
- break;
+ addr_expr = nml_get_addr_expr (sym, c, base_addr);
- case BT_REAL:
- tmp = gfc_build_function_call (iocall_set_nml_val_float, args);
- break;
+ if (as)
+ rank = as->rank;
- case BT_LOGICAL:
- tmp = gfc_build_function_call (iocall_set_nml_val_log, args);
- break;
+ if (rank)
+ {
+ dt = TREE_TYPE ((sym) ? sym->backend_decl : c->backend_decl);
+ dtype = gfc_get_dtype (dt);
+ }
+ else
+ {
+ itype = GFC_DTYPE_UNKNOWN;
- case BT_COMPLEX:
- tmp = gfc_build_function_call (iocall_set_nml_val_complex, args);
- break;
+ switch (ts->type)
- default :
- internal_error ("Bad namelist IO basetype (%d)", ts->type);
+ {
+ case BT_INTEGER:
+ itype = GFC_DTYPE_INTEGER;
+ break;
+ case BT_LOGICAL:
+ itype = GFC_DTYPE_LOGICAL;
+ break;
+ case BT_REAL:
+ itype = GFC_DTYPE_REAL;
+ break;
+ case BT_COMPLEX:
+ itype = GFC_DTYPE_COMPLEX;
+ break;
+ case BT_DERIVED:
+ itype = GFC_DTYPE_DERIVED;
+ break;
+ case BT_CHARACTER:
+ itype = GFC_DTYPE_CHARACTER;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+
+ dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
}
+ /* Build up the arguments for the transfer call.
+ The call for the scalar part transfers:
+ (address, name, type, kind or string_length, dtype) */
+
+ dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
+
+ 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,
+ IARG (ts->kind), tmp, dtype);
gfc_add_expr_to_block (block, tmp);
+
+ /* If the object is an array, transfer rank times:
+ (null pointer, name, stride, lbound, ubound) */
+
+ for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
+ {
+ tmp = build_call_expr_loc (input_location,
+ iocall[IOCALL_SET_NML_VAL_DIM], 5,
+ dt_parm_addr,
+ IARG (n_dim),
+ GFC_TYPE_ARRAY_STRIDE (dt, n_dim),
+ GFC_TYPE_ARRAY_LBOUND (dt, n_dim),
+ GFC_TYPE_ARRAY_UBOUND (dt, n_dim));
+ gfc_add_expr_to_block (block, tmp);
+ }
+
+ if (ts->type == BT_DERIVED)
+ {
+ gfc_component *cmp;
+
+ /* Provide the RECORD_TYPE to build component references. */
+
+ tree expr = build_fold_indirect_ref_loc (input_location,
+ addr_expr);
+
+ for (cmp = ts->u.derived->components; cmp; cmp = cmp->next)
+ {
+ char *full_name = nml_full_name (var_name, cmp->name);
+ transfer_namelist_element (block,
+ full_name,
+ NULL, cmp, expr);
+ gfc_free (full_name);
+ }
+ }
}
+#undef IARG
+
/* Create a data transfer statement. Not all of the fields are valid
for both reading and writing, but improper use has been filtered
out by now. */
static tree
-build_dt (tree * function, gfc_code * code)
+build_dt (tree function, gfc_code * code)
{
- stmtblock_t block, post_block;
+ stmtblock_t block, post_block, post_end_block, post_iu_block;
gfc_dt *dt;
- tree tmp;
- gfc_expr *nmlname, *nmlvar;
+ tree tmp, var;
+ gfc_expr *nmlname;
gfc_namelist *nml;
- gfc_se se,se2;
+ unsigned int mask = 0;
- gfc_init_block (&block);
+ gfc_start_block (&block);
gfc_init_block (&post_block);
+ gfc_init_block (&post_end_block);
+ gfc_init_block (&post_iu_block);
+
+ var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
+
+ set_error_locus (&block, var, &code->loc);
- set_error_locus (&block, &code->loc);
- dt = code->ext.dt;
+ if (last_dt == IOLENGTH)
+ {
+ gfc_inquire *inq;
+
+ inq = code->ext.inquire;
- gcc_assert (dt != NULL);
+ /* First check that preconditions are met. */
+ gcc_assert (inq != NULL);
+ gcc_assert (inq->iolength != NULL);
+
+ /* Connect to the iolength variable. */
+ mask |= set_parameter_ref (&block, &post_end_block, var,
+ IOPARM_dt_iolength, inq->iolength);
+ dt = NULL;
+ }
+ else
+ {
+ dt = code->ext.dt;
+ gcc_assert (dt != NULL);
+ }
- if (dt->io_unit)
+ if (dt && dt->io_unit)
{
if (dt->io_unit->ts.type == BT_CHARACTER)
{
- set_string (&block, &post_block, ioparm_internal_unit,
- ioparm_internal_unit_len, dt->io_unit);
+ mask |= set_internal_unit (&block, &post_iu_block,
+ var, dt->io_unit);
+ set_parameter_const (&block, var, IOPARM_common_unit, 0);
}
- else
- set_parameter_value (&block, ioparm_unit, dt->io_unit);
}
+ else
+ set_parameter_const (&block, var, IOPARM_common_unit, 0);
- if (dt->rec)
- set_parameter_value (&block, ioparm_rec, dt->rec);
+ if (dt)
+ {
+ if (dt->iomsg)
+ mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
+ dt->iomsg);
- if (dt->advance)
- set_string (&block, &post_block, ioparm_advance, ioparm_advance_len,
- dt->advance);
+ if (dt->iostat)
+ mask |= set_parameter_ref (&block, &post_end_block, var,
+ IOPARM_common_iostat, dt->iostat);
- if (dt->format_expr)
- set_string (&block, &post_block, ioparm_format, ioparm_format_len,
- dt->format_expr);
+ if (dt->err)
+ mask |= IOPARM_common_err;
- if (dt->format_label)
- {
- if (dt->format_label == &format_asterisk)
- set_flag (&block, ioparm_list_format);
- else
- set_string (&block, &post_block, ioparm_format,
- ioparm_format_len, dt->format_label->format);
- }
+ if (dt->eor)
+ mask |= IOPARM_common_eor;
- if (dt->iostat)
- set_parameter_ref (&block, ioparm_iostat, dt->iostat);
+ if (dt->end)
+ mask |= IOPARM_common_end;
- if (dt->size)
- set_parameter_ref (&block, ioparm_size, dt->size);
+ if (dt->id)
+ mask |= set_parameter_ref (&block, &post_end_block, var,
+ IOPARM_dt_id, dt->id);
- if (dt->err)
- set_flag (&block, ioparm_err);
+ if (dt->pos)
+ mask |= set_parameter_value (&block, var, IOPARM_dt_pos, dt->pos);
- if (dt->eor)
- set_flag(&block, ioparm_eor);
+ if (dt->asynchronous)
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_asynchronous,
+ dt->asynchronous);
- if (dt->end)
- set_flag(&block, ioparm_end);
+ if (dt->blank)
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_blank,
+ dt->blank);
- if (dt->namelist)
- {
- if (dt->format_expr || dt->format_label)
- fatal_error("A format cannot be specified with a namelist");
-
- nmlname = gfc_new_nml_name_expr(dt->namelist->name);
-
- set_string (&block, &post_block, ioparm_namelist_name,
- ioparm_namelist_name_len, nmlname);
-
- if (last_dt == READ)
- set_flag (&block, ioparm_namelist_read_mode);
-
- for (nml = dt->namelist->namelist; nml; nml = nml->next)
- {
- gfc_init_se (&se, NULL);
- gfc_init_se (&se2, NULL);
- nmlvar = get_new_var_expr (nml->sym);
- nmlname = gfc_new_nml_name_expr (nml->sym->name);
- gfc_conv_expr_reference (&se2, nmlname);
- gfc_conv_expr_reference (&se, nmlvar);
- gfc_evaluate_now (se.expr, &se.pre);
-
- transfer_namelist_element (&block, &nml->sym->ts, se.expr,
- se2.expr, se2.string_length);
- }
+ if (dt->decimal)
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_decimal,
+ dt->decimal);
+
+ if (dt->delim)
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_delim,
+ dt->delim);
+
+ if (dt->pad)
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_pad,
+ dt->pad);
+
+ if (dt->round)
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_round,
+ dt->round);
+
+ if (dt->sign)
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_sign,
+ dt->sign);
+
+ if (dt->rec)
+ mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
+
+ if (dt->advance)
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
+ dt->advance);
+
+ if (dt->format_expr)
+ mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format,
+ dt->format_expr);
+
+ if (dt->format_label)
+ {
+ if (dt->format_label == &format_asterisk)
+ mask |= IOPARM_dt_list_format;
+ else
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
+ dt->format_label->format);
+ }
+
+ if (dt->size)
+ mask |= set_parameter_ref (&block, &post_end_block, var,
+ IOPARM_dt_size, dt->size);
+
+ if (dt->namelist)
+ {
+ if (dt->format_expr || dt->format_label)
+ gfc_internal_error ("build_dt: format with namelist");
+
+ nmlname = gfc_get_character_expr (gfc_default_character_kind, NULL,
+ dt->namelist->name,
+ strlen (dt->namelist->name));
+
+ mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
+ nmlname);
+
+ if (last_dt == READ)
+ mask |= IOPARM_dt_namelist_read_mode;
+
+ set_parameter_const (&block, var, IOPARM_common_flags, mask);
+
+ dt_parm = var;
+
+ for (nml = dt->namelist->namelist; nml; nml = nml->next)
+ transfer_namelist_element (&block, nml->sym->name, nml->sym,
+ NULL, NULL);
+ }
+ else
+ set_parameter_const (&block, var, IOPARM_common_flags, mask);
+
+ if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER)
+ set_parameter_value (&block, var, IOPARM_common_unit, dt->io_unit);
}
+ else
+ set_parameter_const (&block, var, IOPARM_common_flags, mask);
- tmp = gfc_build_function_call (*function, NULL_TREE);
+ tmp = gfc_build_addr_expr (NULL_TREE, var);
+ tmp = build_call_expr_loc (UNKNOWN_LOCATION,
+ function, 1, tmp);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &post_block);
+ dt_parm = var;
+ dt_post_end_block = &post_end_block;
+
+ /* Set implied do loop exit condition. */
+ if (last_dt == READ || last_dt == WRITE)
+ {
+ gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
+
+ tmp = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
+ dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)), NULL_TREE);
+ tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
+ tmp, p->field, NULL_TREE);
+ tmp = fold_build2 (BIT_AND_EXPR, TREE_TYPE (tmp),
+ tmp, build_int_cst (TREE_TYPE (tmp),
+ IOPARM_common_libreturn_mask));
+ }
+ else /* IOLENGTH */
+ tmp = NULL_TREE;
+
+ gfc_add_expr_to_block (&block, gfc_trans_code_cond (code->block->next, tmp));
+
+ gfc_add_block_to_block (&block, &post_iu_block);
+
+ dt_parm = NULL;
+ dt_post_end_block = NULL;
+
return gfc_finish_block (&block);
}
tree
gfc_trans_iolength (gfc_code * code)
{
- stmtblock_t block;
- gfc_inquire *inq;
- tree dt;
-
- gfc_init_block (&block);
-
- set_error_locus (&block, &code->loc);
-
- inq = code->ext.inquire;
-
- /* First check that preconditions are met. */
- gcc_assert (inq != NULL);
- gcc_assert (inq->iolength != NULL);
-
- /* Connect to the iolength variable. */
- if (inq->iolength)
- set_parameter_ref (&block, ioparm_iolength, inq->iolength);
-
- /* Actual logic. */
last_dt = IOLENGTH;
- dt = build_dt(&iocall_iolength, code);
-
- gfc_add_expr_to_block (&block, dt);
-
- return gfc_finish_block (&block);
+ return build_dt (iocall[IOCALL_IOLENGTH], code);
}
tree
gfc_trans_read (gfc_code * code)
{
-
last_dt = READ;
- return build_dt (&iocall_read, code);
+ return build_dt (iocall[IOCALL_READ], code);
}
tree
gfc_trans_write (gfc_code * code)
{
-
last_dt = WRITE;
- return build_dt (&iocall_write, code);
+ return build_dt (iocall[IOCALL_WRITE], code);
}
switch (last_dt)
{
case READ:
- function = iocall_read_done;
+ function = iocall[IOCALL_READ_DONE];
break;
case WRITE:
- function = iocall_write_done;
+ function = iocall[IOCALL_WRITE_DONE];
break;
case IOLENGTH:
- function = iocall_iolength_done;
+ function = iocall[IOCALL_IOLENGTH_DONE];
break;
default:
gcc_unreachable ();
}
- tmp = gfc_build_function_call (function, NULL);
+ tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
+ tmp = build_call_expr_loc (input_location,
+ function, 1, tmp);
gfc_add_expr_to_block (&block, tmp);
+ gfc_add_block_to_block (&block, dt_post_end_block);
+ gfc_init_block (dt_post_end_block);
if (last_dt != IOLENGTH)
{
gcc_assert (code->ext.dt != NULL);
- io_result (&block, code->ext.dt->err,
+ io_result (&block, dt_parm, code->ext.dt->err,
code->ext.dt->end, code->ext.dt->eor);
}
}
static void
-transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr);
+transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code);
/* Given an array field in a derived type variable, generate the code
for the loop that iterates over array elements, and the code that
recursive. */
static tree
-transfer_array_component (tree expr, gfc_component * cm)
+transfer_array_component (tree expr, gfc_component * cm, locus * where)
{
tree tmp;
stmtblock_t body;
gfc_init_loopinfo (&loop);
gfc_add_ss_to_loop (&loop, ss);
gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop);
+ gfc_conv_loop_setup (&loop, where);
gfc_mark_ss_chain_used (ss, 1);
gfc_start_scalarized_body (&loop, &body);
/* 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, se.expr);
- transfer_expr (&se, &cm->ts, tmp);
+ tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
+ transfer_expr (&se, &cm->ts, tmp, NULL);
/* We are done now with the loop body. Wrap up the scalarizer and
return. */
/* Generate the call for a scalar transfer node. */
static void
-transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
+transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
{
- tree args, tmp, function, arg2, field, expr;
+ tree tmp, function, arg2, arg3, field, expr;
gfc_component *c;
int kind;
+ /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
+ the user says something like: print *, 'c_null_ptr: ', c_null_ptr
+ We need to translate the expression to a constant if it's either
+ C_NULL_PTR or C_NULL_FUNPTR. We could also get a user variable of
+ type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
+ BT_DERIVED (could have been changed by gfc_conv_expr). */
+ if ((ts->type == BT_DERIVED || ts->type == BT_INTEGER)
+ && ts->u.derived != NULL
+ && (ts->is_iso_c == 1 || ts->u.derived->ts.is_iso_c == 1))
+ {
+ /* C_PTR and C_FUNPTR have private components which means they can not
+ be printed. However, if -std=gnu and not -pedantic, allow
+ the component to be printed to help debugging. */
+ if (gfc_notification_std (GFC_STD_GNU) != SILENT)
+ {
+ gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
+ ts->u.derived->name, code != NULL ? &(code->loc) :
+ &gfc_current_locus);
+ return;
+ }
+
+ ts->type = ts->u.derived->ts.type;
+ ts->kind = ts->u.derived->ts.kind;
+ ts->f90_type = ts->u.derived->ts.f90_type;
+ }
+
kind = ts->kind;
function = NULL;
arg2 = NULL;
+ arg3 = NULL;
switch (ts->type)
{
case BT_INTEGER:
arg2 = build_int_cst (NULL_TREE, kind);
- function = iocall_x_integer;
+ function = iocall[IOCALL_X_INTEGER];
break;
case BT_REAL:
arg2 = build_int_cst (NULL_TREE, kind);
- function = iocall_x_real;
+ function = iocall[IOCALL_X_REAL];
break;
case BT_COMPLEX:
arg2 = build_int_cst (NULL_TREE, kind);
- function = iocall_x_complex;
+ function = iocall[IOCALL_X_COMPLEX];
break;
case BT_LOGICAL:
arg2 = build_int_cst (NULL_TREE, kind);
- function = iocall_x_logical;
+ function = iocall[IOCALL_X_LOGICAL];
break;
case BT_CHARACTER:
+ if (kind == 4)
+ {
+ if (se->string_length)
+ arg2 = se->string_length;
+ else
+ {
+ tmp = build_fold_indirect_ref_loc (input_location,
+ addr_expr);
+ gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
+ arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
+ arg2 = fold_convert (gfc_charlen_type_node, arg2);
+ }
+ arg3 = build_int_cst (NULL_TREE, kind);
+ function = iocall[IOCALL_X_CHARACTER_WIDE];
+ tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
+ tmp = build_call_expr_loc (input_location,
+ function, 4, tmp, addr_expr, arg2, arg3);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ gfc_add_block_to_block (&se->pre, &se->post);
+ return;
+ }
+ /* Fall through. */
+ case BT_HOLLERITH:
if (se->string_length)
arg2 = se->string_length;
else
{
- tmp = gfc_build_indirect_ref (addr_expr);
+ tmp = build_fold_indirect_ref_loc (input_location,
+ addr_expr);
gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
}
- function = iocall_x_character;
+ function = iocall[IOCALL_X_CHARACTER];
break;
case BT_DERIVED:
/* Recurse into the elements of the derived type. */
expr = gfc_evaluate_now (addr_expr, &se->pre);
- expr = gfc_build_indirect_ref (expr);
+ expr = build_fold_indirect_ref_loc (input_location,
+ expr);
- for (c = ts->derived->components; c; c = c->next)
+ for (c = ts->u.derived->components; c; c = c->next)
{
field = c->backend_decl;
gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
- tmp = build3 (COMPONENT_REF, TREE_TYPE (field), expr, field,
- NULL_TREE);
+ tmp = fold_build3_loc (UNKNOWN_LOCATION,
+ COMPONENT_REF, TREE_TYPE (field),
+ expr, field, NULL_TREE);
- if (c->dimension)
+ if (c->attr.dimension)
{
- tmp = transfer_array_component (tmp, c);
+ tmp = transfer_array_component (tmp, c, & code->loc);
gfc_add_expr_to_block (&se->pre, tmp);
}
else
{
- if (!c->pointer)
- tmp = gfc_build_addr_expr (NULL, tmp);
- transfer_expr (se, &c->ts, tmp);
+ if (!c->attr.pointer)
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+ transfer_expr (se, &c->ts, tmp, code);
}
}
return;
internal_error ("Bad IO basetype (%d)", ts->type);
}
- args = gfc_chainon_list (NULL_TREE, addr_expr);
- args = gfc_chainon_list (args, arg2);
-
- tmp = gfc_build_function_call (function, args);
+ tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
+ tmp = build_call_expr_loc (input_location,
+ function, 3, tmp, addr_expr, arg2);
gfc_add_expr_to_block (&se->pre, tmp);
gfc_add_block_to_block (&se->pre, &se->post);
}
+/* Generate a call to pass an array descriptor to the IO library. The
+ array should be of one of the intrinsic types. */
+
+static void
+transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
+{
+ tree tmp, charlen_arg, kind_arg;
+
+ if (ts->type == BT_CHARACTER)
+ charlen_arg = se->string_length;
+ else
+ charlen_arg = build_int_cst (NULL_TREE, 0);
+
+ kind_arg = build_int_cst (NULL_TREE, ts->kind);
+
+ tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
+ tmp = build_call_expr_loc (UNKNOWN_LOCATION,
+ iocall[IOCALL_X_ARRAY], 4,
+ tmp, addr_expr, kind_arg, charlen_arg);
+ gfc_add_expr_to_block (&se->pre, tmp);
+ gfc_add_block_to_block (&se->pre, &se->post);
+}
+
+
/* gfc_trans_transfer()-- Translate a TRANSFER code node */
tree
stmtblock_t block, body;
gfc_loopinfo loop;
gfc_expr *expr;
+ gfc_ref *ref;
gfc_ss *ss;
gfc_se se;
tree tmp;
+ int n;
gfc_start_block (&block);
+ gfc_init_block (&body);
- expr = code->expr;
+ expr = code->expr1;
ss = gfc_walk_expr (expr);
+ ref = NULL;
gfc_init_se (&se, NULL);
if (ss == gfc_ss_terminator)
- gfc_init_block (&body);
+ {
+ /* Transfer a scalar value. */
+ gfc_conv_expr_reference (&se, expr);
+ transfer_expr (&se, &expr->ts, se.expr, code);
+ }
else
{
+ /* Transfer an array. If it is an array of an intrinsic
+ type, pass the descriptor to the library. Otherwise
+ scalarize the transfer. */
+ if (expr->ref && !gfc_is_proc_ptr_comp (expr, NULL))
+ {
+ for (ref = expr->ref; ref && ref->type != REF_ARRAY;
+ ref = ref->next);
+ gcc_assert (ref->type == REF_ARRAY);
+ }
+
+ if (expr->ts.type != BT_DERIVED
+ && ref && ref->next == NULL
+ && !is_subref_array (expr))
+ {
+ bool seen_vector = false;
+
+ if (ref && ref->u.ar.type == AR_SECTION)
+ {
+ for (n = 0; n < ref->u.ar.dimen; n++)
+ if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
+ seen_vector = true;
+ }
+
+ if (seen_vector && last_dt == READ)
+ {
+ /* Create a temp, read to that and copy it back. */
+ gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT, false);
+ tmp = se.expr;
+ }
+ else
+ {
+ /* Get the descriptor. */
+ gfc_conv_expr_descriptor (&se, expr, ss);
+ tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
+ }
+
+ transfer_array_desc (&se, &expr->ts, tmp);
+ goto finish_block_label;
+ }
+
/* Initialize the scalarizer. */
gfc_init_loopinfo (&loop);
gfc_add_ss_to_loop (&loop, ss);
/* Initialize the loop. */
gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop);
+ gfc_conv_loop_setup (&loop, &code->expr1->where);
/* The main loop body. */
gfc_mark_ss_chain_used (ss, 1);
gfc_copy_loopinfo_to_se (&se, &loop);
se.ss = ss;
- }
- gfc_conv_expr_reference (&se, expr);
+ gfc_conv_expr_reference (&se, expr);
+ transfer_expr (&se, &expr->ts, se.expr, code);
+ }
- transfer_expr (&se, &expr->ts, se.expr);
+ finish_block_label:
gfc_add_block_to_block (&body, &se.pre);
gfc_add_block_to_block (&body, &se.post);
}
#include "gt-fortran-trans-io.h"
-
OSDN Git Service
