/* IO Code translation/library interface
|
/* IO Code translation/library interface
|
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
|
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
|
Free Software Foundation, Inc.
|
Free Software Foundation, Inc.
|
Contributed by Paul Brook
|
Contributed by Paul Brook
|
|
|
This file is part of GCC.
|
This file is part of GCC.
|
|
|
GCC is free software; you can redistribute it and/or modify it under
|
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
|
the terms of the GNU General Public License as published by the Free
|
Software Foundation; either version 3, or (at your option) any later
|
Software Foundation; either version 3, or (at your option) any later
|
version.
|
version.
|
|
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
for more details.
|
for more details.
|
|
|
You should have received a copy of the GNU General Public License
|
You should have received a copy of the GNU General Public License
|
along with GCC; see the file COPYING3. If not see
|
along with GCC; see the file COPYING3. If not see
|
<http://www.gnu.org/licenses/>. */
|
<http://www.gnu.org/licenses/>. */
|
|
|
|
|
#include "config.h"
|
#include "config.h"
|
#include "system.h"
|
#include "system.h"
|
#include "coretypes.h"
|
#include "coretypes.h"
|
#include "tree.h"
|
#include "tree.h"
|
#include "gimple.h"
|
#include "gimple.h"
|
#include "ggc.h"
|
#include "ggc.h"
|
#include "toplev.h"
|
#include "toplev.h"
|
#include "real.h"
|
#include "real.h"
|
#include "gfortran.h"
|
#include "gfortran.h"
|
#include "trans.h"
|
#include "trans.h"
|
#include "trans-stmt.h"
|
#include "trans-stmt.h"
|
#include "trans-array.h"
|
#include "trans-array.h"
|
#include "trans-types.h"
|
#include "trans-types.h"
|
#include "trans-const.h"
|
#include "trans-const.h"
|
|
|
/* Members of the ioparm structure. */
|
/* Members of the ioparm structure. */
|
|
|
enum ioparam_type
|
enum ioparam_type
|
{
|
{
|
IOPARM_ptype_common,
|
IOPARM_ptype_common,
|
IOPARM_ptype_open,
|
IOPARM_ptype_open,
|
IOPARM_ptype_close,
|
IOPARM_ptype_close,
|
IOPARM_ptype_filepos,
|
IOPARM_ptype_filepos,
|
IOPARM_ptype_inquire,
|
IOPARM_ptype_inquire,
|
IOPARM_ptype_dt,
|
IOPARM_ptype_dt,
|
IOPARM_ptype_wait,
|
IOPARM_ptype_wait,
|
IOPARM_ptype_num
|
IOPARM_ptype_num
|
};
|
};
|
|
|
enum iofield_type
|
enum iofield_type
|
{
|
{
|
IOPARM_type_int4,
|
IOPARM_type_int4,
|
IOPARM_type_intio,
|
IOPARM_type_intio,
|
IOPARM_type_pint4,
|
IOPARM_type_pint4,
|
IOPARM_type_pintio,
|
IOPARM_type_pintio,
|
IOPARM_type_pchar,
|
IOPARM_type_pchar,
|
IOPARM_type_parray,
|
IOPARM_type_parray,
|
IOPARM_type_pad,
|
IOPARM_type_pad,
|
IOPARM_type_char1,
|
IOPARM_type_char1,
|
IOPARM_type_char2,
|
IOPARM_type_char2,
|
IOPARM_type_common,
|
IOPARM_type_common,
|
IOPARM_type_num
|
IOPARM_type_num
|
};
|
};
|
|
|
typedef struct GTY(()) gfc_st_parameter_field {
|
typedef struct GTY(()) gfc_st_parameter_field {
|
const char *name;
|
const char *name;
|
unsigned int mask;
|
unsigned int mask;
|
enum ioparam_type param_type;
|
enum ioparam_type param_type;
|
enum iofield_type type;
|
enum iofield_type type;
|
tree field;
|
tree field;
|
tree field_len;
|
tree field_len;
|
}
|
}
|
gfc_st_parameter_field;
|
gfc_st_parameter_field;
|
|
|
typedef struct GTY(()) gfc_st_parameter {
|
typedef struct GTY(()) gfc_st_parameter {
|
const char *name;
|
const char *name;
|
tree type;
|
tree type;
|
}
|
}
|
gfc_st_parameter;
|
gfc_st_parameter;
|
|
|
enum iofield
|
enum iofield
|
{
|
{
|
#define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name,
|
#define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name,
|
#include "ioparm.def"
|
#include "ioparm.def"
|
#undef IOPARM
|
#undef IOPARM
|
IOPARM_field_num
|
IOPARM_field_num
|
};
|
};
|
|
|
static GTY(()) gfc_st_parameter st_parameter[] =
|
static GTY(()) gfc_st_parameter st_parameter[] =
|
{
|
{
|
{ "common", NULL },
|
{ "common", NULL },
|
{ "open", NULL },
|
{ "open", NULL },
|
{ "close", NULL },
|
{ "close", NULL },
|
{ "filepos", NULL },
|
{ "filepos", NULL },
|
{ "inquire", NULL },
|
{ "inquire", NULL },
|
{ "dt", NULL },
|
{ "dt", NULL },
|
{ "wait", NULL }
|
{ "wait", NULL }
|
};
|
};
|
|
|
static GTY(()) gfc_st_parameter_field st_parameter_field[] =
|
static GTY(()) gfc_st_parameter_field st_parameter_field[] =
|
{
|
{
|
#define IOPARM(param_type, name, mask, type) \
|
#define IOPARM(param_type, name, mask, type) \
|
{ #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL },
|
{ #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL },
|
#include "ioparm.def"
|
#include "ioparm.def"
|
#undef IOPARM
|
#undef IOPARM
|
{ NULL, 0, (enum ioparam_type) 0, (enum iofield_type) 0, NULL, NULL }
|
{ NULL, 0, (enum ioparam_type) 0, (enum iofield_type) 0, NULL, NULL }
|
};
|
};
|
|
|
/* Library I/O subroutines */
|
/* Library I/O subroutines */
|
|
|
enum iocall
|
enum iocall
|
{
|
{
|
IOCALL_READ,
|
IOCALL_READ,
|
IOCALL_READ_DONE,
|
IOCALL_READ_DONE,
|
IOCALL_WRITE,
|
IOCALL_WRITE,
|
IOCALL_WRITE_DONE,
|
IOCALL_WRITE_DONE,
|
IOCALL_X_INTEGER,
|
IOCALL_X_INTEGER,
|
IOCALL_X_LOGICAL,
|
IOCALL_X_LOGICAL,
|
IOCALL_X_CHARACTER,
|
IOCALL_X_CHARACTER,
|
IOCALL_X_CHARACTER_WIDE,
|
IOCALL_X_CHARACTER_WIDE,
|
IOCALL_X_REAL,
|
IOCALL_X_REAL,
|
IOCALL_X_COMPLEX,
|
IOCALL_X_COMPLEX,
|
IOCALL_X_ARRAY,
|
IOCALL_X_ARRAY,
|
IOCALL_OPEN,
|
IOCALL_OPEN,
|
IOCALL_CLOSE,
|
IOCALL_CLOSE,
|
IOCALL_INQUIRE,
|
IOCALL_INQUIRE,
|
IOCALL_IOLENGTH,
|
IOCALL_IOLENGTH,
|
IOCALL_IOLENGTH_DONE,
|
IOCALL_IOLENGTH_DONE,
|
IOCALL_REWIND,
|
IOCALL_REWIND,
|
IOCALL_BACKSPACE,
|
IOCALL_BACKSPACE,
|
IOCALL_ENDFILE,
|
IOCALL_ENDFILE,
|
IOCALL_FLUSH,
|
IOCALL_FLUSH,
|
IOCALL_SET_NML_VAL,
|
IOCALL_SET_NML_VAL,
|
IOCALL_SET_NML_VAL_DIM,
|
IOCALL_SET_NML_VAL_DIM,
|
IOCALL_WAIT,
|
IOCALL_WAIT,
|
IOCALL_NUM
|
IOCALL_NUM
|
};
|
};
|
|
|
static GTY(()) tree iocall[IOCALL_NUM];
|
static GTY(()) tree iocall[IOCALL_NUM];
|
|
|
/* Variable for keeping track of what the last data transfer statement
|
/* Variable for keeping track of what the last data transfer statement
|
was. Used for deciding which subroutine to call when the data
|
was. Used for deciding which subroutine to call when the data
|
transfer is complete. */
|
transfer is complete. */
|
static enum { READ, WRITE, IOLENGTH } last_dt;
|
static enum { READ, WRITE, IOLENGTH } last_dt;
|
|
|
/* The data transfer parameter block that should be shared by all
|
/* The data transfer parameter block that should be shared by all
|
data transfer calls belonging to the same read/write/iolength. */
|
data transfer calls belonging to the same read/write/iolength. */
|
static GTY(()) tree dt_parm;
|
static GTY(()) tree dt_parm;
|
static stmtblock_t *dt_post_end_block;
|
static stmtblock_t *dt_post_end_block;
|
|
|
static void
|
static void
|
gfc_build_st_parameter (enum ioparam_type ptype, tree *types)
|
gfc_build_st_parameter (enum ioparam_type ptype, tree *types)
|
{
|
{
|
unsigned int type;
|
unsigned int type;
|
gfc_st_parameter_field *p;
|
gfc_st_parameter_field *p;
|
char name[64];
|
char name[64];
|
size_t len;
|
size_t len;
|
tree t = make_node (RECORD_TYPE);
|
tree t = make_node (RECORD_TYPE);
|
|
|
len = strlen (st_parameter[ptype].name);
|
len = strlen (st_parameter[ptype].name);
|
gcc_assert (len <= sizeof (name) - sizeof ("__st_parameter_"));
|
gcc_assert (len <= sizeof (name) - sizeof ("__st_parameter_"));
|
memcpy (name, "__st_parameter_", sizeof ("__st_parameter_"));
|
memcpy (name, "__st_parameter_", sizeof ("__st_parameter_"));
|
memcpy (name + sizeof ("__st_parameter_") - 1, st_parameter[ptype].name,
|
memcpy (name + sizeof ("__st_parameter_") - 1, st_parameter[ptype].name,
|
len + 1);
|
len + 1);
|
TYPE_NAME (t) = get_identifier (name);
|
TYPE_NAME (t) = get_identifier (name);
|
|
|
for (type = 0, p = st_parameter_field; type < IOPARM_field_num; type++, p++)
|
for (type = 0, p = st_parameter_field; type < IOPARM_field_num; type++, p++)
|
if (p->param_type == ptype)
|
if (p->param_type == ptype)
|
switch (p->type)
|
switch (p->type)
|
{
|
{
|
case IOPARM_type_int4:
|
case IOPARM_type_int4:
|
case IOPARM_type_intio:
|
case IOPARM_type_intio:
|
case IOPARM_type_pint4:
|
case IOPARM_type_pint4:
|
case IOPARM_type_pintio:
|
case IOPARM_type_pintio:
|
case IOPARM_type_parray:
|
case IOPARM_type_parray:
|
case IOPARM_type_pchar:
|
case IOPARM_type_pchar:
|
case IOPARM_type_pad:
|
case IOPARM_type_pad:
|
p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
|
p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
|
get_identifier (p->name),
|
get_identifier (p->name),
|
types[p->type]);
|
types[p->type]);
|
break;
|
break;
|
case IOPARM_type_char1:
|
case IOPARM_type_char1:
|
p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
|
p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
|
get_identifier (p->name),
|
get_identifier (p->name),
|
pchar_type_node);
|
pchar_type_node);
|
/* FALLTHROUGH */
|
/* FALLTHROUGH */
|
case IOPARM_type_char2:
|
case IOPARM_type_char2:
|
len = strlen (p->name);
|
len = strlen (p->name);
|
gcc_assert (len <= sizeof (name) - sizeof ("_len"));
|
gcc_assert (len <= sizeof (name) - sizeof ("_len"));
|
memcpy (name, p->name, len);
|
memcpy (name, p->name, len);
|
memcpy (name + len, "_len", sizeof ("_len"));
|
memcpy (name + len, "_len", sizeof ("_len"));
|
p->field_len = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
|
p->field_len = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
|
get_identifier (name),
|
get_identifier (name),
|
gfc_charlen_type_node);
|
gfc_charlen_type_node);
|
if (p->type == IOPARM_type_char2)
|
if (p->type == IOPARM_type_char2)
|
p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
|
p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
|
get_identifier (p->name),
|
get_identifier (p->name),
|
pchar_type_node);
|
pchar_type_node);
|
break;
|
break;
|
case IOPARM_type_common:
|
case IOPARM_type_common:
|
p->field
|
p->field
|
= gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
|
= gfc_add_field_to_struct (&TYPE_FIELDS (t), t,
|
get_identifier (p->name),
|
get_identifier (p->name),
|
st_parameter[IOPARM_ptype_common].type);
|
st_parameter[IOPARM_ptype_common].type);
|
break;
|
break;
|
case IOPARM_type_num:
|
case IOPARM_type_num:
|
gcc_unreachable ();
|
gcc_unreachable ();
|
}
|
}
|
|
|
gfc_finish_type (t);
|
gfc_finish_type (t);
|
st_parameter[ptype].type = t;
|
st_parameter[ptype].type = t;
|
}
|
}
|
|
|
|
|
/* Build code to test an error condition and call generate_error if needed.
|
/* 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.
|
Note: This builds calls to generate_error in the runtime library function.
|
The function generate_error is dependent on certain parameters in the
|
The function generate_error is dependent on certain parameters in the
|
st_parameter_common flags to be set. (See libgfortran/runtime/error.c)
|
st_parameter_common flags to be set. (See libgfortran/runtime/error.c)
|
Therefore, the code to set these flags must be generated before
|
Therefore, the code to set these flags must be generated before
|
this function is used. */
|
this function is used. */
|
|
|
void
|
void
|
gfc_trans_io_runtime_check (tree cond, tree var, int error_code,
|
gfc_trans_io_runtime_check (tree cond, tree var, int error_code,
|
const char * msgid, stmtblock_t * pblock)
|
const char * msgid, stmtblock_t * pblock)
|
{
|
{
|
stmtblock_t block;
|
stmtblock_t block;
|
tree body;
|
tree body;
|
tree tmp;
|
tree tmp;
|
tree arg1, arg2, arg3;
|
tree arg1, arg2, arg3;
|
char *message;
|
char *message;
|
|
|
if (integer_zerop (cond))
|
if (integer_zerop (cond))
|
return;
|
return;
|
|
|
/* The code to generate the error. */
|
/* The code to generate the error. */
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
|
|
arg1 = gfc_build_addr_expr (NULL_TREE, var);
|
arg1 = gfc_build_addr_expr (NULL_TREE, var);
|
|
|
arg2 = build_int_cst (integer_type_node, error_code),
|
arg2 = build_int_cst (integer_type_node, error_code),
|
|
|
asprintf (&message, "%s", _(msgid));
|
asprintf (&message, "%s", _(msgid));
|
arg3 = gfc_build_addr_expr (pchar_type_node,
|
arg3 = gfc_build_addr_expr (pchar_type_node,
|
gfc_build_localized_cstring_const (message));
|
gfc_build_localized_cstring_const (message));
|
gfc_free(message);
|
gfc_free(message);
|
|
|
tmp = build_call_expr_loc (input_location,
|
tmp = build_call_expr_loc (input_location,
|
gfor_fndecl_generate_error, 3, arg1, arg2, arg3);
|
gfor_fndecl_generate_error, 3, arg1, arg2, arg3);
|
|
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
body = gfc_finish_block (&block);
|
body = gfc_finish_block (&block);
|
|
|
if (integer_onep (cond))
|
if (integer_onep (cond))
|
{
|
{
|
gfc_add_expr_to_block (pblock, body);
|
gfc_add_expr_to_block (pblock, body);
|
}
|
}
|
else
|
else
|
{
|
{
|
/* Tell the compiler that this isn't likely. */
|
/* Tell the compiler that this isn't likely. */
|
cond = fold_convert (long_integer_type_node, cond);
|
cond = fold_convert (long_integer_type_node, cond);
|
tmp = build_int_cst (long_integer_type_node, 0);
|
tmp = build_int_cst (long_integer_type_node, 0);
|
cond = build_call_expr_loc (input_location,
|
cond = build_call_expr_loc (input_location,
|
built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
|
built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
|
cond = fold_convert (boolean_type_node, cond);
|
cond = fold_convert (boolean_type_node, cond);
|
|
|
tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location));
|
tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location));
|
gfc_add_expr_to_block (pblock, tmp);
|
gfc_add_expr_to_block (pblock, tmp);
|
}
|
}
|
}
|
}
|
|
|
|
|
/* Create function decls for IO library functions. */
|
/* Create function decls for IO library functions. */
|
|
|
void
|
void
|
gfc_build_io_library_fndecls (void)
|
gfc_build_io_library_fndecls (void)
|
{
|
{
|
tree types[IOPARM_type_num], pad_idx, gfc_int4_type_node;
|
tree types[IOPARM_type_num], pad_idx, gfc_int4_type_node;
|
tree gfc_intio_type_node;
|
tree gfc_intio_type_node;
|
tree parm_type, dt_parm_type;
|
tree parm_type, dt_parm_type;
|
HOST_WIDE_INT pad_size;
|
HOST_WIDE_INT pad_size;
|
unsigned int ptype;
|
unsigned int ptype;
|
|
|
types[IOPARM_type_int4] = gfc_int4_type_node = gfc_get_int_type (4);
|
types[IOPARM_type_int4] = gfc_int4_type_node = gfc_get_int_type (4);
|
types[IOPARM_type_intio] = gfc_intio_type_node
|
types[IOPARM_type_intio] = gfc_intio_type_node
|
= gfc_get_int_type (gfc_intio_kind);
|
= gfc_get_int_type (gfc_intio_kind);
|
types[IOPARM_type_pint4] = build_pointer_type (gfc_int4_type_node);
|
types[IOPARM_type_pint4] = build_pointer_type (gfc_int4_type_node);
|
types[IOPARM_type_pintio]
|
types[IOPARM_type_pintio]
|
= build_pointer_type (gfc_intio_type_node);
|
= build_pointer_type (gfc_intio_type_node);
|
types[IOPARM_type_parray] = pchar_type_node;
|
types[IOPARM_type_parray] = pchar_type_node;
|
types[IOPARM_type_pchar] = 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 = 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_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));
|
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);
|
types[IOPARM_type_pad] = build_array_type (char_type_node, pad_idx);
|
|
|
/* pad actually contains pointers and integers so it needs to have an
|
/* 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
|
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
|
types. See the st_parameter_dt structure in libgfortran/io/io.h for
|
what really goes into this space. */
|
what really goes into this space. */
|
TYPE_ALIGN (types[IOPARM_type_pad]) = MAX (TYPE_ALIGN (pchar_type_node),
|
TYPE_ALIGN (types[IOPARM_type_pad]) = MAX (TYPE_ALIGN (pchar_type_node),
|
TYPE_ALIGN (gfc_get_int_type (gfc_intio_kind)));
|
TYPE_ALIGN (gfc_get_int_type (gfc_intio_kind)));
|
|
|
for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++)
|
for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++)
|
gfc_build_st_parameter ((enum ioparam_type) ptype, types);
|
gfc_build_st_parameter ((enum ioparam_type) ptype, types);
|
|
|
/* Define the transfer functions. */
|
/* Define the transfer functions. */
|
|
|
dt_parm_type = build_pointer_type (st_parameter[IOPARM_ptype_dt].type);
|
dt_parm_type = build_pointer_type (st_parameter[IOPARM_ptype_dt].type);
|
|
|
iocall[IOCALL_X_INTEGER] =
|
iocall[IOCALL_X_INTEGER] =
|
gfc_build_library_function_decl (get_identifier
|
gfc_build_library_function_decl (get_identifier
|
(PREFIX("transfer_integer")),
|
(PREFIX("transfer_integer")),
|
void_type_node, 3, dt_parm_type,
|
void_type_node, 3, dt_parm_type,
|
pvoid_type_node, gfc_int4_type_node);
|
pvoid_type_node, gfc_int4_type_node);
|
|
|
iocall[IOCALL_X_LOGICAL] =
|
iocall[IOCALL_X_LOGICAL] =
|
gfc_build_library_function_decl (get_identifier
|
gfc_build_library_function_decl (get_identifier
|
(PREFIX("transfer_logical")),
|
(PREFIX("transfer_logical")),
|
void_type_node, 3, dt_parm_type,
|
void_type_node, 3, dt_parm_type,
|
pvoid_type_node, gfc_int4_type_node);
|
pvoid_type_node, gfc_int4_type_node);
|
|
|
iocall[IOCALL_X_CHARACTER] =
|
iocall[IOCALL_X_CHARACTER] =
|
gfc_build_library_function_decl (get_identifier
|
gfc_build_library_function_decl (get_identifier
|
(PREFIX("transfer_character")),
|
(PREFIX("transfer_character")),
|
void_type_node, 3, dt_parm_type,
|
void_type_node, 3, dt_parm_type,
|
pvoid_type_node, gfc_int4_type_node);
|
pvoid_type_node, gfc_int4_type_node);
|
|
|
iocall[IOCALL_X_CHARACTER_WIDE] =
|
iocall[IOCALL_X_CHARACTER_WIDE] =
|
gfc_build_library_function_decl (get_identifier
|
gfc_build_library_function_decl (get_identifier
|
(PREFIX("transfer_character_wide")),
|
(PREFIX("transfer_character_wide")),
|
void_type_node, 4, dt_parm_type,
|
void_type_node, 4, dt_parm_type,
|
pvoid_type_node, gfc_charlen_type_node,
|
pvoid_type_node, gfc_charlen_type_node,
|
gfc_int4_type_node);
|
gfc_int4_type_node);
|
|
|
iocall[IOCALL_X_REAL] =
|
iocall[IOCALL_X_REAL] =
|
gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
|
gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
|
void_type_node, 3, dt_parm_type,
|
void_type_node, 3, dt_parm_type,
|
pvoid_type_node, gfc_int4_type_node);
|
pvoid_type_node, gfc_int4_type_node);
|
|
|
iocall[IOCALL_X_COMPLEX] =
|
iocall[IOCALL_X_COMPLEX] =
|
gfc_build_library_function_decl (get_identifier
|
gfc_build_library_function_decl (get_identifier
|
(PREFIX("transfer_complex")),
|
(PREFIX("transfer_complex")),
|
void_type_node, 3, dt_parm_type,
|
void_type_node, 3, dt_parm_type,
|
pvoid_type_node, gfc_int4_type_node);
|
pvoid_type_node, gfc_int4_type_node);
|
|
|
iocall[IOCALL_X_ARRAY] =
|
iocall[IOCALL_X_ARRAY] =
|
gfc_build_library_function_decl (get_identifier
|
gfc_build_library_function_decl (get_identifier
|
(PREFIX("transfer_array")),
|
(PREFIX("transfer_array")),
|
void_type_node, 4, dt_parm_type,
|
void_type_node, 4, dt_parm_type,
|
pvoid_type_node, integer_type_node,
|
pvoid_type_node, integer_type_node,
|
gfc_charlen_type_node);
|
gfc_charlen_type_node);
|
|
|
/* Library entry points */
|
/* Library entry points */
|
|
|
iocall[IOCALL_READ] =
|
iocall[IOCALL_READ] =
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
|
void_type_node, 1, dt_parm_type);
|
void_type_node, 1, dt_parm_type);
|
|
|
iocall[IOCALL_WRITE] =
|
iocall[IOCALL_WRITE] =
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
|
void_type_node, 1, dt_parm_type);
|
void_type_node, 1, dt_parm_type);
|
|
|
parm_type = build_pointer_type (st_parameter[IOPARM_ptype_open].type);
|
parm_type = build_pointer_type (st_parameter[IOPARM_ptype_open].type);
|
iocall[IOCALL_OPEN] =
|
iocall[IOCALL_OPEN] =
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
|
void_type_node, 1, parm_type);
|
void_type_node, 1, parm_type);
|
|
|
|
|
parm_type = build_pointer_type (st_parameter[IOPARM_ptype_close].type);
|
parm_type = build_pointer_type (st_parameter[IOPARM_ptype_close].type);
|
iocall[IOCALL_CLOSE] =
|
iocall[IOCALL_CLOSE] =
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
|
void_type_node, 1, parm_type);
|
void_type_node, 1, parm_type);
|
|
|
parm_type = build_pointer_type (st_parameter[IOPARM_ptype_inquire].type);
|
parm_type = build_pointer_type (st_parameter[IOPARM_ptype_inquire].type);
|
iocall[IOCALL_INQUIRE] =
|
iocall[IOCALL_INQUIRE] =
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
|
gfc_int4_type_node, 1, parm_type);
|
gfc_int4_type_node, 1, parm_type);
|
|
|
iocall[IOCALL_IOLENGTH] =
|
iocall[IOCALL_IOLENGTH] =
|
gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
|
gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
|
void_type_node, 1, dt_parm_type);
|
void_type_node, 1, dt_parm_type);
|
|
|
parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type);
|
parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type);
|
iocall[IOCALL_WAIT] =
|
iocall[IOCALL_WAIT] =
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_wait")),
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_wait")),
|
gfc_int4_type_node, 1, parm_type);
|
gfc_int4_type_node, 1, parm_type);
|
|
|
parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
|
parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
|
iocall[IOCALL_REWIND] =
|
iocall[IOCALL_REWIND] =
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
|
gfc_int4_type_node, 1, parm_type);
|
gfc_int4_type_node, 1, parm_type);
|
|
|
iocall[IOCALL_BACKSPACE] =
|
iocall[IOCALL_BACKSPACE] =
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
|
gfc_int4_type_node, 1, parm_type);
|
gfc_int4_type_node, 1, parm_type);
|
|
|
iocall[IOCALL_ENDFILE] =
|
iocall[IOCALL_ENDFILE] =
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
|
gfc_int4_type_node, 1, parm_type);
|
gfc_int4_type_node, 1, parm_type);
|
|
|
iocall[IOCALL_FLUSH] =
|
iocall[IOCALL_FLUSH] =
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_flush")),
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_flush")),
|
gfc_int4_type_node, 1, parm_type);
|
gfc_int4_type_node, 1, parm_type);
|
|
|
/* Library helpers */
|
/* Library helpers */
|
|
|
iocall[IOCALL_READ_DONE] =
|
iocall[IOCALL_READ_DONE] =
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
|
gfc_int4_type_node, 1, dt_parm_type);
|
gfc_int4_type_node, 1, dt_parm_type);
|
|
|
iocall[IOCALL_WRITE_DONE] =
|
iocall[IOCALL_WRITE_DONE] =
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
|
gfc_int4_type_node, 1, dt_parm_type);
|
gfc_int4_type_node, 1, dt_parm_type);
|
|
|
iocall[IOCALL_IOLENGTH_DONE] =
|
iocall[IOCALL_IOLENGTH_DONE] =
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
|
gfc_int4_type_node, 1, dt_parm_type);
|
gfc_int4_type_node, 1, dt_parm_type);
|
|
|
|
|
iocall[IOCALL_SET_NML_VAL] =
|
iocall[IOCALL_SET_NML_VAL] =
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
|
void_type_node, 6, dt_parm_type,
|
void_type_node, 6, dt_parm_type,
|
pvoid_type_node, pvoid_type_node,
|
pvoid_type_node, pvoid_type_node,
|
gfc_int4_type_node, gfc_charlen_type_node,
|
gfc_int4_type_node, gfc_charlen_type_node,
|
gfc_int4_type_node);
|
gfc_int4_type_node);
|
|
|
iocall[IOCALL_SET_NML_VAL_DIM] =
|
iocall[IOCALL_SET_NML_VAL_DIM] =
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
|
gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
|
void_type_node, 5, dt_parm_type,
|
void_type_node, 5, dt_parm_type,
|
gfc_int4_type_node, gfc_array_index_type,
|
gfc_int4_type_node, gfc_array_index_type,
|
gfc_array_index_type, gfc_array_index_type);
|
gfc_array_index_type, gfc_array_index_type);
|
}
|
}
|
|
|
|
|
/* Generate code to store an integer constant into the
|
/* Generate code to store an integer constant into the
|
st_parameter_XXX structure. */
|
st_parameter_XXX structure. */
|
|
|
static unsigned int
|
static unsigned int
|
set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
|
set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
|
unsigned int val)
|
unsigned int val)
|
{
|
{
|
tree tmp;
|
tree tmp;
|
gfc_st_parameter_field *p = &st_parameter_field[type];
|
gfc_st_parameter_field *p = &st_parameter_field[type];
|
|
|
if (p->param_type == IOPARM_ptype_common)
|
if (p->param_type == IOPARM_ptype_common)
|
var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
|
var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
|
var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
|
var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
|
tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
|
tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
|
NULL_TREE);
|
NULL_TREE);
|
gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (p->field), val));
|
gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (p->field), val));
|
return p->mask;
|
return p->mask;
|
}
|
}
|
|
|
|
|
/* Generate code to store a non-string I/O parameter into the
|
/* Generate code to store a non-string I/O parameter into the
|
st_parameter_XXX structure. This is a pass by value. */
|
st_parameter_XXX structure. This is a pass by value. */
|
|
|
static unsigned int
|
static unsigned int
|
set_parameter_value (stmtblock_t *block, tree var, enum iofield type,
|
set_parameter_value (stmtblock_t *block, tree var, enum iofield type,
|
gfc_expr *e)
|
gfc_expr *e)
|
{
|
{
|
gfc_se se;
|
gfc_se se;
|
tree tmp;
|
tree tmp;
|
gfc_st_parameter_field *p = &st_parameter_field[type];
|
gfc_st_parameter_field *p = &st_parameter_field[type];
|
tree dest_type = TREE_TYPE (p->field);
|
tree dest_type = TREE_TYPE (p->field);
|
|
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_conv_expr_val (&se, e);
|
gfc_conv_expr_val (&se, e);
|
|
|
/* If we're storing a UNIT number, we need to check it first. */
|
/* If we're storing a UNIT number, we need to check it first. */
|
if (type == IOPARM_common_unit && e->ts.kind > 4)
|
if (type == IOPARM_common_unit && e->ts.kind > 4)
|
{
|
{
|
tree cond, val;
|
tree cond, val;
|
int i;
|
int i;
|
|
|
/* Don't evaluate the UNIT number multiple times. */
|
/* Don't evaluate the UNIT number multiple times. */
|
se.expr = gfc_evaluate_now (se.expr, &se.pre);
|
se.expr = gfc_evaluate_now (se.expr, &se.pre);
|
|
|
/* UNIT numbers should be greater than the min. */
|
/* UNIT numbers should be greater than the min. */
|
i = gfc_validate_kind (BT_INTEGER, 4, false);
|
i = gfc_validate_kind (BT_INTEGER, 4, false);
|
val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].pedantic_min_int, 4);
|
val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].pedantic_min_int, 4);
|
cond = fold_build2 (LT_EXPR, boolean_type_node, se.expr,
|
cond = fold_build2 (LT_EXPR, boolean_type_node, se.expr,
|
fold_convert (TREE_TYPE (se.expr), val));
|
fold_convert (TREE_TYPE (se.expr), val));
|
gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT,
|
gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT,
|
"Unit number in I/O statement too small",
|
"Unit number in I/O statement too small",
|
&se.pre);
|
&se.pre);
|
|
|
/* UNIT numbers should be less than the max. */
|
/* UNIT numbers should be less than the max. */
|
val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4);
|
val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4);
|
cond = fold_build2 (GT_EXPR, boolean_type_node, se.expr,
|
cond = fold_build2 (GT_EXPR, boolean_type_node, se.expr,
|
fold_convert (TREE_TYPE (se.expr), val));
|
fold_convert (TREE_TYPE (se.expr), val));
|
gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT,
|
gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT,
|
"Unit number in I/O statement too large",
|
"Unit number in I/O statement too large",
|
&se.pre);
|
&se.pre);
|
|
|
}
|
}
|
|
|
se.expr = convert (dest_type, se.expr);
|
se.expr = convert (dest_type, se.expr);
|
gfc_add_block_to_block (block, &se.pre);
|
gfc_add_block_to_block (block, &se.pre);
|
|
|
if (p->param_type == IOPARM_ptype_common)
|
if (p->param_type == IOPARM_ptype_common)
|
var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
|
var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
|
var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
|
var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
|
|
|
tmp = fold_build3 (COMPONENT_REF, dest_type, var, p->field, NULL_TREE);
|
tmp = fold_build3 (COMPONENT_REF, dest_type, var, p->field, NULL_TREE);
|
gfc_add_modify (block, tmp, se.expr);
|
gfc_add_modify (block, tmp, se.expr);
|
return p->mask;
|
return p->mask;
|
}
|
}
|
|
|
|
|
/* Generate code to store a non-string I/O parameter into the
|
/* Generate code to store a non-string I/O parameter into the
|
st_parameter_XXX structure. This is pass by reference. */
|
st_parameter_XXX structure. This is pass by reference. */
|
|
|
static unsigned int
|
static unsigned int
|
set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
|
set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
|
tree var, enum iofield type, gfc_expr *e)
|
tree var, enum iofield type, gfc_expr *e)
|
{
|
{
|
gfc_se se;
|
gfc_se se;
|
tree tmp, addr;
|
tree tmp, addr;
|
gfc_st_parameter_field *p = &st_parameter_field[type];
|
gfc_st_parameter_field *p = &st_parameter_field[type];
|
|
|
gcc_assert (e->ts.type == BT_INTEGER || e->ts.type == BT_LOGICAL);
|
gcc_assert (e->ts.type == BT_INTEGER || e->ts.type == BT_LOGICAL);
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
gfc_conv_expr_lhs (&se, e);
|
gfc_conv_expr_lhs (&se, e);
|
|
|
gfc_add_block_to_block (block, &se.pre);
|
gfc_add_block_to_block (block, &se.pre);
|
|
|
if (TYPE_MODE (TREE_TYPE (se.expr))
|
if (TYPE_MODE (TREE_TYPE (se.expr))
|
== TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field))))
|
== TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field))))
|
{
|
{
|
addr = convert (TREE_TYPE (p->field), gfc_build_addr_expr (NULL_TREE, se.expr));
|
addr = convert (TREE_TYPE (p->field), gfc_build_addr_expr (NULL_TREE, se.expr));
|
|
|
/* If this is for the iostat variable initialize the
|
/* If this is for the iostat variable initialize the
|
user variable to LIBERROR_OK which is zero. */
|
user variable to LIBERROR_OK which is zero. */
|
if (type == IOPARM_common_iostat)
|
if (type == IOPARM_common_iostat)
|
gfc_add_modify (block, se.expr,
|
gfc_add_modify (block, se.expr,
|
build_int_cst (TREE_TYPE (se.expr), LIBERROR_OK));
|
build_int_cst (TREE_TYPE (se.expr), LIBERROR_OK));
|
}
|
}
|
else
|
else
|
{
|
{
|
/* The type used by the library has different size
|
/* The type used by the library has different size
|
from the type of the variable supplied by the user.
|
from the type of the variable supplied by the user.
|
Need to use a temporary. */
|
Need to use a temporary. */
|
tree tmpvar = gfc_create_var (TREE_TYPE (TREE_TYPE (p->field)),
|
tree tmpvar = gfc_create_var (TREE_TYPE (TREE_TYPE (p->field)),
|
st_parameter_field[type].name);
|
st_parameter_field[type].name);
|
|
|
/* If this is for the iostat variable, initialize the
|
/* If this is for the iostat variable, initialize the
|
user variable to LIBERROR_OK which is zero. */
|
user variable to LIBERROR_OK which is zero. */
|
if (type == IOPARM_common_iostat)
|
if (type == IOPARM_common_iostat)
|
gfc_add_modify (block, tmpvar,
|
gfc_add_modify (block, tmpvar,
|
build_int_cst (TREE_TYPE (tmpvar), LIBERROR_OK));
|
build_int_cst (TREE_TYPE (tmpvar), LIBERROR_OK));
|
|
|
addr = gfc_build_addr_expr (NULL_TREE, tmpvar);
|
addr = gfc_build_addr_expr (NULL_TREE, tmpvar);
|
/* After the I/O operation, we set the variable from the temporary. */
|
/* After the I/O operation, we set the variable from the temporary. */
|
tmp = convert (TREE_TYPE (se.expr), tmpvar);
|
tmp = convert (TREE_TYPE (se.expr), tmpvar);
|
gfc_add_modify (postblock, se.expr, tmp);
|
gfc_add_modify (postblock, se.expr, tmp);
|
}
|
}
|
|
|
if (p->param_type == IOPARM_ptype_common)
|
if (p->param_type == IOPARM_ptype_common)
|
var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
|
var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
|
var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
|
var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
|
tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
|
tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
|
var, p->field, NULL_TREE);
|
var, p->field, NULL_TREE);
|
gfc_add_modify (block, tmp, addr);
|
gfc_add_modify (block, tmp, addr);
|
return p->mask;
|
return p->mask;
|
}
|
}
|
|
|
/* Given an array expr, find its address and length to get a string. If the
|
/* 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
|
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
|
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
|
string's address is the element's address and the length is the rest size of
|
the array. */
|
the array. */
|
|
|
static void
|
static void
|
gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
|
gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
|
{
|
{
|
tree size;
|
tree size;
|
|
|
if (e->rank == 0)
|
if (e->rank == 0)
|
{
|
{
|
tree type, array, tmp;
|
tree type, array, tmp;
|
gfc_symbol *sym;
|
gfc_symbol *sym;
|
int rank;
|
int rank;
|
|
|
/* If it is an element, we need its address and size of the rest. */
|
/* If it is an element, we need its address and size of the rest. */
|
gcc_assert (e->expr_type == EXPR_VARIABLE);
|
gcc_assert (e->expr_type == EXPR_VARIABLE);
|
gcc_assert (e->ref->u.ar.type == AR_ELEMENT);
|
gcc_assert (e->ref->u.ar.type == AR_ELEMENT);
|
sym = e->symtree->n.sym;
|
sym = e->symtree->n.sym;
|
rank = sym->as->rank - 1;
|
rank = sym->as->rank - 1;
|
gfc_conv_expr (se, e);
|
gfc_conv_expr (se, e);
|
|
|
array = sym->backend_decl;
|
array = sym->backend_decl;
|
type = TREE_TYPE (array);
|
type = TREE_TYPE (array);
|
|
|
if (GFC_ARRAY_TYPE_P (type))
|
if (GFC_ARRAY_TYPE_P (type))
|
size = GFC_TYPE_ARRAY_SIZE (type);
|
size = GFC_TYPE_ARRAY_SIZE (type);
|
else
|
else
|
{
|
{
|
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
|
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
|
size = gfc_conv_array_stride (array, rank);
|
size = gfc_conv_array_stride (array, rank);
|
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
|
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
|
gfc_conv_array_ubound (array, rank),
|
gfc_conv_array_ubound (array, rank),
|
gfc_conv_array_lbound (array, rank));
|
gfc_conv_array_lbound (array, rank));
|
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
|
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
|
gfc_index_one_node);
|
gfc_index_one_node);
|
size = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
|
size = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
|
}
|
}
|
gcc_assert (size);
|
gcc_assert (size);
|
|
|
size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
|
size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
|
TREE_OPERAND (se->expr, 1));
|
TREE_OPERAND (se->expr, 1));
|
se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
|
se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
|
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
|
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
|
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
|
size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
|
fold_convert (gfc_array_index_type, tmp));
|
fold_convert (gfc_array_index_type, tmp));
|
se->string_length = fold_convert (gfc_charlen_type_node, size);
|
se->string_length = fold_convert (gfc_charlen_type_node, size);
|
return;
|
return;
|
}
|
}
|
|
|
gfc_conv_array_parameter (se, e, gfc_walk_expr (e), true, NULL, NULL, &size);
|
gfc_conv_array_parameter (se, e, gfc_walk_expr (e), true, NULL, NULL, &size);
|
se->string_length = fold_convert (gfc_charlen_type_node, size);
|
se->string_length = fold_convert (gfc_charlen_type_node, size);
|
}
|
}
|
|
|
|
|
/* Generate code to store a string and its length into the
|
/* Generate code to store a string and its length into the
|
st_parameter_XXX structure. */
|
st_parameter_XXX structure. */
|
|
|
static unsigned int
|
static unsigned int
|
set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
|
set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
|
enum iofield type, gfc_expr * e)
|
enum iofield type, gfc_expr * e)
|
{
|
{
|
gfc_se se;
|
gfc_se se;
|
tree tmp;
|
tree tmp;
|
tree io;
|
tree io;
|
tree len;
|
tree len;
|
gfc_st_parameter_field *p = &st_parameter_field[type];
|
gfc_st_parameter_field *p = &st_parameter_field[type];
|
|
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
|
|
if (p->param_type == IOPARM_ptype_common)
|
if (p->param_type == IOPARM_ptype_common)
|
var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
|
var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
|
var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
|
var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
|
io = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
|
io = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
|
var, p->field, NULL_TREE);
|
var, p->field, NULL_TREE);
|
len = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field_len),
|
len = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field_len),
|
var, p->field_len, NULL_TREE);
|
var, p->field_len, NULL_TREE);
|
|
|
/* Integer variable assigned a format label. */
|
/* Integer variable assigned a format label. */
|
if (e->ts.type == BT_INTEGER
|
if (e->ts.type == BT_INTEGER
|
&& e->rank == 0
|
&& e->rank == 0
|
&& e->symtree->n.sym->attr.assign == 1)
|
&& e->symtree->n.sym->attr.assign == 1)
|
{
|
{
|
char * msg;
|
char * msg;
|
tree cond;
|
tree cond;
|
|
|
gfc_conv_label_variable (&se, e);
|
gfc_conv_label_variable (&se, e);
|
tmp = GFC_DECL_STRING_LEN (se.expr);
|
tmp = GFC_DECL_STRING_LEN (se.expr);
|
cond = fold_build2 (LT_EXPR, boolean_type_node,
|
cond = fold_build2 (LT_EXPR, boolean_type_node,
|
tmp, build_int_cst (TREE_TYPE (tmp), 0));
|
tmp, build_int_cst (TREE_TYPE (tmp), 0));
|
|
|
asprintf(&msg, "Label assigned to variable '%s' (%%ld) is not a format "
|
asprintf(&msg, "Label assigned to variable '%s' (%%ld) is not a format "
|
"label", e->symtree->name);
|
"label", e->symtree->name);
|
gfc_trans_runtime_check (true, false, cond, &se.pre, &e->where, msg,
|
gfc_trans_runtime_check (true, false, cond, &se.pre, &e->where, msg,
|
fold_convert (long_integer_type_node, tmp));
|
fold_convert (long_integer_type_node, tmp));
|
gfc_free (msg);
|
gfc_free (msg);
|
|
|
gfc_add_modify (&se.pre, io,
|
gfc_add_modify (&se.pre, io,
|
fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr)));
|
fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr)));
|
gfc_add_modify (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
|
gfc_add_modify (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
|
}
|
}
|
else
|
else
|
{
|
{
|
/* General character. */
|
/* General character. */
|
if (e->ts.type == BT_CHARACTER && e->rank == 0)
|
if (e->ts.type == BT_CHARACTER && e->rank == 0)
|
gfc_conv_expr (&se, e);
|
gfc_conv_expr (&se, e);
|
/* Array assigned Hollerith constant or character array. */
|
/* Array assigned Hollerith constant or character array. */
|
else if (e->rank > 0 || (e->symtree && e->symtree->n.sym->as->rank > 0))
|
else if (e->rank > 0 || (e->symtree && e->symtree->n.sym->as->rank > 0))
|
gfc_convert_array_to_string (&se, e);
|
gfc_convert_array_to_string (&se, e);
|
else
|
else
|
gcc_unreachable ();
|
gcc_unreachable ();
|
|
|
gfc_conv_string_parameter (&se);
|
gfc_conv_string_parameter (&se);
|
gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
|
gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
|
gfc_add_modify (&se.pre, len, se.string_length);
|
gfc_add_modify (&se.pre, len, se.string_length);
|
}
|
}
|
|
|
gfc_add_block_to_block (block, &se.pre);
|
gfc_add_block_to_block (block, &se.pre);
|
gfc_add_block_to_block (postblock, &se.post);
|
gfc_add_block_to_block (postblock, &se.post);
|
return p->mask;
|
return p->mask;
|
}
|
}
|
|
|
|
|
/* Generate code to store the character (array) and the character length
|
/* Generate code to store the character (array) and the character length
|
for an internal unit. */
|
for an internal unit. */
|
|
|
static unsigned int
|
static unsigned int
|
set_internal_unit (stmtblock_t * block, stmtblock_t * post_block,
|
set_internal_unit (stmtblock_t * block, stmtblock_t * post_block,
|
tree var, gfc_expr * e)
|
tree var, gfc_expr * e)
|
{
|
{
|
gfc_se se;
|
gfc_se se;
|
tree io;
|
tree io;
|
tree len;
|
tree len;
|
tree desc;
|
tree desc;
|
tree tmp;
|
tree tmp;
|
gfc_st_parameter_field *p;
|
gfc_st_parameter_field *p;
|
unsigned int mask;
|
unsigned int mask;
|
|
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
|
|
p = &st_parameter_field[IOPARM_dt_internal_unit];
|
p = &st_parameter_field[IOPARM_dt_internal_unit];
|
mask = p->mask;
|
mask = p->mask;
|
io = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
|
io = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
|
var, p->field, NULL_TREE);
|
var, p->field, NULL_TREE);
|
len = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field_len),
|
len = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field_len),
|
var, p->field_len, NULL_TREE);
|
var, p->field_len, NULL_TREE);
|
p = &st_parameter_field[IOPARM_dt_internal_unit_desc];
|
p = &st_parameter_field[IOPARM_dt_internal_unit_desc];
|
desc = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
|
desc = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
|
var, p->field, NULL_TREE);
|
var, p->field, NULL_TREE);
|
|
|
gcc_assert (e->ts.type == BT_CHARACTER);
|
gcc_assert (e->ts.type == BT_CHARACTER);
|
|
|
/* Character scalars. */
|
/* Character scalars. */
|
if (e->rank == 0)
|
if (e->rank == 0)
|
{
|
{
|
gfc_conv_expr (&se, e);
|
gfc_conv_expr (&se, e);
|
gfc_conv_string_parameter (&se);
|
gfc_conv_string_parameter (&se);
|
tmp = se.expr;
|
tmp = se.expr;
|
se.expr = build_int_cst (pchar_type_node, 0);
|
se.expr = build_int_cst (pchar_type_node, 0);
|
}
|
}
|
|
|
/* Character array. */
|
/* Character array. */
|
else if (e->rank > 0)
|
else if (e->rank > 0)
|
{
|
{
|
se.ss = gfc_walk_expr (e);
|
se.ss = gfc_walk_expr (e);
|
|
|
if (is_subref_array (e))
|
if (is_subref_array (e))
|
{
|
{
|
/* Use a temporary for components of arrays of derived types
|
/* Use a temporary for components of arrays of derived types
|
or substring array references. */
|
or substring array references. */
|
gfc_conv_subref_array_arg (&se, e, 0,
|
gfc_conv_subref_array_arg (&se, e, 0,
|
last_dt == READ ? INTENT_IN : INTENT_OUT, false);
|
last_dt == READ ? INTENT_IN : INTENT_OUT, false);
|
tmp = build_fold_indirect_ref_loc (input_location,
|
tmp = build_fold_indirect_ref_loc (input_location,
|
se.expr);
|
se.expr);
|
se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
|
se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
|
tmp = gfc_conv_descriptor_data_get (tmp);
|
tmp = gfc_conv_descriptor_data_get (tmp);
|
}
|
}
|
else
|
else
|
{
|
{
|
/* Return the data pointer and rank from the descriptor. */
|
/* Return the data pointer and rank from the descriptor. */
|
gfc_conv_expr_descriptor (&se, e, se.ss);
|
gfc_conv_expr_descriptor (&se, e, se.ss);
|
tmp = gfc_conv_descriptor_data_get (se.expr);
|
tmp = gfc_conv_descriptor_data_get (se.expr);
|
se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
|
se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
|
}
|
}
|
}
|
}
|
else
|
else
|
gcc_unreachable ();
|
gcc_unreachable ();
|
|
|
/* The cast is needed for character substrings and the descriptor
|
/* The cast is needed for character substrings and the descriptor
|
data. */
|
data. */
|
gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), tmp));
|
gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), tmp));
|
gfc_add_modify (&se.pre, len,
|
gfc_add_modify (&se.pre, len,
|
fold_convert (TREE_TYPE (len), se.string_length));
|
fold_convert (TREE_TYPE (len), se.string_length));
|
gfc_add_modify (&se.pre, desc, se.expr);
|
gfc_add_modify (&se.pre, desc, se.expr);
|
|
|
gfc_add_block_to_block (block, &se.pre);
|
gfc_add_block_to_block (block, &se.pre);
|
gfc_add_block_to_block (post_block, &se.post);
|
gfc_add_block_to_block (post_block, &se.post);
|
return mask;
|
return mask;
|
}
|
}
|
|
|
/* Add a case to a IO-result switch. */
|
/* Add a case to a IO-result switch. */
|
|
|
static void
|
static void
|
add_case (int label_value, gfc_st_label * label, stmtblock_t * body)
|
add_case (int label_value, gfc_st_label * label, stmtblock_t * body)
|
{
|
{
|
tree tmp, value;
|
tree tmp, value;
|
|
|
if (label == NULL)
|
if (label == NULL)
|
return; /* No label, no case */
|
return; /* No label, no case */
|
|
|
value = build_int_cst (NULL_TREE, label_value);
|
value = build_int_cst (NULL_TREE, label_value);
|
|
|
/* Make a backend label for this case. */
|
/* Make a backend label for this case. */
|
tmp = gfc_build_label_decl (NULL_TREE);
|
tmp = gfc_build_label_decl (NULL_TREE);
|
|
|
/* And the case itself. */
|
/* And the case itself. */
|
tmp = build3_v (CASE_LABEL_EXPR, value, NULL_TREE, tmp);
|
tmp = build3_v (CASE_LABEL_EXPR, value, NULL_TREE, tmp);
|
gfc_add_expr_to_block (body, tmp);
|
gfc_add_expr_to_block (body, tmp);
|
|
|
/* Jump to the label. */
|
/* Jump to the label. */
|
tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label));
|
tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label));
|
gfc_add_expr_to_block (body, tmp);
|
gfc_add_expr_to_block (body, tmp);
|
}
|
}
|
|
|
|
|
/* Generate a switch statement that branches to the correct I/O
|
/* Generate a switch statement that branches to the correct I/O
|
result label. The last statement of an I/O call stores the
|
result label. The last statement of an I/O call stores the
|
result into a variable because there is often cleanup that
|
result into a variable because there is often cleanup that
|
must be done before the switch, so a temporary would have to
|
must be done before the switch, so a temporary would have to
|
be created anyway. */
|
be created anyway. */
|
|
|
static void
|
static void
|
io_result (stmtblock_t * block, tree var, 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)
|
gfc_st_label * end_label, gfc_st_label * eor_label)
|
{
|
{
|
stmtblock_t body;
|
stmtblock_t body;
|
tree tmp, rc;
|
tree tmp, rc;
|
gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
|
gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
|
|
|
/* If no labels are specified, ignore the result instead
|
/* If no labels are specified, ignore the result instead
|
of building an empty switch. */
|
of building an empty switch. */
|
if (err_label == NULL
|
if (err_label == NULL
|
&& end_label == NULL
|
&& end_label == NULL
|
&& eor_label == NULL)
|
&& eor_label == NULL)
|
return;
|
return;
|
|
|
/* Build a switch statement. */
|
/* Build a switch statement. */
|
gfc_start_block (&body);
|
gfc_start_block (&body);
|
|
|
/* The label values here must be the same as the values
|
/* The label values here must be the same as the values
|
in the library_return enum in the runtime library */
|
in the library_return enum in the runtime library */
|
add_case (1, err_label, &body);
|
add_case (1, err_label, &body);
|
add_case (2, end_label, &body);
|
add_case (2, end_label, &body);
|
add_case (3, eor_label, &body);
|
add_case (3, eor_label, &body);
|
|
|
tmp = gfc_finish_block (&body);
|
tmp = gfc_finish_block (&body);
|
|
|
var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
|
var = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
|
var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
|
var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
|
rc = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
|
rc = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
|
var, p->field, NULL_TREE);
|
var, p->field, NULL_TREE);
|
rc = fold_build2 (BIT_AND_EXPR, TREE_TYPE (rc),
|
rc = fold_build2 (BIT_AND_EXPR, TREE_TYPE (rc),
|
rc, build_int_cst (TREE_TYPE (rc),
|
rc, build_int_cst (TREE_TYPE (rc),
|
IOPARM_common_libreturn_mask));
|
IOPARM_common_libreturn_mask));
|
|
|
tmp = build3_v (SWITCH_EXPR, rc, tmp, NULL_TREE);
|
tmp = build3_v (SWITCH_EXPR, rc, tmp, NULL_TREE);
|
|
|
gfc_add_expr_to_block (block, tmp);
|
gfc_add_expr_to_block (block, tmp);
|
}
|
}
|
|
|
|
|
/* Store the current file and line number to variables so that if a
|
/* Store the current file and line number to variables so that if a
|
library call goes awry, we can tell the user where the problem is. */
|
library call goes awry, we can tell the user where the problem is. */
|
|
|
static void
|
static void
|
set_error_locus (stmtblock_t * block, tree var, locus * where)
|
set_error_locus (stmtblock_t * block, tree var, locus * where)
|
{
|
{
|
gfc_file *f;
|
gfc_file *f;
|
tree str, locus_file;
|
tree str, locus_file;
|
int line;
|
int line;
|
gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename];
|
gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename];
|
|
|
locus_file = fold_build3 (COMPONENT_REF,
|
locus_file = fold_build3 (COMPONENT_REF,
|
st_parameter[IOPARM_ptype_common].type,
|
st_parameter[IOPARM_ptype_common].type,
|
var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
|
var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
|
locus_file = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
|
locus_file = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
|
locus_file, p->field, NULL_TREE);
|
locus_file, p->field, NULL_TREE);
|
f = where->lb->file;
|
f = where->lb->file;
|
str = gfc_build_cstring_const (f->filename);
|
str = gfc_build_cstring_const (f->filename);
|
|
|
str = gfc_build_addr_expr (pchar_type_node, str);
|
str = gfc_build_addr_expr (pchar_type_node, str);
|
gfc_add_modify (block, locus_file, str);
|
gfc_add_modify (block, locus_file, str);
|
|
|
line = LOCATION_LINE (where->lb->location);
|
line = LOCATION_LINE (where->lb->location);
|
set_parameter_const (block, var, IOPARM_common_line, line);
|
set_parameter_const (block, var, IOPARM_common_line, line);
|
}
|
}
|
|
|
|
|
/* Translate an OPEN statement. */
|
/* Translate an OPEN statement. */
|
|
|
tree
|
tree
|
gfc_trans_open (gfc_code * code)
|
gfc_trans_open (gfc_code * code)
|
{
|
{
|
stmtblock_t block, post_block;
|
stmtblock_t block, post_block;
|
gfc_open *p;
|
gfc_open *p;
|
tree tmp, var;
|
tree tmp, var;
|
unsigned int mask = 0;
|
unsigned int mask = 0;
|
|
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
gfc_init_block (&post_block);
|
gfc_init_block (&post_block);
|
|
|
var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm");
|
var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm");
|
|
|
set_error_locus (&block, var, &code->loc);
|
set_error_locus (&block, var, &code->loc);
|
p = code->ext.open;
|
p = code->ext.open;
|
|
|
if (p->iomsg)
|
if (p->iomsg)
|
mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
|
mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
|
p->iomsg);
|
p->iomsg);
|
|
|
if (p->iostat)
|
if (p->iostat)
|
mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
|
mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
|
p->iostat);
|
p->iostat);
|
|
|
if (p->err)
|
if (p->err)
|
mask |= IOPARM_common_err;
|
mask |= IOPARM_common_err;
|
|
|
if (p->file)
|
if (p->file)
|
mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);
|
mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);
|
|
|
if (p->status)
|
if (p->status)
|
mask |= set_string (&block, &post_block, var, IOPARM_open_status,
|
mask |= set_string (&block, &post_block, var, IOPARM_open_status,
|
p->status);
|
p->status);
|
|
|
if (p->access)
|
if (p->access)
|
mask |= set_string (&block, &post_block, var, IOPARM_open_access,
|
mask |= set_string (&block, &post_block, var, IOPARM_open_access,
|
p->access);
|
p->access);
|
|
|
if (p->form)
|
if (p->form)
|
mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);
|
mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);
|
|
|
if (p->recl)
|
if (p->recl)
|
mask |= set_parameter_value (&block, var, IOPARM_open_recl_in, p->recl);
|
mask |= set_parameter_value (&block, var, IOPARM_open_recl_in, p->recl);
|
|
|
if (p->blank)
|
if (p->blank)
|
mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
|
mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
|
p->blank);
|
p->blank);
|
|
|
if (p->position)
|
if (p->position)
|
mask |= set_string (&block, &post_block, var, IOPARM_open_position,
|
mask |= set_string (&block, &post_block, var, IOPARM_open_position,
|
p->position);
|
p->position);
|
|
|
if (p->action)
|
if (p->action)
|
mask |= set_string (&block, &post_block, var, IOPARM_open_action,
|
mask |= set_string (&block, &post_block, var, IOPARM_open_action,
|
p->action);
|
p->action);
|
|
|
if (p->delim)
|
if (p->delim)
|
mask |= set_string (&block, &post_block, var, IOPARM_open_delim,
|
mask |= set_string (&block, &post_block, var, IOPARM_open_delim,
|
p->delim);
|
p->delim);
|
|
|
if (p->pad)
|
if (p->pad)
|
mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
|
mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
|
|
|
if (p->decimal)
|
if (p->decimal)
|
mask |= set_string (&block, &post_block, var, IOPARM_open_decimal,
|
mask |= set_string (&block, &post_block, var, IOPARM_open_decimal,
|
p->decimal);
|
p->decimal);
|
|
|
if (p->encoding)
|
if (p->encoding)
|
mask |= set_string (&block, &post_block, var, IOPARM_open_encoding,
|
mask |= set_string (&block, &post_block, var, IOPARM_open_encoding,
|
p->encoding);
|
p->encoding);
|
|
|
if (p->round)
|
if (p->round)
|
mask |= set_string (&block, &post_block, var, IOPARM_open_round, p->round);
|
mask |= set_string (&block, &post_block, var, IOPARM_open_round, p->round);
|
|
|
if (p->sign)
|
if (p->sign)
|
mask |= set_string (&block, &post_block, var, IOPARM_open_sign, p->sign);
|
mask |= set_string (&block, &post_block, var, IOPARM_open_sign, p->sign);
|
|
|
if (p->asynchronous)
|
if (p->asynchronous)
|
mask |= set_string (&block, &post_block, var, IOPARM_open_asynchronous,
|
mask |= set_string (&block, &post_block, var, IOPARM_open_asynchronous,
|
p->asynchronous);
|
p->asynchronous);
|
|
|
if (p->convert)
|
if (p->convert)
|
mask |= set_string (&block, &post_block, var, IOPARM_open_convert,
|
mask |= set_string (&block, &post_block, var, IOPARM_open_convert,
|
p->convert);
|
p->convert);
|
|
|
if (p->newunit)
|
if (p->newunit)
|
mask |= set_parameter_ref (&block, &post_block, var, IOPARM_open_newunit,
|
mask |= set_parameter_ref (&block, &post_block, var, IOPARM_open_newunit,
|
p->newunit);
|
p->newunit);
|
|
|
set_parameter_const (&block, var, IOPARM_common_flags, mask);
|
set_parameter_const (&block, var, IOPARM_common_flags, mask);
|
|
|
if (p->unit)
|
if (p->unit)
|
set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
|
set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
|
else
|
else
|
set_parameter_const (&block, var, IOPARM_common_unit, 0);
|
set_parameter_const (&block, var, IOPARM_common_unit, 0);
|
|
|
tmp = gfc_build_addr_expr (NULL_TREE, var);
|
tmp = gfc_build_addr_expr (NULL_TREE, var);
|
tmp = build_call_expr_loc (input_location,
|
tmp = build_call_expr_loc (input_location,
|
iocall[IOCALL_OPEN], 1, tmp);
|
iocall[IOCALL_OPEN], 1, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
gfc_add_block_to_block (&block, &post_block);
|
gfc_add_block_to_block (&block, &post_block);
|
|
|
io_result (&block, var, p->err, NULL, NULL);
|
io_result (&block, var, p->err, NULL, NULL);
|
|
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
|
|
/* Translate a CLOSE statement. */
|
/* Translate a CLOSE statement. */
|
|
|
tree
|
tree
|
gfc_trans_close (gfc_code * code)
|
gfc_trans_close (gfc_code * code)
|
{
|
{
|
stmtblock_t block, post_block;
|
stmtblock_t block, post_block;
|
gfc_close *p;
|
gfc_close *p;
|
tree tmp, var;
|
tree tmp, var;
|
unsigned int mask = 0;
|
unsigned int mask = 0;
|
|
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
gfc_init_block (&post_block);
|
gfc_init_block (&post_block);
|
|
|
var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm");
|
var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm");
|
|
|
set_error_locus (&block, var, &code->loc);
|
set_error_locus (&block, var, &code->loc);
|
p = code->ext.close;
|
p = code->ext.close;
|
|
|
if (p->iomsg)
|
if (p->iomsg)
|
mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
|
mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
|
p->iomsg);
|
p->iomsg);
|
|
|
if (p->iostat)
|
if (p->iostat)
|
mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
|
mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
|
p->iostat);
|
p->iostat);
|
|
|
if (p->err)
|
if (p->err)
|
mask |= IOPARM_common_err;
|
mask |= IOPARM_common_err;
|
|
|
if (p->status)
|
if (p->status)
|
mask |= set_string (&block, &post_block, var, IOPARM_close_status,
|
mask |= set_string (&block, &post_block, var, IOPARM_close_status,
|
p->status);
|
p->status);
|
|
|
set_parameter_const (&block, var, IOPARM_common_flags, mask);
|
set_parameter_const (&block, var, IOPARM_common_flags, mask);
|
|
|
if (p->unit)
|
if (p->unit)
|
set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
|
set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
|
else
|
else
|
set_parameter_const (&block, var, IOPARM_common_unit, 0);
|
set_parameter_const (&block, var, IOPARM_common_unit, 0);
|
|
|
tmp = gfc_build_addr_expr (NULL_TREE, var);
|
tmp = gfc_build_addr_expr (NULL_TREE, var);
|
tmp = build_call_expr_loc (input_location,
|
tmp = build_call_expr_loc (input_location,
|
iocall[IOCALL_CLOSE], 1, tmp);
|
iocall[IOCALL_CLOSE], 1, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
gfc_add_block_to_block (&block, &post_block);
|
gfc_add_block_to_block (&block, &post_block);
|
|
|
io_result (&block, var, p->err, NULL, NULL);
|
io_result (&block, var, p->err, NULL, NULL);
|
|
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
|
|
/* Common subroutine for building a file positioning statement. */
|
/* Common subroutine for building a file positioning statement. */
|
|
|
static tree
|
static tree
|
build_filepos (tree function, gfc_code * code)
|
build_filepos (tree function, gfc_code * code)
|
{
|
{
|
stmtblock_t block, post_block;
|
stmtblock_t block, post_block;
|
gfc_filepos *p;
|
gfc_filepos *p;
|
tree tmp, var;
|
tree tmp, var;
|
unsigned int mask = 0;
|
unsigned int mask = 0;
|
|
|
p = code->ext.filepos;
|
p = code->ext.filepos;
|
|
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
gfc_init_block (&post_block);
|
gfc_init_block (&post_block);
|
|
|
var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type,
|
var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type,
|
"filepos_parm");
|
"filepos_parm");
|
|
|
set_error_locus (&block, var, &code->loc);
|
set_error_locus (&block, var, &code->loc);
|
|
|
if (p->iomsg)
|
if (p->iomsg)
|
mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
|
mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
|
p->iomsg);
|
p->iomsg);
|
|
|
if (p->iostat)
|
if (p->iostat)
|
mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
|
mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
|
p->iostat);
|
p->iostat);
|
|
|
if (p->err)
|
if (p->err)
|
mask |= IOPARM_common_err;
|
mask |= IOPARM_common_err;
|
|
|
set_parameter_const (&block, var, IOPARM_common_flags, mask);
|
set_parameter_const (&block, var, IOPARM_common_flags, mask);
|
|
|
if (p->unit)
|
if (p->unit)
|
set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
|
set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
|
else
|
else
|
set_parameter_const (&block, var, IOPARM_common_unit, 0);
|
set_parameter_const (&block, var, IOPARM_common_unit, 0);
|
|
|
tmp = gfc_build_addr_expr (NULL_TREE, var);
|
tmp = gfc_build_addr_expr (NULL_TREE, var);
|
tmp = build_call_expr_loc (input_location,
|
tmp = build_call_expr_loc (input_location,
|
function, 1, tmp);
|
function, 1, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
gfc_add_block_to_block (&block, &post_block);
|
gfc_add_block_to_block (&block, &post_block);
|
|
|
io_result (&block, var, p->err, NULL, NULL);
|
io_result (&block, var, p->err, NULL, NULL);
|
|
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
|
|
/* Translate a BACKSPACE statement. */
|
/* Translate a BACKSPACE statement. */
|
|
|
tree
|
tree
|
gfc_trans_backspace (gfc_code * code)
|
gfc_trans_backspace (gfc_code * code)
|
{
|
{
|
return build_filepos (iocall[IOCALL_BACKSPACE], code);
|
return build_filepos (iocall[IOCALL_BACKSPACE], code);
|
}
|
}
|
|
|
|
|
/* Translate an ENDFILE statement. */
|
/* Translate an ENDFILE statement. */
|
|
|
tree
|
tree
|
gfc_trans_endfile (gfc_code * code)
|
gfc_trans_endfile (gfc_code * code)
|
{
|
{
|
return build_filepos (iocall[IOCALL_ENDFILE], code);
|
return build_filepos (iocall[IOCALL_ENDFILE], code);
|
}
|
}
|
|
|
|
|
/* Translate a REWIND statement. */
|
/* Translate a REWIND statement. */
|
|
|
tree
|
tree
|
gfc_trans_rewind (gfc_code * code)
|
gfc_trans_rewind (gfc_code * code)
|
{
|
{
|
return build_filepos (iocall[IOCALL_REWIND], code);
|
return build_filepos (iocall[IOCALL_REWIND], code);
|
}
|
}
|
|
|
|
|
/* Translate a FLUSH statement. */
|
/* Translate a FLUSH statement. */
|
|
|
tree
|
tree
|
gfc_trans_flush (gfc_code * code)
|
gfc_trans_flush (gfc_code * code)
|
{
|
{
|
return build_filepos (iocall[IOCALL_FLUSH], code);
|
return build_filepos (iocall[IOCALL_FLUSH], code);
|
}
|
}
|
|
|
|
|
/* Create a dummy iostat variable to catch any error due to bad unit. */
|
/* Create a dummy iostat variable to catch any error due to bad unit. */
|
|
|
static gfc_expr *
|
static gfc_expr *
|
create_dummy_iostat (void)
|
create_dummy_iostat (void)
|
{
|
{
|
gfc_symtree *st;
|
gfc_symtree *st;
|
gfc_expr *e;
|
gfc_expr *e;
|
|
|
gfc_get_ha_sym_tree ("@iostat", &st);
|
gfc_get_ha_sym_tree ("@iostat", &st);
|
st->n.sym->ts.type = BT_INTEGER;
|
st->n.sym->ts.type = BT_INTEGER;
|
st->n.sym->ts.kind = gfc_default_integer_kind;
|
st->n.sym->ts.kind = gfc_default_integer_kind;
|
gfc_set_sym_referenced (st->n.sym);
|
gfc_set_sym_referenced (st->n.sym);
|
gfc_commit_symbol (st->n.sym);
|
gfc_commit_symbol (st->n.sym);
|
st->n.sym->backend_decl
|
st->n.sym->backend_decl
|
= gfc_create_var (gfc_get_int_type (st->n.sym->ts.kind),
|
= gfc_create_var (gfc_get_int_type (st->n.sym->ts.kind),
|
st->n.sym->name);
|
st->n.sym->name);
|
|
|
e = gfc_get_expr ();
|
e = gfc_get_expr ();
|
e->expr_type = EXPR_VARIABLE;
|
e->expr_type = EXPR_VARIABLE;
|
e->symtree = st;
|
e->symtree = st;
|
e->ts.type = BT_INTEGER;
|
e->ts.type = BT_INTEGER;
|
e->ts.kind = st->n.sym->ts.kind;
|
e->ts.kind = st->n.sym->ts.kind;
|
|
|
return e;
|
return e;
|
}
|
}
|
|
|
|
|
/* Translate the non-IOLENGTH form of an INQUIRE statement. */
|
/* Translate the non-IOLENGTH form of an INQUIRE statement. */
|
|
|
tree
|
tree
|
gfc_trans_inquire (gfc_code * code)
|
gfc_trans_inquire (gfc_code * code)
|
{
|
{
|
stmtblock_t block, post_block;
|
stmtblock_t block, post_block;
|
gfc_inquire *p;
|
gfc_inquire *p;
|
tree tmp, var;
|
tree tmp, var;
|
unsigned int mask = 0, mask2 = 0;
|
unsigned int mask = 0, mask2 = 0;
|
|
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
gfc_init_block (&post_block);
|
gfc_init_block (&post_block);
|
|
|
var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type,
|
var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type,
|
"inquire_parm");
|
"inquire_parm");
|
|
|
set_error_locus (&block, var, &code->loc);
|
set_error_locus (&block, var, &code->loc);
|
p = code->ext.inquire;
|
p = code->ext.inquire;
|
|
|
if (p->iomsg)
|
if (p->iomsg)
|
mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
|
mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
|
p->iomsg);
|
p->iomsg);
|
|
|
if (p->iostat)
|
if (p->iostat)
|
mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
|
mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
|
p->iostat);
|
p->iostat);
|
|
|
if (p->err)
|
if (p->err)
|
mask |= IOPARM_common_err;
|
mask |= IOPARM_common_err;
|
|
|
/* Sanity check. */
|
/* Sanity check. */
|
if (p->unit && p->file)
|
if (p->unit && p->file)
|
gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc);
|
gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc);
|
|
|
if (p->file)
|
if (p->file)
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_file,
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_file,
|
p->file);
|
p->file);
|
|
|
if (p->exist)
|
if (p->exist)
|
{
|
{
|
mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist,
|
mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist,
|
p->exist);
|
p->exist);
|
|
|
if (p->unit && !p->iostat)
|
if (p->unit && !p->iostat)
|
{
|
{
|
p->iostat = create_dummy_iostat ();
|
p->iostat = create_dummy_iostat ();
|
mask |= set_parameter_ref (&block, &post_block, var,
|
mask |= set_parameter_ref (&block, &post_block, var,
|
IOPARM_common_iostat, p->iostat);
|
IOPARM_common_iostat, p->iostat);
|
}
|
}
|
}
|
}
|
|
|
if (p->opened)
|
if (p->opened)
|
mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened,
|
mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened,
|
p->opened);
|
p->opened);
|
|
|
if (p->number)
|
if (p->number)
|
mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number,
|
mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number,
|
p->number);
|
p->number);
|
|
|
if (p->named)
|
if (p->named)
|
mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named,
|
mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named,
|
p->named);
|
p->named);
|
|
|
if (p->name)
|
if (p->name)
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_name,
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_name,
|
p->name);
|
p->name);
|
|
|
if (p->access)
|
if (p->access)
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_access,
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_access,
|
p->access);
|
p->access);
|
|
|
if (p->sequential)
|
if (p->sequential)
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential,
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential,
|
p->sequential);
|
p->sequential);
|
|
|
if (p->direct)
|
if (p->direct)
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct,
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct,
|
p->direct);
|
p->direct);
|
|
|
if (p->form)
|
if (p->form)
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_form,
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_form,
|
p->form);
|
p->form);
|
|
|
if (p->formatted)
|
if (p->formatted)
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted,
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted,
|
p->formatted);
|
p->formatted);
|
|
|
if (p->unformatted)
|
if (p->unformatted)
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted,
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted,
|
p->unformatted);
|
p->unformatted);
|
|
|
if (p->recl)
|
if (p->recl)
|
mask |= set_parameter_ref (&block, &post_block, var,
|
mask |= set_parameter_ref (&block, &post_block, var,
|
IOPARM_inquire_recl_out, p->recl);
|
IOPARM_inquire_recl_out, p->recl);
|
|
|
if (p->nextrec)
|
if (p->nextrec)
|
mask |= set_parameter_ref (&block, &post_block, var,
|
mask |= set_parameter_ref (&block, &post_block, var,
|
IOPARM_inquire_nextrec, p->nextrec);
|
IOPARM_inquire_nextrec, p->nextrec);
|
|
|
if (p->blank)
|
if (p->blank)
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
|
p->blank);
|
p->blank);
|
|
|
if (p->delim)
|
if (p->delim)
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
|
p->delim);
|
p->delim);
|
|
|
if (p->position)
|
if (p->position)
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_position,
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_position,
|
p->position);
|
p->position);
|
|
|
if (p->action)
|
if (p->action)
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_action,
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_action,
|
p->action);
|
p->action);
|
|
|
if (p->read)
|
if (p->read)
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_read,
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_read,
|
p->read);
|
p->read);
|
|
|
if (p->write)
|
if (p->write)
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_write,
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_write,
|
p->write);
|
p->write);
|
|
|
if (p->readwrite)
|
if (p->readwrite)
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite,
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite,
|
p->readwrite);
|
p->readwrite);
|
|
|
if (p->pad)
|
if (p->pad)
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad,
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad,
|
p->pad);
|
p->pad);
|
|
|
if (p->convert)
|
if (p->convert)
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert,
|
mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert,
|
p->convert);
|
p->convert);
|
|
|
if (p->strm_pos)
|
if (p->strm_pos)
|
mask |= set_parameter_ref (&block, &post_block, var,
|
mask |= set_parameter_ref (&block, &post_block, var,
|
IOPARM_inquire_strm_pos_out, p->strm_pos);
|
IOPARM_inquire_strm_pos_out, p->strm_pos);
|
|
|
/* The second series of flags. */
|
/* The second series of flags. */
|
if (p->asynchronous)
|
if (p->asynchronous)
|
mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_asynchronous,
|
mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_asynchronous,
|
p->asynchronous);
|
p->asynchronous);
|
|
|
if (p->decimal)
|
if (p->decimal)
|
mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_decimal,
|
mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_decimal,
|
p->decimal);
|
p->decimal);
|
|
|
if (p->encoding)
|
if (p->encoding)
|
mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_encoding,
|
mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_encoding,
|
p->encoding);
|
p->encoding);
|
|
|
if (p->round)
|
if (p->round)
|
mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_round,
|
mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_round,
|
p->round);
|
p->round);
|
|
|
if (p->sign)
|
if (p->sign)
|
mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_sign,
|
mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_sign,
|
p->sign);
|
p->sign);
|
|
|
if (p->pending)
|
if (p->pending)
|
mask2 |= set_parameter_ref (&block, &post_block, var,
|
mask2 |= set_parameter_ref (&block, &post_block, var,
|
IOPARM_inquire_pending, p->pending);
|
IOPARM_inquire_pending, p->pending);
|
|
|
if (p->size)
|
if (p->size)
|
mask2 |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_size,
|
mask2 |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_size,
|
p->size);
|
p->size);
|
|
|
if (p->id)
|
if (p->id)
|
mask2 |= set_parameter_ref (&block, &post_block,var, IOPARM_inquire_id,
|
mask2 |= set_parameter_ref (&block, &post_block,var, IOPARM_inquire_id,
|
p->id);
|
p->id);
|
|
|
if (mask2)
|
if (mask2)
|
mask |= set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2);
|
mask |= set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2);
|
|
|
set_parameter_const (&block, var, IOPARM_common_flags, mask);
|
set_parameter_const (&block, var, IOPARM_common_flags, mask);
|
|
|
if (p->unit)
|
if (p->unit)
|
set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
|
set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
|
else
|
else
|
set_parameter_const (&block, var, IOPARM_common_unit, 0);
|
set_parameter_const (&block, var, IOPARM_common_unit, 0);
|
|
|
tmp = gfc_build_addr_expr (NULL_TREE, var);
|
tmp = gfc_build_addr_expr (NULL_TREE, var);
|
tmp = build_call_expr_loc (input_location,
|
tmp = build_call_expr_loc (input_location,
|
iocall[IOCALL_INQUIRE], 1, tmp);
|
iocall[IOCALL_INQUIRE], 1, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
gfc_add_block_to_block (&block, &post_block);
|
gfc_add_block_to_block (&block, &post_block);
|
|
|
io_result (&block, var, p->err, NULL, NULL);
|
io_result (&block, var, p->err, NULL, NULL);
|
|
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
|
|
tree
|
tree
|
gfc_trans_wait (gfc_code * code)
|
gfc_trans_wait (gfc_code * code)
|
{
|
{
|
stmtblock_t block, post_block;
|
stmtblock_t block, post_block;
|
gfc_wait *p;
|
gfc_wait *p;
|
tree tmp, var;
|
tree tmp, var;
|
unsigned int mask = 0;
|
unsigned int mask = 0;
|
|
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
gfc_init_block (&post_block);
|
gfc_init_block (&post_block);
|
|
|
var = gfc_create_var (st_parameter[IOPARM_ptype_wait].type,
|
var = gfc_create_var (st_parameter[IOPARM_ptype_wait].type,
|
"wait_parm");
|
"wait_parm");
|
|
|
set_error_locus (&block, var, &code->loc);
|
set_error_locus (&block, var, &code->loc);
|
p = code->ext.wait;
|
p = code->ext.wait;
|
|
|
/* Set parameters here. */
|
/* Set parameters here. */
|
if (p->iomsg)
|
if (p->iomsg)
|
mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
|
mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
|
p->iomsg);
|
p->iomsg);
|
|
|
if (p->iostat)
|
if (p->iostat)
|
mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
|
mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
|
p->iostat);
|
p->iostat);
|
|
|
if (p->err)
|
if (p->err)
|
mask |= IOPARM_common_err;
|
mask |= IOPARM_common_err;
|
|
|
if (p->id)
|
if (p->id)
|
mask |= set_parameter_value (&block, var, IOPARM_wait_id, p->id);
|
mask |= set_parameter_value (&block, var, IOPARM_wait_id, p->id);
|
|
|
set_parameter_const (&block, var, IOPARM_common_flags, mask);
|
set_parameter_const (&block, var, IOPARM_common_flags, mask);
|
|
|
if (p->unit)
|
if (p->unit)
|
set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
|
set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
|
|
|
tmp = gfc_build_addr_expr (NULL_TREE, var);
|
tmp = gfc_build_addr_expr (NULL_TREE, var);
|
tmp = build_call_expr_loc (input_location,
|
tmp = build_call_expr_loc (input_location,
|
iocall[IOCALL_WAIT], 1, tmp);
|
iocall[IOCALL_WAIT], 1, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
gfc_add_block_to_block (&block, &post_block);
|
gfc_add_block_to_block (&block, &post_block);
|
|
|
io_result (&block, var, p->err, NULL, NULL);
|
io_result (&block, var, p->err, NULL, NULL);
|
|
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
|
|
}
|
}
|
|
|
static gfc_expr *
|
static gfc_expr *
|
gfc_new_nml_name_expr (const char * name)
|
gfc_new_nml_name_expr (const char * name)
|
{
|
{
|
gfc_expr * nml_name;
|
gfc_expr * nml_name;
|
|
|
nml_name = gfc_get_expr();
|
nml_name = gfc_get_expr();
|
nml_name->ref = NULL;
|
nml_name->ref = NULL;
|
nml_name->expr_type = EXPR_CONSTANT;
|
nml_name->expr_type = EXPR_CONSTANT;
|
nml_name->ts.kind = gfc_default_character_kind;
|
nml_name->ts.kind = gfc_default_character_kind;
|
nml_name->ts.type = BT_CHARACTER;
|
nml_name->ts.type = BT_CHARACTER;
|
nml_name->value.character.length = strlen(name);
|
nml_name->value.character.length = strlen(name);
|
nml_name->value.character.string = gfc_char_to_widechar (name);
|
nml_name->value.character.string = gfc_char_to_widechar (name);
|
|
|
return nml_name;
|
return nml_name;
|
}
|
}
|
|
|
/* nml_full_name builds up the fully qualified name of a
|
/* nml_full_name builds up the fully qualified name of a
|
derived type component. */
|
derived type component. */
|
|
|
static char*
|
static char*
|
nml_full_name (const char* var_name, const char* cmp_name)
|
nml_full_name (const char* var_name, const char* cmp_name)
|
{
|
{
|
int full_name_length;
|
int full_name_length;
|
char * full_name;
|
char * full_name;
|
|
|
full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
|
full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
|
full_name = (char*)gfc_getmem (full_name_length + 1);
|
full_name = (char*)gfc_getmem (full_name_length + 1);
|
strcpy (full_name, var_name);
|
strcpy (full_name, var_name);
|
full_name = strcat (full_name, "%");
|
full_name = strcat (full_name, "%");
|
full_name = strcat (full_name, cmp_name);
|
full_name = strcat (full_name, cmp_name);
|
return full_name;
|
return full_name;
|
}
|
}
|
|
|
/* nml_get_addr_expr builds an address expression from the
|
/* nml_get_addr_expr builds an address expression from the
|
gfc_symbol or gfc_component backend_decl's. An offset is
|
gfc_symbol or gfc_component backend_decl's. An offset is
|
provided so that the address of an element of an array of
|
provided so that the address of an element of an array of
|
derived types is returned. This is used in the runtime to
|
derived types is returned. This is used in the runtime to
|
determine that span of the derived type. */
|
determine that span of the derived type. */
|
|
|
static tree
|
static tree
|
nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
|
nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
|
tree base_addr)
|
tree base_addr)
|
{
|
{
|
tree decl = NULL_TREE;
|
tree decl = NULL_TREE;
|
tree tmp;
|
tree tmp;
|
tree itmp;
|
tree itmp;
|
int array_flagged;
|
int array_flagged;
|
int dummy_arg_flagged;
|
int dummy_arg_flagged;
|
|
|
if (sym)
|
if (sym)
|
{
|
{
|
sym->attr.referenced = 1;
|
sym->attr.referenced = 1;
|
decl = gfc_get_symbol_decl (sym);
|
decl = gfc_get_symbol_decl (sym);
|
|
|
/* If this is the enclosing function declaration, use
|
/* If this is the enclosing function declaration, use
|
the fake result instead. */
|
the fake result instead. */
|
if (decl == current_function_decl)
|
if (decl == current_function_decl)
|
decl = gfc_get_fake_result_decl (sym, 0);
|
decl = gfc_get_fake_result_decl (sym, 0);
|
else if (decl == DECL_CONTEXT (current_function_decl))
|
else if (decl == DECL_CONTEXT (current_function_decl))
|
decl = gfc_get_fake_result_decl (sym, 1);
|
decl = gfc_get_fake_result_decl (sym, 1);
|
}
|
}
|
else
|
else
|
decl = c->backend_decl;
|
decl = c->backend_decl;
|
|
|
gcc_assert (decl && ((TREE_CODE (decl) == FIELD_DECL
|
gcc_assert (decl && ((TREE_CODE (decl) == FIELD_DECL
|
|| TREE_CODE (decl) == VAR_DECL
|
|| TREE_CODE (decl) == VAR_DECL
|
|| TREE_CODE (decl) == PARM_DECL)
|
|| TREE_CODE (decl) == PARM_DECL)
|
|| TREE_CODE (decl) == COMPONENT_REF));
|
|| TREE_CODE (decl) == COMPONENT_REF));
|
|
|
tmp = decl;
|
tmp = decl;
|
|
|
/* Build indirect reference, if dummy argument. */
|
/* Build indirect reference, if dummy argument. */
|
|
|
dummy_arg_flagged = POINTER_TYPE_P (TREE_TYPE(tmp));
|
dummy_arg_flagged = POINTER_TYPE_P (TREE_TYPE(tmp));
|
|
|
itmp = (dummy_arg_flagged) ? build_fold_indirect_ref_loc (input_location,
|
itmp = (dummy_arg_flagged) ? build_fold_indirect_ref_loc (input_location,
|
tmp) : tmp;
|
tmp) : tmp;
|
|
|
/* If an array, set flag and use indirect ref. if built. */
|
/* If an array, set flag and use indirect ref. if built. */
|
|
|
array_flagged = (TREE_CODE (TREE_TYPE (itmp)) == ARRAY_TYPE
|
array_flagged = (TREE_CODE (TREE_TYPE (itmp)) == ARRAY_TYPE
|
&& !TYPE_STRING_FLAG (TREE_TYPE (itmp)));
|
&& !TYPE_STRING_FLAG (TREE_TYPE (itmp)));
|
|
|
if (array_flagged)
|
if (array_flagged)
|
tmp = itmp;
|
tmp = itmp;
|
|
|
/* Treat the component of a derived type, using base_addr for
|
/* Treat the component of a derived type, using base_addr for
|
the derived type. */
|
the derived type. */
|
|
|
if (TREE_CODE (decl) == FIELD_DECL)
|
if (TREE_CODE (decl) == FIELD_DECL)
|
tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
|
tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
|
base_addr, tmp, NULL_TREE);
|
base_addr, tmp, NULL_TREE);
|
|
|
/* If we have a derived type component, a reference to the first
|
/* 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,
|
element of the array is built. This is done so that base_addr,
|
used in the build of the component reference, always points to
|
used in the build of the component reference, always points to
|
a RECORD_TYPE. */
|
a RECORD_TYPE. */
|
|
|
if (array_flagged)
|
if (array_flagged)
|
tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
|
tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
|
|
|
/* Now build the address expression. */
|
/* Now build the address expression. */
|
|
|
tmp = gfc_build_addr_expr (NULL_TREE, tmp);
|
tmp = gfc_build_addr_expr (NULL_TREE, tmp);
|
|
|
/* If scalar dummy, resolve indirect reference now. */
|
/* If scalar dummy, resolve indirect reference now. */
|
|
|
if (dummy_arg_flagged && !array_flagged)
|
if (dummy_arg_flagged && !array_flagged)
|
tmp = build_fold_indirect_ref_loc (input_location,
|
tmp = build_fold_indirect_ref_loc (input_location,
|
tmp);
|
tmp);
|
|
|
gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
|
gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
|
|
|
return tmp;
|
return tmp;
|
}
|
}
|
|
|
/* For an object VAR_NAME whose base address is BASE_ADDR, generate a
|
/* 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
|
call to iocall[IOCALL_SET_NML_VAL]. For derived type variable, recursively
|
generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
|
generate calls to iocall[IOCALL_SET_NML_VAL] for each component. */
|
|
|
#define IARG(i) build_int_cst (gfc_array_index_type, i)
|
#define IARG(i) build_int_cst (gfc_array_index_type, i)
|
|
|
static void
|
static void
|
transfer_namelist_element (stmtblock_t * block, const char * var_name,
|
transfer_namelist_element (stmtblock_t * block, const char * var_name,
|
gfc_symbol * sym, gfc_component * c,
|
gfc_symbol * sym, gfc_component * c,
|
tree base_addr)
|
tree base_addr)
|
{
|
{
|
gfc_typespec * ts = NULL;
|
gfc_typespec * ts = NULL;
|
gfc_array_spec * as = NULL;
|
gfc_array_spec * as = NULL;
|
tree addr_expr = NULL;
|
tree addr_expr = NULL;
|
tree dt = NULL;
|
tree dt = NULL;
|
tree string;
|
tree string;
|
tree tmp;
|
tree tmp;
|
tree dtype;
|
tree dtype;
|
tree dt_parm_addr;
|
tree dt_parm_addr;
|
int n_dim;
|
int n_dim;
|
int itype;
|
int itype;
|
int rank = 0;
|
int rank = 0;
|
|
|
gcc_assert (sym || c);
|
gcc_assert (sym || c);
|
|
|
/* Build the namelist object name. */
|
/* Build the namelist object name. */
|
|
|
string = gfc_build_cstring_const (var_name);
|
string = gfc_build_cstring_const (var_name);
|
string = gfc_build_addr_expr (pchar_type_node, string);
|
string = gfc_build_addr_expr (pchar_type_node, string);
|
|
|
/* Build ts, as and data address using symbol or component. */
|
/* Build ts, as and data address using symbol or component. */
|
|
|
ts = (sym) ? &sym->ts : &c->ts;
|
ts = (sym) ? &sym->ts : &c->ts;
|
as = (sym) ? sym->as : c->as;
|
as = (sym) ? sym->as : c->as;
|
|
|
addr_expr = nml_get_addr_expr (sym, c, base_addr);
|
addr_expr = nml_get_addr_expr (sym, c, base_addr);
|
|
|
if (as)
|
if (as)
|
rank = as->rank;
|
rank = as->rank;
|
|
|
if (rank)
|
if (rank)
|
{
|
{
|
dt = TREE_TYPE ((sym) ? sym->backend_decl : c->backend_decl);
|
dt = TREE_TYPE ((sym) ? sym->backend_decl : c->backend_decl);
|
dtype = gfc_get_dtype (dt);
|
dtype = gfc_get_dtype (dt);
|
}
|
}
|
else
|
else
|
{
|
{
|
itype = GFC_DTYPE_UNKNOWN;
|
itype = GFC_DTYPE_UNKNOWN;
|
|
|
switch (ts->type)
|
switch (ts->type)
|
|
|
{
|
{
|
case BT_INTEGER:
|
case BT_INTEGER:
|
itype = GFC_DTYPE_INTEGER;
|
itype = GFC_DTYPE_INTEGER;
|
break;
|
break;
|
case BT_LOGICAL:
|
case BT_LOGICAL:
|
itype = GFC_DTYPE_LOGICAL;
|
itype = GFC_DTYPE_LOGICAL;
|
break;
|
break;
|
case BT_REAL:
|
case BT_REAL:
|
itype = GFC_DTYPE_REAL;
|
itype = GFC_DTYPE_REAL;
|
break;
|
break;
|
case BT_COMPLEX:
|
case BT_COMPLEX:
|
itype = GFC_DTYPE_COMPLEX;
|
itype = GFC_DTYPE_COMPLEX;
|
break;
|
break;
|
case BT_DERIVED:
|
case BT_DERIVED:
|
itype = GFC_DTYPE_DERIVED;
|
itype = GFC_DTYPE_DERIVED;
|
break;
|
break;
|
case BT_CHARACTER:
|
case BT_CHARACTER:
|
itype = GFC_DTYPE_CHARACTER;
|
itype = GFC_DTYPE_CHARACTER;
|
break;
|
break;
|
default:
|
default:
|
gcc_unreachable ();
|
gcc_unreachable ();
|
}
|
}
|
|
|
dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
|
dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
|
}
|
}
|
|
|
/* Build up the arguments for the transfer call.
|
/* Build up the arguments for the transfer call.
|
The call for the scalar part transfers:
|
The call for the scalar part transfers:
|
(address, name, type, kind or string_length, dtype) */
|
(address, name, type, kind or string_length, dtype) */
|
|
|
dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
|
dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
|
|
|
if (ts->type == BT_CHARACTER)
|
if (ts->type == BT_CHARACTER)
|
tmp = ts->u.cl->backend_decl;
|
tmp = ts->u.cl->backend_decl;
|
else
|
else
|
tmp = build_int_cst (gfc_charlen_type_node, 0);
|
tmp = build_int_cst (gfc_charlen_type_node, 0);
|
tmp = build_call_expr_loc (input_location,
|
tmp = build_call_expr_loc (input_location,
|
iocall[IOCALL_SET_NML_VAL], 6,
|
iocall[IOCALL_SET_NML_VAL], 6,
|
dt_parm_addr, addr_expr, string,
|
dt_parm_addr, addr_expr, string,
|
IARG (ts->kind), tmp, dtype);
|
IARG (ts->kind), tmp, dtype);
|
gfc_add_expr_to_block (block, tmp);
|
gfc_add_expr_to_block (block, tmp);
|
|
|
/* If the object is an array, transfer rank times:
|
/* If the object is an array, transfer rank times:
|
(null pointer, name, stride, lbound, ubound) */
|
(null pointer, name, stride, lbound, ubound) */
|
|
|
for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
|
for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
|
{
|
{
|
tmp = build_call_expr_loc (input_location,
|
tmp = build_call_expr_loc (input_location,
|
iocall[IOCALL_SET_NML_VAL_DIM], 5,
|
iocall[IOCALL_SET_NML_VAL_DIM], 5,
|
dt_parm_addr,
|
dt_parm_addr,
|
IARG (n_dim),
|
IARG (n_dim),
|
GFC_TYPE_ARRAY_STRIDE (dt, n_dim),
|
GFC_TYPE_ARRAY_STRIDE (dt, n_dim),
|
GFC_TYPE_ARRAY_LBOUND (dt, n_dim),
|
GFC_TYPE_ARRAY_LBOUND (dt, n_dim),
|
GFC_TYPE_ARRAY_UBOUND (dt, n_dim));
|
GFC_TYPE_ARRAY_UBOUND (dt, n_dim));
|
gfc_add_expr_to_block (block, tmp);
|
gfc_add_expr_to_block (block, tmp);
|
}
|
}
|
|
|
if (ts->type == BT_DERIVED)
|
if (ts->type == BT_DERIVED)
|
{
|
{
|
gfc_component *cmp;
|
gfc_component *cmp;
|
|
|
/* Provide the RECORD_TYPE to build component references. */
|
/* Provide the RECORD_TYPE to build component references. */
|
|
|
tree expr = build_fold_indirect_ref_loc (input_location,
|
tree expr = build_fold_indirect_ref_loc (input_location,
|
addr_expr);
|
addr_expr);
|
|
|
for (cmp = ts->u.derived->components; cmp; cmp = cmp->next)
|
for (cmp = ts->u.derived->components; cmp; cmp = cmp->next)
|
{
|
{
|
char *full_name = nml_full_name (var_name, cmp->name);
|
char *full_name = nml_full_name (var_name, cmp->name);
|
transfer_namelist_element (block,
|
transfer_namelist_element (block,
|
full_name,
|
full_name,
|
NULL, cmp, expr);
|
NULL, cmp, expr);
|
gfc_free (full_name);
|
gfc_free (full_name);
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
#undef IARG
|
#undef IARG
|
|
|
/* Create a data transfer statement. Not all of the fields are valid
|
/* Create a data transfer statement. Not all of the fields are valid
|
for both reading and writing, but improper use has been filtered
|
for both reading and writing, but improper use has been filtered
|
out by now. */
|
out by now. */
|
|
|
static tree
|
static tree
|
build_dt (tree function, gfc_code * code)
|
build_dt (tree function, gfc_code * code)
|
{
|
{
|
stmtblock_t block, post_block, post_end_block, post_iu_block;
|
stmtblock_t block, post_block, post_end_block, post_iu_block;
|
gfc_dt *dt;
|
gfc_dt *dt;
|
tree tmp, var;
|
tree tmp, var;
|
gfc_expr *nmlname;
|
gfc_expr *nmlname;
|
gfc_namelist *nml;
|
gfc_namelist *nml;
|
unsigned int mask = 0;
|
unsigned int mask = 0;
|
|
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
gfc_init_block (&post_block);
|
gfc_init_block (&post_block);
|
gfc_init_block (&post_end_block);
|
gfc_init_block (&post_end_block);
|
gfc_init_block (&post_iu_block);
|
gfc_init_block (&post_iu_block);
|
|
|
var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
|
var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
|
|
|
set_error_locus (&block, var, &code->loc);
|
set_error_locus (&block, var, &code->loc);
|
|
|
if (last_dt == IOLENGTH)
|
if (last_dt == IOLENGTH)
|
{
|
{
|
gfc_inquire *inq;
|
gfc_inquire *inq;
|
|
|
inq = code->ext.inquire;
|
inq = code->ext.inquire;
|
|
|
/* First check that preconditions are met. */
|
/* First check that preconditions are met. */
|
gcc_assert (inq != NULL);
|
gcc_assert (inq != NULL);
|
gcc_assert (inq->iolength != NULL);
|
gcc_assert (inq->iolength != NULL);
|
|
|
/* Connect to the iolength variable. */
|
/* Connect to the iolength variable. */
|
mask |= set_parameter_ref (&block, &post_end_block, var,
|
mask |= set_parameter_ref (&block, &post_end_block, var,
|
IOPARM_dt_iolength, inq->iolength);
|
IOPARM_dt_iolength, inq->iolength);
|
dt = NULL;
|
dt = NULL;
|
}
|
}
|
else
|
else
|
{
|
{
|
dt = code->ext.dt;
|
dt = code->ext.dt;
|
gcc_assert (dt != NULL);
|
gcc_assert (dt != NULL);
|
}
|
}
|
|
|
if (dt && dt->io_unit)
|
if (dt && dt->io_unit)
|
{
|
{
|
if (dt->io_unit->ts.type == BT_CHARACTER)
|
if (dt->io_unit->ts.type == BT_CHARACTER)
|
{
|
{
|
mask |= set_internal_unit (&block, &post_iu_block,
|
mask |= set_internal_unit (&block, &post_iu_block,
|
var, dt->io_unit);
|
var, dt->io_unit);
|
set_parameter_const (&block, var, IOPARM_common_unit, 0);
|
set_parameter_const (&block, var, IOPARM_common_unit, 0);
|
}
|
}
|
}
|
}
|
else
|
else
|
set_parameter_const (&block, var, IOPARM_common_unit, 0);
|
set_parameter_const (&block, var, IOPARM_common_unit, 0);
|
|
|
if (dt)
|
if (dt)
|
{
|
{
|
if (dt->iomsg)
|
if (dt->iomsg)
|
mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
|
mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
|
dt->iomsg);
|
dt->iomsg);
|
|
|
if (dt->iostat)
|
if (dt->iostat)
|
mask |= set_parameter_ref (&block, &post_end_block, var,
|
mask |= set_parameter_ref (&block, &post_end_block, var,
|
IOPARM_common_iostat, dt->iostat);
|
IOPARM_common_iostat, dt->iostat);
|
|
|
if (dt->err)
|
if (dt->err)
|
mask |= IOPARM_common_err;
|
mask |= IOPARM_common_err;
|
|
|
if (dt->eor)
|
if (dt->eor)
|
mask |= IOPARM_common_eor;
|
mask |= IOPARM_common_eor;
|
|
|
if (dt->end)
|
if (dt->end)
|
mask |= IOPARM_common_end;
|
mask |= IOPARM_common_end;
|
|
|
if (dt->id)
|
if (dt->id)
|
mask |= set_parameter_ref (&block, &post_end_block, var,
|
mask |= set_parameter_ref (&block, &post_end_block, var,
|
IOPARM_dt_id, dt->id);
|
IOPARM_dt_id, dt->id);
|
|
|
if (dt->pos)
|
if (dt->pos)
|
mask |= set_parameter_value (&block, var, IOPARM_dt_pos, dt->pos);
|
mask |= set_parameter_value (&block, var, IOPARM_dt_pos, dt->pos);
|
|
|
if (dt->asynchronous)
|
if (dt->asynchronous)
|
mask |= set_string (&block, &post_block, var, IOPARM_dt_asynchronous,
|
mask |= set_string (&block, &post_block, var, IOPARM_dt_asynchronous,
|
dt->asynchronous);
|
dt->asynchronous);
|
|
|
if (dt->blank)
|
if (dt->blank)
|
mask |= set_string (&block, &post_block, var, IOPARM_dt_blank,
|
mask |= set_string (&block, &post_block, var, IOPARM_dt_blank,
|
dt->blank);
|
dt->blank);
|
|
|
if (dt->decimal)
|
if (dt->decimal)
|
mask |= set_string (&block, &post_block, var, IOPARM_dt_decimal,
|
mask |= set_string (&block, &post_block, var, IOPARM_dt_decimal,
|
dt->decimal);
|
dt->decimal);
|
|
|
if (dt->delim)
|
if (dt->delim)
|
mask |= set_string (&block, &post_block, var, IOPARM_dt_delim,
|
mask |= set_string (&block, &post_block, var, IOPARM_dt_delim,
|
dt->delim);
|
dt->delim);
|
|
|
if (dt->pad)
|
if (dt->pad)
|
mask |= set_string (&block, &post_block, var, IOPARM_dt_pad,
|
mask |= set_string (&block, &post_block, var, IOPARM_dt_pad,
|
dt->pad);
|
dt->pad);
|
|
|
if (dt->round)
|
if (dt->round)
|
mask |= set_string (&block, &post_block, var, IOPARM_dt_round,
|
mask |= set_string (&block, &post_block, var, IOPARM_dt_round,
|
dt->round);
|
dt->round);
|
|
|
if (dt->sign)
|
if (dt->sign)
|
mask |= set_string (&block, &post_block, var, IOPARM_dt_sign,
|
mask |= set_string (&block, &post_block, var, IOPARM_dt_sign,
|
dt->sign);
|
dt->sign);
|
|
|
if (dt->rec)
|
if (dt->rec)
|
mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
|
mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
|
|
|
if (dt->advance)
|
if (dt->advance)
|
mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
|
mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
|
dt->advance);
|
dt->advance);
|
|
|
if (dt->format_expr)
|
if (dt->format_expr)
|
mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format,
|
mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format,
|
dt->format_expr);
|
dt->format_expr);
|
|
|
if (dt->format_label)
|
if (dt->format_label)
|
{
|
{
|
if (dt->format_label == &format_asterisk)
|
if (dt->format_label == &format_asterisk)
|
mask |= IOPARM_dt_list_format;
|
mask |= IOPARM_dt_list_format;
|
else
|
else
|
mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
|
mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
|
dt->format_label->format);
|
dt->format_label->format);
|
}
|
}
|
|
|
if (dt->size)
|
if (dt->size)
|
mask |= set_parameter_ref (&block, &post_end_block, var,
|
mask |= set_parameter_ref (&block, &post_end_block, var,
|
IOPARM_dt_size, dt->size);
|
IOPARM_dt_size, dt->size);
|
|
|
if (dt->namelist)
|
if (dt->namelist)
|
{
|
{
|
if (dt->format_expr || dt->format_label)
|
if (dt->format_expr || dt->format_label)
|
gfc_internal_error ("build_dt: format with namelist");
|
gfc_internal_error ("build_dt: format with namelist");
|
|
|
nmlname = gfc_new_nml_name_expr (dt->namelist->name);
|
nmlname = gfc_new_nml_name_expr (dt->namelist->name);
|
|
|
mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
|
mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
|
nmlname);
|
nmlname);
|
|
|
if (last_dt == READ)
|
if (last_dt == READ)
|
mask |= IOPARM_dt_namelist_read_mode;
|
mask |= IOPARM_dt_namelist_read_mode;
|
|
|
set_parameter_const (&block, var, IOPARM_common_flags, mask);
|
set_parameter_const (&block, var, IOPARM_common_flags, mask);
|
|
|
dt_parm = var;
|
dt_parm = var;
|
|
|
for (nml = dt->namelist->namelist; nml; nml = nml->next)
|
for (nml = dt->namelist->namelist; nml; nml = nml->next)
|
transfer_namelist_element (&block, nml->sym->name, nml->sym,
|
transfer_namelist_element (&block, nml->sym->name, nml->sym,
|
NULL, NULL);
|
NULL, NULL);
|
}
|
}
|
else
|
else
|
set_parameter_const (&block, var, IOPARM_common_flags, mask);
|
set_parameter_const (&block, var, IOPARM_common_flags, mask);
|
|
|
if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER)
|
if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER)
|
set_parameter_value (&block, var, IOPARM_common_unit, dt->io_unit);
|
set_parameter_value (&block, var, IOPARM_common_unit, dt->io_unit);
|
}
|
}
|
else
|
else
|
set_parameter_const (&block, var, IOPARM_common_flags, mask);
|
set_parameter_const (&block, var, IOPARM_common_flags, mask);
|
|
|
tmp = gfc_build_addr_expr (NULL_TREE, var);
|
tmp = gfc_build_addr_expr (NULL_TREE, var);
|
tmp = build_call_expr_loc (UNKNOWN_LOCATION,
|
tmp = build_call_expr_loc (UNKNOWN_LOCATION,
|
function, 1, tmp);
|
function, 1, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
gfc_add_block_to_block (&block, &post_block);
|
gfc_add_block_to_block (&block, &post_block);
|
|
|
dt_parm = var;
|
dt_parm = var;
|
dt_post_end_block = &post_end_block;
|
dt_post_end_block = &post_end_block;
|
|
|
/* Set implied do loop exit condition. */
|
/* Set implied do loop exit condition. */
|
if (last_dt == READ || last_dt == WRITE)
|
if (last_dt == READ || last_dt == WRITE)
|
{
|
{
|
gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
|
gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
|
|
|
tmp = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
|
tmp = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
|
dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)), NULL_TREE);
|
dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)), NULL_TREE);
|
tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
|
tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
|
tmp, p->field, NULL_TREE);
|
tmp, p->field, NULL_TREE);
|
tmp = fold_build2 (BIT_AND_EXPR, TREE_TYPE (tmp),
|
tmp = fold_build2 (BIT_AND_EXPR, TREE_TYPE (tmp),
|
tmp, build_int_cst (TREE_TYPE (tmp),
|
tmp, build_int_cst (TREE_TYPE (tmp),
|
IOPARM_common_libreturn_mask));
|
IOPARM_common_libreturn_mask));
|
}
|
}
|
else /* IOLENGTH */
|
else /* IOLENGTH */
|
tmp = NULL_TREE;
|
tmp = NULL_TREE;
|
|
|
gfc_add_expr_to_block (&block, gfc_trans_code_cond (code->block->next, tmp));
|
gfc_add_expr_to_block (&block, gfc_trans_code_cond (code->block->next, tmp));
|
|
|
gfc_add_block_to_block (&block, &post_iu_block);
|
gfc_add_block_to_block (&block, &post_iu_block);
|
|
|
dt_parm = NULL;
|
dt_parm = NULL;
|
dt_post_end_block = NULL;
|
dt_post_end_block = NULL;
|
|
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
|
|
/* Translate the IOLENGTH form of an INQUIRE statement. We treat
|
/* Translate the IOLENGTH form of an INQUIRE statement. We treat
|
this as a third sort of data transfer statement, except that
|
this as a third sort of data transfer statement, except that
|
lengths are summed instead of actually transferring any data. */
|
lengths are summed instead of actually transferring any data. */
|
|
|
tree
|
tree
|
gfc_trans_iolength (gfc_code * code)
|
gfc_trans_iolength (gfc_code * code)
|
{
|
{
|
last_dt = IOLENGTH;
|
last_dt = IOLENGTH;
|
return build_dt (iocall[IOCALL_IOLENGTH], code);
|
return build_dt (iocall[IOCALL_IOLENGTH], code);
|
}
|
}
|
|
|
|
|
/* Translate a READ statement. */
|
/* Translate a READ statement. */
|
|
|
tree
|
tree
|
gfc_trans_read (gfc_code * code)
|
gfc_trans_read (gfc_code * code)
|
{
|
{
|
last_dt = READ;
|
last_dt = READ;
|
return build_dt (iocall[IOCALL_READ], code);
|
return build_dt (iocall[IOCALL_READ], code);
|
}
|
}
|
|
|
|
|
/* Translate a WRITE statement */
|
/* Translate a WRITE statement */
|
|
|
tree
|
tree
|
gfc_trans_write (gfc_code * code)
|
gfc_trans_write (gfc_code * code)
|
{
|
{
|
last_dt = WRITE;
|
last_dt = WRITE;
|
return build_dt (iocall[IOCALL_WRITE], code);
|
return build_dt (iocall[IOCALL_WRITE], code);
|
}
|
}
|
|
|
|
|
/* Finish a data transfer statement. */
|
/* Finish a data transfer statement. */
|
|
|
tree
|
tree
|
gfc_trans_dt_end (gfc_code * code)
|
gfc_trans_dt_end (gfc_code * code)
|
{
|
{
|
tree function, tmp;
|
tree function, tmp;
|
stmtblock_t block;
|
stmtblock_t block;
|
|
|
gfc_init_block (&block);
|
gfc_init_block (&block);
|
|
|
switch (last_dt)
|
switch (last_dt)
|
{
|
{
|
case READ:
|
case READ:
|
function = iocall[IOCALL_READ_DONE];
|
function = iocall[IOCALL_READ_DONE];
|
break;
|
break;
|
|
|
case WRITE:
|
case WRITE:
|
function = iocall[IOCALL_WRITE_DONE];
|
function = iocall[IOCALL_WRITE_DONE];
|
break;
|
break;
|
|
|
case IOLENGTH:
|
case IOLENGTH:
|
function = iocall[IOCALL_IOLENGTH_DONE];
|
function = iocall[IOCALL_IOLENGTH_DONE];
|
break;
|
break;
|
|
|
default:
|
default:
|
gcc_unreachable ();
|
gcc_unreachable ();
|
}
|
}
|
|
|
tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
|
tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
|
tmp = build_call_expr_loc (input_location,
|
tmp = build_call_expr_loc (input_location,
|
function, 1, tmp);
|
function, 1, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_block_to_block (&block, dt_post_end_block);
|
gfc_add_block_to_block (&block, dt_post_end_block);
|
gfc_init_block (dt_post_end_block);
|
gfc_init_block (dt_post_end_block);
|
|
|
if (last_dt != IOLENGTH)
|
if (last_dt != IOLENGTH)
|
{
|
{
|
gcc_assert (code->ext.dt != NULL);
|
gcc_assert (code->ext.dt != NULL);
|
io_result (&block, dt_parm, code->ext.dt->err,
|
io_result (&block, dt_parm, code->ext.dt->err,
|
code->ext.dt->end, code->ext.dt->eor);
|
code->ext.dt->end, code->ext.dt->eor);
|
}
|
}
|
|
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
static void
|
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);
|
|
|
/* Given an array field in a derived type variable, generate the 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
|
for the loop that iterates over array elements, and the code that
|
accesses those array elements. Use transfer_expr to generate code
|
accesses those array elements. Use transfer_expr to generate code
|
for transferring that element. Because elements may also be
|
for transferring that element. Because elements may also be
|
derived types, transfer_expr and transfer_array_component are mutually
|
derived types, transfer_expr and transfer_array_component are mutually
|
recursive. */
|
recursive. */
|
|
|
static tree
|
static tree
|
transfer_array_component (tree expr, gfc_component * cm, locus * where)
|
transfer_array_component (tree expr, gfc_component * cm, locus * where)
|
{
|
{
|
tree tmp;
|
tree tmp;
|
stmtblock_t body;
|
stmtblock_t body;
|
stmtblock_t block;
|
stmtblock_t block;
|
gfc_loopinfo loop;
|
gfc_loopinfo loop;
|
int n;
|
int n;
|
gfc_ss *ss;
|
gfc_ss *ss;
|
gfc_se se;
|
gfc_se se;
|
|
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
|
|
/* Create and initialize Scalarization Status. Unlike in
|
/* Create and initialize Scalarization Status. Unlike in
|
gfc_trans_transfer, we can't simply use gfc_walk_expr to take
|
gfc_trans_transfer, we can't simply use gfc_walk_expr to take
|
care of this task, because we don't have a gfc_expr at hand.
|
care of this task, because we don't have a gfc_expr at hand.
|
Build one manually, as in gfc_trans_subarray_assign. */
|
Build one manually, as in gfc_trans_subarray_assign. */
|
|
|
ss = gfc_get_ss ();
|
ss = gfc_get_ss ();
|
ss->type = GFC_SS_COMPONENT;
|
ss->type = GFC_SS_COMPONENT;
|
ss->expr = NULL;
|
ss->expr = NULL;
|
ss->shape = gfc_get_shape (cm->as->rank);
|
ss->shape = gfc_get_shape (cm->as->rank);
|
ss->next = gfc_ss_terminator;
|
ss->next = gfc_ss_terminator;
|
ss->data.info.dimen = cm->as->rank;
|
ss->data.info.dimen = cm->as->rank;
|
ss->data.info.descriptor = expr;
|
ss->data.info.descriptor = expr;
|
ss->data.info.data = gfc_conv_array_data (expr);
|
ss->data.info.data = gfc_conv_array_data (expr);
|
ss->data.info.offset = gfc_conv_array_offset (expr);
|
ss->data.info.offset = gfc_conv_array_offset (expr);
|
for (n = 0; n < cm->as->rank; n++)
|
for (n = 0; n < cm->as->rank; n++)
|
{
|
{
|
ss->data.info.dim[n] = n;
|
ss->data.info.dim[n] = n;
|
ss->data.info.start[n] = gfc_conv_array_lbound (expr, n);
|
ss->data.info.start[n] = gfc_conv_array_lbound (expr, n);
|
ss->data.info.stride[n] = gfc_index_one_node;
|
ss->data.info.stride[n] = gfc_index_one_node;
|
|
|
mpz_init (ss->shape[n]);
|
mpz_init (ss->shape[n]);
|
mpz_sub (ss->shape[n], cm->as->upper[n]->value.integer,
|
mpz_sub (ss->shape[n], cm->as->upper[n]->value.integer,
|
cm->as->lower[n]->value.integer);
|
cm->as->lower[n]->value.integer);
|
mpz_add_ui (ss->shape[n], ss->shape[n], 1);
|
mpz_add_ui (ss->shape[n], ss->shape[n], 1);
|
}
|
}
|
|
|
/* Once we got ss, we use scalarizer to create the loop. */
|
/* Once we got ss, we use scalarizer to create the loop. */
|
|
|
gfc_init_loopinfo (&loop);
|
gfc_init_loopinfo (&loop);
|
gfc_add_ss_to_loop (&loop, ss);
|
gfc_add_ss_to_loop (&loop, ss);
|
gfc_conv_ss_startstride (&loop);
|
gfc_conv_ss_startstride (&loop);
|
gfc_conv_loop_setup (&loop, where);
|
gfc_conv_loop_setup (&loop, where);
|
gfc_mark_ss_chain_used (ss, 1);
|
gfc_mark_ss_chain_used (ss, 1);
|
gfc_start_scalarized_body (&loop, &body);
|
gfc_start_scalarized_body (&loop, &body);
|
|
|
gfc_copy_loopinfo_to_se (&se, &loop);
|
gfc_copy_loopinfo_to_se (&se, &loop);
|
se.ss = ss;
|
se.ss = ss;
|
|
|
/* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
|
/* gfc_conv_tmp_array_ref assumes that se.expr contains the array. */
|
se.expr = expr;
|
se.expr = expr;
|
gfc_conv_tmp_array_ref (&se);
|
gfc_conv_tmp_array_ref (&se);
|
|
|
/* Now se.expr contains an element of the array. Take the address and pass
|
/* Now se.expr contains an element of the array. Take the address and pass
|
it to the IO routines. */
|
it to the IO routines. */
|
tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
|
tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
|
transfer_expr (&se, &cm->ts, tmp, NULL);
|
transfer_expr (&se, &cm->ts, tmp, NULL);
|
|
|
/* We are done now with the loop body. Wrap up the scalarizer and
|
/* We are done now with the loop body. Wrap up the scalarizer and
|
return. */
|
return. */
|
|
|
gfc_add_block_to_block (&body, &se.pre);
|
gfc_add_block_to_block (&body, &se.pre);
|
gfc_add_block_to_block (&body, &se.post);
|
gfc_add_block_to_block (&body, &se.post);
|
|
|
gfc_trans_scalarizing_loops (&loop, &body);
|
gfc_trans_scalarizing_loops (&loop, &body);
|
|
|
gfc_add_block_to_block (&block, &loop.pre);
|
gfc_add_block_to_block (&block, &loop.pre);
|
gfc_add_block_to_block (&block, &loop.post);
|
gfc_add_block_to_block (&block, &loop.post);
|
|
|
for (n = 0; n < cm->as->rank; n++)
|
for (n = 0; n < cm->as->rank; n++)
|
mpz_clear (ss->shape[n]);
|
mpz_clear (ss->shape[n]);
|
gfc_free (ss->shape);
|
gfc_free (ss->shape);
|
|
|
gfc_cleanup_loop (&loop);
|
gfc_cleanup_loop (&loop);
|
|
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
/* Generate the call for a scalar transfer node. */
|
/* Generate the call for a scalar transfer node. */
|
|
|
static void
|
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 tmp, function, arg2, arg3, field, expr;
|
tree tmp, function, arg2, arg3, field, expr;
|
gfc_component *c;
|
gfc_component *c;
|
int kind;
|
int kind;
|
|
|
/* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
|
/* 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
|
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
|
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
|
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
|
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). */
|
BT_DERIVED (could have been changed by gfc_conv_expr). */
|
if ((ts->type == BT_DERIVED || ts->type == BT_INTEGER)
|
if ((ts->type == BT_DERIVED || ts->type == BT_INTEGER)
|
&& ts->u.derived != NULL
|
&& ts->u.derived != NULL
|
&& (ts->is_iso_c == 1 || ts->u.derived->ts.is_iso_c == 1))
|
&& (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
|
/* C_PTR and C_FUNPTR have private components which means they can not
|
be printed. However, if -std=gnu and not -pedantic, allow
|
be printed. However, if -std=gnu and not -pedantic, allow
|
the component to be printed to help debugging. */
|
the component to be printed to help debugging. */
|
if (gfc_notification_std (GFC_STD_GNU) != SILENT)
|
if (gfc_notification_std (GFC_STD_GNU) != SILENT)
|
{
|
{
|
gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
|
gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
|
ts->u.derived->name, code != NULL ? &(code->loc) :
|
ts->u.derived->name, code != NULL ? &(code->loc) :
|
&gfc_current_locus);
|
&gfc_current_locus);
|
return;
|
return;
|
}
|
}
|
|
|
ts->type = ts->u.derived->ts.type;
|
ts->type = ts->u.derived->ts.type;
|
ts->kind = ts->u.derived->ts.kind;
|
ts->kind = ts->u.derived->ts.kind;
|
ts->f90_type = ts->u.derived->ts.f90_type;
|
ts->f90_type = ts->u.derived->ts.f90_type;
|
}
|
}
|
|
|
kind = ts->kind;
|
kind = ts->kind;
|
function = NULL;
|
function = NULL;
|
arg2 = NULL;
|
arg2 = NULL;
|
arg3 = NULL;
|
arg3 = NULL;
|
|
|
switch (ts->type)
|
switch (ts->type)
|
{
|
{
|
case BT_INTEGER:
|
case BT_INTEGER:
|
arg2 = build_int_cst (NULL_TREE, kind);
|
arg2 = build_int_cst (NULL_TREE, kind);
|
function = iocall[IOCALL_X_INTEGER];
|
function = iocall[IOCALL_X_INTEGER];
|
break;
|
break;
|
|
|
case BT_REAL:
|
case BT_REAL:
|
arg2 = build_int_cst (NULL_TREE, kind);
|
arg2 = build_int_cst (NULL_TREE, kind);
|
function = iocall[IOCALL_X_REAL];
|
function = iocall[IOCALL_X_REAL];
|
break;
|
break;
|
|
|
case BT_COMPLEX:
|
case BT_COMPLEX:
|
arg2 = build_int_cst (NULL_TREE, kind);
|
arg2 = build_int_cst (NULL_TREE, kind);
|
function = iocall[IOCALL_X_COMPLEX];
|
function = iocall[IOCALL_X_COMPLEX];
|
break;
|
break;
|
|
|
case BT_LOGICAL:
|
case BT_LOGICAL:
|
arg2 = build_int_cst (NULL_TREE, kind);
|
arg2 = build_int_cst (NULL_TREE, kind);
|
function = iocall[IOCALL_X_LOGICAL];
|
function = iocall[IOCALL_X_LOGICAL];
|
break;
|
break;
|
|
|
case BT_CHARACTER:
|
case BT_CHARACTER:
|
if (kind == 4)
|
if (kind == 4)
|
{
|
{
|
if (se->string_length)
|
if (se->string_length)
|
arg2 = se->string_length;
|
arg2 = se->string_length;
|
else
|
else
|
{
|
{
|
tmp = build_fold_indirect_ref_loc (input_location,
|
tmp = build_fold_indirect_ref_loc (input_location,
|
addr_expr);
|
addr_expr);
|
gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
|
gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
|
arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
|
arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
|
arg2 = fold_convert (gfc_charlen_type_node, arg2);
|
arg2 = fold_convert (gfc_charlen_type_node, arg2);
|
}
|
}
|
arg3 = build_int_cst (NULL_TREE, kind);
|
arg3 = build_int_cst (NULL_TREE, kind);
|
function = iocall[IOCALL_X_CHARACTER_WIDE];
|
function = iocall[IOCALL_X_CHARACTER_WIDE];
|
tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
|
tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
|
tmp = build_call_expr_loc (input_location,
|
tmp = build_call_expr_loc (input_location,
|
function, 4, tmp, addr_expr, arg2, arg3);
|
function, 4, tmp, addr_expr, arg2, arg3);
|
gfc_add_expr_to_block (&se->pre, tmp);
|
gfc_add_expr_to_block (&se->pre, tmp);
|
gfc_add_block_to_block (&se->pre, &se->post);
|
gfc_add_block_to_block (&se->pre, &se->post);
|
return;
|
return;
|
}
|
}
|
/* Fall through. */
|
/* Fall through. */
|
case BT_HOLLERITH:
|
case BT_HOLLERITH:
|
if (se->string_length)
|
if (se->string_length)
|
arg2 = se->string_length;
|
arg2 = se->string_length;
|
else
|
else
|
{
|
{
|
tmp = build_fold_indirect_ref_loc (input_location,
|
tmp = build_fold_indirect_ref_loc (input_location,
|
addr_expr);
|
addr_expr);
|
gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
|
gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
|
arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
|
arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
|
}
|
}
|
function = iocall[IOCALL_X_CHARACTER];
|
function = iocall[IOCALL_X_CHARACTER];
|
break;
|
break;
|
|
|
case BT_DERIVED:
|
case BT_DERIVED:
|
/* Recurse into the elements of the derived type. */
|
/* Recurse into the elements of the derived type. */
|
expr = gfc_evaluate_now (addr_expr, &se->pre);
|
expr = gfc_evaluate_now (addr_expr, &se->pre);
|
expr = build_fold_indirect_ref_loc (input_location,
|
expr = build_fold_indirect_ref_loc (input_location,
|
expr);
|
expr);
|
|
|
for (c = ts->u.derived->components; c; c = c->next)
|
for (c = ts->u.derived->components; c; c = c->next)
|
{
|
{
|
field = c->backend_decl;
|
field = c->backend_decl;
|
gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
|
gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
|
|
|
tmp = fold_build3_loc (UNKNOWN_LOCATION,
|
tmp = fold_build3_loc (UNKNOWN_LOCATION,
|
COMPONENT_REF, TREE_TYPE (field),
|
COMPONENT_REF, TREE_TYPE (field),
|
expr, field, NULL_TREE);
|
expr, field, NULL_TREE);
|
|
|
if (c->attr.dimension)
|
if (c->attr.dimension)
|
{
|
{
|
tmp = transfer_array_component (tmp, c, & code->loc);
|
tmp = transfer_array_component (tmp, c, & code->loc);
|
gfc_add_expr_to_block (&se->pre, tmp);
|
gfc_add_expr_to_block (&se->pre, tmp);
|
}
|
}
|
else
|
else
|
{
|
{
|
if (!c->attr.pointer)
|
if (!c->attr.pointer)
|
tmp = gfc_build_addr_expr (NULL_TREE, tmp);
|
tmp = gfc_build_addr_expr (NULL_TREE, tmp);
|
transfer_expr (se, &c->ts, tmp, code);
|
transfer_expr (se, &c->ts, tmp, code);
|
}
|
}
|
}
|
}
|
return;
|
return;
|
|
|
default:
|
default:
|
internal_error ("Bad IO basetype (%d)", ts->type);
|
internal_error ("Bad IO basetype (%d)", ts->type);
|
}
|
}
|
|
|
tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
|
tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
|
tmp = build_call_expr_loc (input_location,
|
tmp = build_call_expr_loc (input_location,
|
function, 3, tmp, addr_expr, arg2);
|
function, 3, tmp, addr_expr, arg2);
|
gfc_add_expr_to_block (&se->pre, tmp);
|
gfc_add_expr_to_block (&se->pre, tmp);
|
gfc_add_block_to_block (&se->pre, &se->post);
|
gfc_add_block_to_block (&se->pre, &se->post);
|
|
|
}
|
}
|
|
|
|
|
/* Generate a call to pass an array descriptor to the IO library. The
|
/* Generate a call to pass an array descriptor to the IO library. The
|
array should be of one of the intrinsic types. */
|
array should be of one of the intrinsic types. */
|
|
|
static void
|
static void
|
transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
|
transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
|
{
|
{
|
tree tmp, charlen_arg, kind_arg;
|
tree tmp, charlen_arg, kind_arg;
|
|
|
if (ts->type == BT_CHARACTER)
|
if (ts->type == BT_CHARACTER)
|
charlen_arg = se->string_length;
|
charlen_arg = se->string_length;
|
else
|
else
|
charlen_arg = build_int_cst (NULL_TREE, 0);
|
charlen_arg = build_int_cst (NULL_TREE, 0);
|
|
|
kind_arg = build_int_cst (NULL_TREE, ts->kind);
|
kind_arg = build_int_cst (NULL_TREE, ts->kind);
|
|
|
tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
|
tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
|
tmp = build_call_expr_loc (UNKNOWN_LOCATION,
|
tmp = build_call_expr_loc (UNKNOWN_LOCATION,
|
iocall[IOCALL_X_ARRAY], 4,
|
iocall[IOCALL_X_ARRAY], 4,
|
tmp, addr_expr, kind_arg, charlen_arg);
|
tmp, addr_expr, kind_arg, charlen_arg);
|
gfc_add_expr_to_block (&se->pre, tmp);
|
gfc_add_expr_to_block (&se->pre, tmp);
|
gfc_add_block_to_block (&se->pre, &se->post);
|
gfc_add_block_to_block (&se->pre, &se->post);
|
}
|
}
|
|
|
|
|
/* gfc_trans_transfer()-- Translate a TRANSFER code node */
|
/* gfc_trans_transfer()-- Translate a TRANSFER code node */
|
|
|
tree
|
tree
|
gfc_trans_transfer (gfc_code * code)
|
gfc_trans_transfer (gfc_code * code)
|
{
|
{
|
stmtblock_t block, body;
|
stmtblock_t block, body;
|
gfc_loopinfo loop;
|
gfc_loopinfo loop;
|
gfc_expr *expr;
|
gfc_expr *expr;
|
gfc_ref *ref;
|
gfc_ref *ref;
|
gfc_ss *ss;
|
gfc_ss *ss;
|
gfc_se se;
|
gfc_se se;
|
tree tmp;
|
tree tmp;
|
int n;
|
int n;
|
|
|
gfc_start_block (&block);
|
gfc_start_block (&block);
|
gfc_init_block (&body);
|
gfc_init_block (&body);
|
|
|
expr = code->expr1;
|
expr = code->expr1;
|
ss = gfc_walk_expr (expr);
|
ss = gfc_walk_expr (expr);
|
|
|
ref = NULL;
|
ref = NULL;
|
gfc_init_se (&se, NULL);
|
gfc_init_se (&se, NULL);
|
|
|
if (ss == gfc_ss_terminator)
|
if (ss == gfc_ss_terminator)
|
{
|
{
|
/* Transfer a scalar value. */
|
/* Transfer a scalar value. */
|
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, code);
|
}
|
}
|
else
|
else
|
{
|
{
|
/* Transfer an array. If it is an array of an intrinsic
|
/* Transfer an array. If it is an array of an intrinsic
|
type, pass the descriptor to the library. Otherwise
|
type, pass the descriptor to the library. Otherwise
|
scalarize the transfer. */
|
scalarize the transfer. */
|
if (expr->ref && !gfc_is_proc_ptr_comp (expr, NULL))
|
if (expr->ref && !gfc_is_proc_ptr_comp (expr, NULL))
|
{
|
{
|
for (ref = expr->ref; ref && ref->type != REF_ARRAY;
|
for (ref = expr->ref; ref && ref->type != REF_ARRAY;
|
ref = ref->next);
|
ref = ref->next);
|
gcc_assert (ref->type == REF_ARRAY);
|
gcc_assert (ref->type == REF_ARRAY);
|
}
|
}
|
|
|
if (expr->ts.type != BT_DERIVED
|
if (expr->ts.type != BT_DERIVED
|
&& ref && ref->next == NULL
|
&& ref && ref->next == NULL
|
&& !is_subref_array (expr))
|
&& !is_subref_array (expr))
|
{
|
{
|
bool seen_vector = false;
|
bool seen_vector = false;
|
|
|
if (ref && ref->u.ar.type == AR_SECTION)
|
if (ref && ref->u.ar.type == AR_SECTION)
|
{
|
{
|
for (n = 0; n < ref->u.ar.dimen; n++)
|
for (n = 0; n < ref->u.ar.dimen; n++)
|
if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
|
if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
|
seen_vector = true;
|
seen_vector = true;
|
}
|
}
|
|
|
if (seen_vector && last_dt == READ)
|
if (seen_vector && last_dt == READ)
|
{
|
{
|
/* Create a temp, read to that and copy it back. */
|
/* Create a temp, read to that and copy it back. */
|
gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT, false);
|
gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT, false);
|
tmp = se.expr;
|
tmp = se.expr;
|
}
|
}
|
else
|
else
|
{
|
{
|
/* Get the descriptor. */
|
/* Get the descriptor. */
|
gfc_conv_expr_descriptor (&se, expr, ss);
|
gfc_conv_expr_descriptor (&se, expr, ss);
|
tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
|
tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
|
}
|
}
|
|
|
transfer_array_desc (&se, &expr->ts, tmp);
|
transfer_array_desc (&se, &expr->ts, tmp);
|
goto finish_block_label;
|
goto finish_block_label;
|
}
|
}
|
|
|
/* Initialize the scalarizer. */
|
/* Initialize the scalarizer. */
|
gfc_init_loopinfo (&loop);
|
gfc_init_loopinfo (&loop);
|
gfc_add_ss_to_loop (&loop, ss);
|
gfc_add_ss_to_loop (&loop, ss);
|
|
|
/* Initialize the loop. */
|
/* Initialize the loop. */
|
gfc_conv_ss_startstride (&loop);
|
gfc_conv_ss_startstride (&loop);
|
gfc_conv_loop_setup (&loop, &code->expr1->where);
|
gfc_conv_loop_setup (&loop, &code->expr1->where);
|
|
|
/* The main loop body. */
|
/* The main loop body. */
|
gfc_mark_ss_chain_used (ss, 1);
|
gfc_mark_ss_chain_used (ss, 1);
|
gfc_start_scalarized_body (&loop, &body);
|
gfc_start_scalarized_body (&loop, &body);
|
|
|
gfc_copy_loopinfo_to_se (&se, &loop);
|
gfc_copy_loopinfo_to_se (&se, &loop);
|
se.ss = ss;
|
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, code);
|
}
|
}
|
|
|
finish_block_label:
|
finish_block_label:
|
|
|
gfc_add_block_to_block (&body, &se.pre);
|
gfc_add_block_to_block (&body, &se.pre);
|
gfc_add_block_to_block (&body, &se.post);
|
gfc_add_block_to_block (&body, &se.post);
|
|
|
if (se.ss == NULL)
|
if (se.ss == NULL)
|
tmp = gfc_finish_block (&body);
|
tmp = gfc_finish_block (&body);
|
else
|
else
|
{
|
{
|
gcc_assert (se.ss == gfc_ss_terminator);
|
gcc_assert (se.ss == gfc_ss_terminator);
|
gfc_trans_scalarizing_loops (&loop, &body);
|
gfc_trans_scalarizing_loops (&loop, &body);
|
|
|
gfc_add_block_to_block (&loop.pre, &loop.post);
|
gfc_add_block_to_block (&loop.pre, &loop.post);
|
tmp = gfc_finish_block (&loop.pre);
|
tmp = gfc_finish_block (&loop.pre);
|
gfc_cleanup_loop (&loop);
|
gfc_cleanup_loop (&loop);
|
}
|
}
|
|
|
gfc_add_expr_to_block (&block, tmp);
|
gfc_add_expr_to_block (&block, tmp);
|
|
|
return gfc_finish_block (&block);
|
return gfc_finish_block (&block);
|
}
|
}
|
|
|
#include "gt-fortran-trans-io.h"
|
#include "gt-fortran-trans-io.h"
|
|
|
