X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=blobdiff_plain;f=gcc%2Ffortran%2Ftrans-io.c;h=89c8df77f71c868ebec3c358733119964e267308;hp=b8ff5f36f53fd4fa2682a7c45579f7c237e27aca;hb=f5e3bc0e44695728180d63750b51a2ff58512db0;hpb=fb1e4f4abf01d3559f37568d2624b734410d3b3e diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index b8ff5f36f53..89c8df77f71 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -1,5 +1,5 @@ /* IO Code translation/library interface - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. Contributed by Paul Brook @@ -24,10 +24,8 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "tree.h" -#include "gimple.h" #include "ggc.h" -#include "toplev.h" -#include "real.h" +#include "diagnostic-core.h" /* For internal_error. */ #include "gfortran.h" #include "trans.h" #include "trans-stmt.h" @@ -105,7 +103,7 @@ static GTY(()) gfc_st_parameter_field st_parameter_field[] = { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL }, #include "ioparm.def" #undef IOPARM - { NULL, 0, 0, 0, NULL, NULL } + { NULL, 0, (enum ioparam_type) 0, (enum iofield_type) 0, NULL, NULL } }; /* Library I/O subroutines */ @@ -153,11 +151,12 @@ static stmtblock_t *dt_post_end_block; static void gfc_build_st_parameter (enum ioparam_type ptype, tree *types) { - enum iofield type; + 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_")); @@ -177,33 +176,31 @@ gfc_build_st_parameter (enum ioparam_type ptype, tree *types) case IOPARM_type_parray: case IOPARM_type_pchar: case IOPARM_type_pad: - p->field = gfc_add_field_to_struct (&TYPE_FIELDS (t), t, - get_identifier (p->name), - types[p->type]); + 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 (&TYPE_FIELDS (t), t, - get_identifier (p->name), - pchar_type_node); + 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 (&TYPE_FIELDS (t), t, - get_identifier (name), - gfc_charlen_type_node); + 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 (&TYPE_FIELDS (t), t, - get_identifier (p->name), - pchar_type_node); + 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 (&TYPE_FIELDS (t), t, + = gfc_add_field_to_struct (t, get_identifier (p->name), - st_parameter[IOPARM_ptype_common].type); + st_parameter[IOPARM_ptype_common].type, + &chain); break; case IOPARM_type_num: gcc_unreachable (); @@ -246,7 +243,8 @@ gfc_trans_io_runtime_check (tree cond, tree var, int error_code, gfc_build_localized_cstring_const (message)); gfc_free(message); - tmp = build_call_expr (gfor_fndecl_generate_error, 3, arg1, arg2, arg3); + tmp = build_call_expr_loc (input_location, + gfor_fndecl_generate_error, 3, arg1, arg2, arg3); gfc_add_expr_to_block (&block, tmp); @@ -261,10 +259,11 @@ gfc_trans_io_runtime_check (tree cond, tree var, int error_code, /* Tell the compiler that this isn't likely. */ cond = fold_convert (long_integer_type_node, cond); tmp = build_int_cst (long_integer_type_node, 0); - cond = build_call_expr (built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp); + cond = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp); cond = fold_convert (boolean_type_node, cond); - tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ()); + tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location)); gfc_add_expr_to_block (pblock, tmp); } } @@ -279,7 +278,7 @@ gfc_build_io_library_fndecls (void) tree gfc_intio_type_node; tree parm_type, dt_parm_type; HOST_WIDE_INT pad_size; - enum ioparam_type ptype; + unsigned int ptype; types[IOPARM_type_int4] = gfc_int4_type_node = gfc_get_int_type (4); types[IOPARM_type_intio] = gfc_intio_type_node @@ -302,134 +301,119 @@ gfc_build_io_library_fndecls (void) TYPE_ALIGN (gfc_get_int_type (gfc_intio_kind))); for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++) - gfc_build_st_parameter (ptype, types); + gfc_build_st_parameter ((enum ioparam_type) ptype, types); - /* Define the transfer functions. */ + /* Define the transfer functions. + TODO: Split them between READ and WRITE to allow further + optimizations, e.g. by using aliases? */ dt_parm_type = build_pointer_type (st_parameter[IOPARM_ptype_dt].type); - iocall[IOCALL_X_INTEGER] = - gfc_build_library_function_decl (get_identifier - (PREFIX("transfer_integer")), - void_type_node, 3, dt_parm_type, - pvoid_type_node, gfc_int4_type_node); - - iocall[IOCALL_X_LOGICAL] = - gfc_build_library_function_decl (get_identifier - (PREFIX("transfer_logical")), - void_type_node, 3, dt_parm_type, - pvoid_type_node, gfc_int4_type_node); - - iocall[IOCALL_X_CHARACTER] = - gfc_build_library_function_decl (get_identifier - (PREFIX("transfer_character")), - void_type_node, 3, dt_parm_type, - pvoid_type_node, gfc_int4_type_node); - - iocall[IOCALL_X_CHARACTER_WIDE] = - gfc_build_library_function_decl (get_identifier - (PREFIX("transfer_character_wide")), - void_type_node, 4, dt_parm_type, - pvoid_type_node, gfc_charlen_type_node, - gfc_int4_type_node); - - iocall[IOCALL_X_REAL] = - gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")), - void_type_node, 3, dt_parm_type, - pvoid_type_node, gfc_int4_type_node); - - iocall[IOCALL_X_COMPLEX] = - gfc_build_library_function_decl (get_identifier - (PREFIX("transfer_complex")), - void_type_node, 3, dt_parm_type, - pvoid_type_node, gfc_int4_type_node); - - iocall[IOCALL_X_ARRAY] = - gfc_build_library_function_decl (get_identifier - (PREFIX("transfer_array")), - void_type_node, 4, dt_parm_type, - pvoid_type_node, integer_type_node, - gfc_charlen_type_node); + 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_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_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_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_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_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_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); /* Library entry points */ - iocall[IOCALL_READ] = - gfc_build_library_function_decl (get_identifier (PREFIX("st_read")), - void_type_node, 1, dt_parm_type); + 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 (get_identifier (PREFIX("st_write")), - 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 (get_identifier (PREFIX("st_open")), - void_type_node, 1, parm_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 (get_identifier (PREFIX("st_close")), - void_type_node, 1, parm_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 (get_identifier (PREFIX("st_inquire")), - gfc_int4_type_node, 1, parm_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(get_identifier (PREFIX("st_iolength")), - void_type_node, 1, dt_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 (get_identifier (PREFIX("st_wait")), - gfc_int4_type_node, 1, parm_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 (get_identifier (PREFIX("st_rewind")), - gfc_int4_type_node, 1, parm_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 (get_identifier (PREFIX("st_backspace")), - gfc_int4_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 (get_identifier (PREFIX("st_endfile")), - gfc_int4_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 (get_identifier (PREFIX("st_flush")), - gfc_int4_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 (get_identifier (PREFIX("st_read_done")), - gfc_int4_type_node, 1, dt_parm_type); - - iocall[IOCALL_WRITE_DONE] = - gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")), - gfc_int4_type_node, 1, dt_parm_type); + 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_IOLENGTH_DONE] = - gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")), - gfc_int4_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 (get_identifier (PREFIX("st_set_nml_var")), - void_type_node, 6, dt_parm_type, - pvoid_type_node, pvoid_type_node, - gfc_int4_type_node, gfc_charlen_type_node, - gfc_int4_type_node); + iocall[IOCALL_SET_NML_VAL] = 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 (get_identifier (PREFIX("st_set_nml_var_dim")), - void_type_node, 5, dt_parm_type, - gfc_int4_type_node, gfc_array_index_type, - gfc_array_index_type, gfc_array_index_type); + 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); } @@ -469,26 +453,27 @@ set_parameter_value (stmtblock_t *block, tree var, enum iofield type, 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) + if (type == IOPARM_common_unit && e->ts.kind > 4) { - tree cond, max; + 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 nonnegative. */ + /* UNIT numbers should be greater than the min. */ + i = gfc_validate_kind (BT_INTEGER, 4, false); + val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].pedantic_min_int, 4); cond = fold_build2 (LT_EXPR, boolean_type_node, se.expr, - build_int_cst (TREE_TYPE (se.expr),0)); + fold_convert (TREE_TYPE (se.expr), val)); gfc_trans_io_runtime_check (cond, var, LIBERROR_BAD_UNIT, - "Negative unit number in I/O statement", + "Unit number in I/O statement too small", &se.pre); /* UNIT numbers should be less than the max. */ - i = gfc_validate_kind (BT_INTEGER, 4, false); - max = 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, - fold_convert (TREE_TYPE (se.expr), max)); + 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); @@ -567,65 +552,57 @@ set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock, /* 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 + 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. -*/ + the array. */ static void gfc_convert_array_to_string (gfc_se * se, gfc_expr * e) { - tree tmp; - tree array; - tree type; tree size; - int rank; - gfc_symbol *sym; - - sym = e->symtree->n.sym; - rank = sym->as->rank - 1; - if (e->ref->u.ar.type == AR_FULL) - { - se->expr = gfc_get_symbol_decl (sym); - se->expr = gfc_conv_array_data (se->expr); - } - else + 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); + array = sym->backend_decl; + type = TREE_TYPE (array); - if (GFC_ARRAY_TYPE_P (type)) - size = GFC_TYPE_ARRAY_SIZE (type); - else - { - gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); - size = gfc_conv_array_stride (array, rank); - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, - gfc_conv_array_ubound (array, rank), - gfc_conv_array_lbound (array, rank)); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, - gfc_index_one_node); - size = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, size); - } - - gcc_assert (size); + if (GFC_ARRAY_TYPE_P (type)) + size = GFC_TYPE_ARRAY_SIZE (type); + else + { + gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); + size = gfc_conv_array_stride (array, rank); + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, + gfc_conv_array_ubound (array, rank), + gfc_conv_array_lbound (array, rank)); + tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, + gfc_index_one_node); + size = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, size); + } + gcc_assert (size); - /* If it is an element, we need the its address and size of the rest. */ - if (e->ref->u.ar.type == AR_ELEMENT) - { 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); + tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); + size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, + fold_convert (gfc_array_index_type, tmp)); + se->string_length = fold_convert (gfc_charlen_type_node, size); + return; } - tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); - size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, - fold_convert (gfc_array_index_type, tmp)); - + gfc_conv_array_parameter (se, e, gfc_walk_expr (e), true, NULL, NULL, &size); se->string_length = fold_convert (gfc_charlen_type_node, size); } @@ -654,7 +631,9 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var, var, p->field_len, NULL_TREE); /* Integer variable assigned a format label. */ - if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1) + if (e->ts.type == BT_INTEGER + && e->rank == 0 + && e->symtree->n.sym->attr.assign == 1) { char * msg; tree cond; @@ -680,7 +659,7 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var, if (e->ts.type == BT_CHARACTER && e->rank == 0) gfc_conv_expr (&se, e); /* Array assigned Hollerith constant or character array. */ - else if (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); else gcc_unreachable (); @@ -744,8 +723,9 @@ set_internal_unit (stmtblock_t * block, stmtblock_t * post_block, /* 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); - tmp = build_fold_indirect_ref (se.expr); + 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); } @@ -956,6 +936,10 @@ gfc_trans_open (gfc_code * code) 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); @@ -965,7 +949,8 @@ gfc_trans_open (gfc_code * code) set_parameter_const (&block, var, IOPARM_common_unit, 0); tmp = gfc_build_addr_expr (NULL_TREE, var); - tmp = build_call_expr (iocall[IOCALL_OPEN], 1, tmp); + 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); @@ -1017,7 +1002,8 @@ gfc_trans_close (gfc_code * code) set_parameter_const (&block, var, IOPARM_common_unit, 0); tmp = gfc_build_addr_expr (NULL_TREE, var); - tmp = build_call_expr (iocall[IOCALL_CLOSE], 1, tmp); + 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); @@ -1067,7 +1053,8 @@ build_filepos (tree function, gfc_code * code) set_parameter_const (&block, var, IOPARM_common_unit, 0); tmp = gfc_build_addr_expr (NULL_TREE, var); - tmp = build_call_expr (function, 1, tmp); + 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); @@ -1324,7 +1311,8 @@ gfc_trans_inquire (gfc_code * code) set_parameter_const (&block, var, IOPARM_common_unit, 0); tmp = gfc_build_addr_expr (NULL_TREE, var); - tmp = build_call_expr (iocall[IOCALL_INQUIRE], 1, tmp); + 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); @@ -1373,7 +1361,8 @@ gfc_trans_wait (gfc_code * code) set_parameter_value (&block, var, IOPARM_common_unit, p->unit); tmp = gfc_build_addr_expr (NULL_TREE, var); - tmp = build_call_expr (iocall[IOCALL_WAIT], 1, tmp); + 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); @@ -1384,21 +1373,6 @@ gfc_trans_wait (gfc_code * code) } -static gfc_expr * -gfc_new_nml_name_expr (const char * name) -{ - gfc_expr * nml_name; - - nml_name = gfc_get_expr(); - nml_name->ref = NULL; - nml_name->expr_type = EXPR_CONSTANT; - nml_name->ts.kind = gfc_default_character_kind; - nml_name->ts.type = BT_CHARACTER; - nml_name->value.character.length = strlen(name); - nml_name->value.character.string = gfc_char_to_widechar (name); - - return nml_name; -} /* nml_full_name builds up the fully qualified name of a derived type component. */ @@ -1459,7 +1433,8 @@ nml_get_addr_expr (gfc_symbol * sym, gfc_component * c, dummy_arg_flagged = POINTER_TYPE_P (TREE_TYPE(tmp)); - itmp = (dummy_arg_flagged) ? build_fold_indirect_ref (tmp) : tmp; + itmp = (dummy_arg_flagged) ? build_fold_indirect_ref_loc (input_location, + tmp) : tmp; /* If an array, set flag and use indirect ref. if built. */ @@ -1491,7 +1466,8 @@ nml_get_addr_expr (gfc_symbol * sym, gfc_component * c, /* If scalar dummy, resolve indirect reference now. */ if (dummy_arg_flagged && !array_flagged) - tmp = build_fold_indirect_ref (tmp); + tmp = build_fold_indirect_ref_loc (input_location, + tmp); gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp))); @@ -1582,10 +1558,11 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm); if (ts->type == BT_CHARACTER) - tmp = ts->cl->backend_decl; + tmp = ts->u.cl->backend_decl; else tmp = build_int_cst (gfc_charlen_type_node, 0); - tmp = build_call_expr (iocall[IOCALL_SET_NML_VAL], 6, + 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); @@ -1595,7 +1572,8 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, for ( n_dim = 0 ; n_dim < rank ; n_dim++ ) { - tmp = build_call_expr (iocall[IOCALL_SET_NML_VAL_DIM], 5, + tmp = build_call_expr_loc (input_location, + iocall[IOCALL_SET_NML_VAL_DIM], 5, dt_parm_addr, IARG (n_dim), GFC_TYPE_ARRAY_STRIDE (dt, n_dim), @@ -1610,9 +1588,10 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, /* Provide the RECORD_TYPE to build component references. */ - tree expr = build_fold_indirect_ref (addr_expr); + tree expr = build_fold_indirect_ref_loc (input_location, + addr_expr); - for (cmp = ts->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); transfer_namelist_element (block, @@ -1675,7 +1654,8 @@ build_dt (tree function, gfc_code * code) { mask |= set_internal_unit (&block, &post_iu_block, var, dt->io_unit); - set_parameter_const (&block, var, IOPARM_common_unit, 0); + set_parameter_const (&block, var, IOPARM_common_unit, + dt->io_unit->ts.kind == 1 ? 0 : -1); } } else @@ -1764,7 +1744,9 @@ build_dt (tree function, gfc_code * code) if (dt->format_expr || dt->format_label) gfc_internal_error ("build_dt: format with namelist"); - nmlname = gfc_new_nml_name_expr (dt->namelist->name); + 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); @@ -1778,7 +1760,7 @@ build_dt (tree function, gfc_code * code) for (nml = dt->namelist->namelist; nml; nml = nml->next) transfer_namelist_element (&block, nml->sym->name, nml->sym, - NULL, NULL); + NULL, NULL_TREE); } else set_parameter_const (&block, var, IOPARM_common_flags, mask); @@ -1790,7 +1772,8 @@ build_dt (tree function, gfc_code * code) set_parameter_const (&block, var, IOPARM_common_flags, mask); tmp = gfc_build_addr_expr (NULL_TREE, var); - tmp = build_call_expr (function, 1, tmp); + 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); @@ -1798,7 +1781,23 @@ build_dt (tree function, gfc_code * code) dt_parm = var; dt_post_end_block = &post_end_block; - gfc_add_expr_to_block (&block, gfc_trans_code (code->block->next)); + /* Set implied do loop exit condition. */ + if (last_dt == READ || last_dt == WRITE) + { + gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags]; + + tmp = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type, + dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)), NULL_TREE); + tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field), + tmp, p->field, NULL_TREE); + tmp = fold_build2 (BIT_AND_EXPR, TREE_TYPE (tmp), + tmp, build_int_cst (TREE_TYPE (tmp), + IOPARM_common_libreturn_mask)); + } + else /* IOLENGTH */ + tmp = NULL_TREE; + + gfc_add_expr_to_block (&block, gfc_trans_code_cond (code->block->next, tmp)); gfc_add_block_to_block (&block, &post_iu_block); @@ -1870,7 +1869,8 @@ gfc_trans_dt_end (gfc_code * code) } tmp = gfc_build_addr_expr (NULL_TREE, dt_parm); - tmp = build_call_expr (function, 1, tmp); + 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); @@ -1991,8 +1991,9 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code) 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->is_iso_c == 1 && ts->derived != NULL) - || (ts->derived != NULL && ts->derived->ts.is_iso_c == 1)) + 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 @@ -2000,14 +2001,14 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code) if (gfc_notification_std (GFC_STD_GNU) != SILENT) { gfc_error_now ("Derived type '%s' at %L has PRIVATE components", - ts->derived->name, code != NULL ? &(code->loc) : + ts->u.derived->name, code != NULL ? &(code->loc) : &gfc_current_locus); return; } - ts->type = ts->derived->ts.type; - ts->kind = ts->derived->ts.kind; - ts->f90_type = ts->derived->ts.f90_type; + 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; @@ -2044,7 +2045,8 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code) arg2 = se->string_length; else { - tmp = build_fold_indirect_ref (addr_expr); + tmp = build_fold_indirect_ref_loc (input_location, + addr_expr); gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE); arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp))); arg2 = fold_convert (gfc_charlen_type_node, arg2); @@ -2052,7 +2054,8 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code) arg3 = build_int_cst (NULL_TREE, kind); function = iocall[IOCALL_X_CHARACTER_WIDE]; tmp = gfc_build_addr_expr (NULL_TREE, dt_parm); - tmp = build_call_expr (function, 4, tmp, addr_expr, arg2, arg3); + 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; @@ -2063,7 +2066,8 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code) arg2 = se->string_length; else { - tmp = build_fold_indirect_ref (addr_expr); + tmp = build_fold_indirect_ref_loc (input_location, + addr_expr); gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE); arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp))); } @@ -2073,14 +2077,16 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code) case BT_DERIVED: /* Recurse into the elements of the derived type. */ expr = gfc_evaluate_now (addr_expr, &se->pre); - expr = build_fold_indirect_ref (expr); + expr = build_fold_indirect_ref_loc (input_location, + expr); - for (c = ts->derived->components; c; c = c->next) + for (c = ts->u.derived->components; c; c = c->next) { field = c->backend_decl; gcc_assert (field && TREE_CODE (field) == FIELD_DECL); - tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field), + tmp = fold_build3_loc (UNKNOWN_LOCATION, + COMPONENT_REF, TREE_TYPE (field), expr, field, NULL_TREE); if (c->attr.dimension) @@ -2102,7 +2108,8 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code) } tmp = gfc_build_addr_expr (NULL_TREE, dt_parm); - tmp = build_call_expr (function, 3, tmp, addr_expr, arg2); + 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); @@ -2125,7 +2132,8 @@ transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr) kind_arg = build_int_cst (NULL_TREE, ts->kind); tmp = gfc_build_addr_expr (NULL_TREE, dt_parm); - tmp = build_call_expr (iocall[IOCALL_X_ARRAY], 4, + tmp = build_call_expr_loc (UNKNOWN_LOCATION, + iocall[IOCALL_X_ARRAY], 4, tmp, addr_expr, kind_arg, charlen_arg); gfc_add_expr_to_block (&se->pre, tmp); gfc_add_block_to_block (&se->pre, &se->post); @@ -2149,7 +2157,7 @@ gfc_trans_transfer (gfc_code * code) gfc_start_block (&block); gfc_init_block (&body); - expr = code->expr; + expr = code->expr1; ss = gfc_walk_expr (expr); ref = NULL; @@ -2166,7 +2174,7 @@ gfc_trans_transfer (gfc_code * code) /* 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) + if (expr->ref && !gfc_is_proc_ptr_comp (expr, NULL)) { for (ref = expr->ref; ref && ref->type != REF_ARRAY; ref = ref->next); @@ -2189,7 +2197,7 @@ gfc_trans_transfer (gfc_code * code) 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); + gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT, false); tmp = se.expr; } else @@ -2209,7 +2217,7 @@ gfc_trans_transfer (gfc_code * code) /* Initialize the loop. */ gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop, &code->expr->where); + gfc_conv_loop_setup (&loop, &code->expr1->where); /* The main loop body. */ gfc_mark_ss_chain_used (ss, 1); @@ -2245,4 +2253,3 @@ gfc_trans_transfer (gfc_code * code) } #include "gt-fortran-trans-io.h" -