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