diff options
Diffstat (limited to 'gcc/fortran/trans-io.c')
| -rw-r--r-- | gcc/fortran/trans-io.c | 266 |
1 files changed, 206 insertions, 60 deletions
diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index aefa96d..2c84349 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -132,6 +132,7 @@ enum iocall IOCALL_X_COMPLEX128_WRITE, IOCALL_X_ARRAY, IOCALL_X_ARRAY_WRITE, + IOCALL_X_DERIVED, IOCALL_OPEN, IOCALL_CLOSE, IOCALL_INQUIRE, @@ -142,6 +143,7 @@ enum iocall IOCALL_ENDFILE, IOCALL_FLUSH, IOCALL_SET_NML_VAL, + IOCALL_SET_NML_DTIO_VAL, IOCALL_SET_NML_VAL_DIM, IOCALL_WAIT, IOCALL_NUM @@ -397,6 +399,10 @@ gfc_build_io_library_fndecls (void) void_type_node, 4, dt_parm_type, pvoid_type_node, integer_type_node, gfc_charlen_type_node); + iocall[IOCALL_X_DERIVED] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("transfer_derived")), ".wrR", + void_type_node, 2, dt_parm_type, pvoid_type_node, pchar_type_node); + /* Library entry points */ iocall[IOCALL_READ] = gfc_build_library_function_decl_with_spec ( @@ -468,6 +474,12 @@ gfc_build_io_library_fndecls (void) 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_DTIO_VAL] = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX("st_set_nml_dtio_var")), ".w.R", + void_type_node, 8, dt_parm_type, pvoid_type_node, pvoid_type_node, + gfc_int4_type_node, gfc_charlen_type_node, gfc_int4_type_node, + pvoid_type_node, pvoid_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, @@ -475,12 +487,8 @@ gfc_build_io_library_fndecls (void) } -/* 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) +static void +set_parameter_tree (stmtblock_t *block, tree var, enum iofield type, tree value) { tree tmp; gfc_st_parameter_field *p = &st_parameter_field[type]; @@ -491,7 +499,21 @@ set_parameter_const (stmtblock_t *block, tree var, enum iofield 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)); + gfc_add_modify (block, tmp, value); +} + + +/* 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) +{ + gfc_st_parameter_field *p = &st_parameter_field[type]; + + set_parameter_tree (block, var, type, + build_int_cst (TREE_TYPE (p->field), val)); return p->mask; } @@ -637,7 +659,7 @@ set_parameter_value_inquire (stmtblock_t *block, tree var, body = gfc_finish_block (&newblock); - cond3 = gfc_unlikely (cond3, PRED_FORTRAN_FAIL_IO); + cond3 = gfc_unlikely (cond3, PRED_FORTRAN_FAIL_IO); var = build3_v (COND_EXPR, cond3, body, build_empty_stmt (input_location)); gfc_add_expr_to_block (&se.pre, var); } @@ -697,13 +719,7 @@ set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock, 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); + set_parameter_tree (block, var, type, addr); return p->mask; } @@ -1618,6 +1634,8 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, tree dt_parm_addr; tree decl = NULL_TREE; tree gfc_int4_type_node = gfc_get_int_type (4); + tree dtio_proc = null_pointer_node; + tree vtable = null_pointer_node; int n_dim; int itype; int rank = 0; @@ -1659,15 +1677,45 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm); + /* Check if the derived type has a specific DTIO for the mode. + Note that although namelist io is forbidden to have a format + list, the specific subroutine is of the formatted kind. */ + if (ts->type == BT_DERIVED) + { + gfc_symbol *dtio_sub = NULL; + gfc_symbol *vtab; + dtio_sub = gfc_find_specific_dtio_proc (ts->u.derived, + last_dt == WRITE, + true); + if (dtio_sub != NULL) + { + dtio_proc = gfc_get_symbol_decl (dtio_sub); + dtio_proc = gfc_build_addr_expr (NULL, dtio_proc); + vtab = gfc_find_derived_vtab (ts->u.derived); + vtable = vtab->backend_decl; + if (vtable == NULL_TREE) + vtable = gfc_get_symbol_decl (vtab); + vtable = gfc_build_addr_expr (pvoid_type_node, vtable); + } + } + 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, - build_int_cst (gfc_int4_type_node, ts->kind), - tmp, dtype); + + if (dtio_proc == NULL_TREE) + tmp = build_call_expr_loc (input_location, + iocall[IOCALL_SET_NML_VAL], 6, + dt_parm_addr, addr_expr, string, + build_int_cst (gfc_int4_type_node, ts->kind), + tmp, dtype); + else + tmp = build_call_expr_loc (input_location, + iocall[IOCALL_SET_NML_DTIO_VAL], 8, + dt_parm_addr, addr_expr, string, + build_int_cst (gfc_int4_type_node, ts->kind), + tmp, dtype, dtio_proc, vtable); gfc_add_expr_to_block (block, tmp); /* If the object is an array, transfer rank times: @@ -1685,7 +1733,8 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, gfc_add_expr_to_block (block, tmp); } - if (gfc_bt_struct (ts->type) && ts->u.derived->components) + if (gfc_bt_struct (ts->type) && ts->u.derived->components + && dtio_proc == null_pointer_node) { gfc_component *cmp; @@ -1995,7 +2044,8 @@ gfc_trans_dt_end (gfc_code * code) } static void -transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code); +transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, + gfc_code * code, tree vptr); /* Given an array field in a derived type variable, generate the code for the loop that iterates over array elements, and the code that @@ -2061,7 +2111,7 @@ transfer_array_component (tree expr, gfc_component * cm, locus * where) /* 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); + transfer_expr (&se, &cm->ts, tmp, NULL, NULL_TREE); /* We are done now with the loop body. Wrap up the scalarizer and return. */ @@ -2081,10 +2131,53 @@ transfer_array_component (tree expr, gfc_component * cm, locus * where) return gfc_finish_block (&block); } + +/* Helper function for transfer_expr that looks for the DTIO procedure + either as a typebound binding or in a generic interface. If present, + the address expression of the procedure is returned. It is assumed + that the procedure interface has been checked during resolution. */ + +static tree +get_dtio_proc (gfc_typespec * ts, gfc_code * code, gfc_symbol **dtio_sub) +{ + gfc_symbol *derived; + bool formatted = false; + gfc_dt *dt = code->ext.dt; + + if (dt && dt->format_expr) + { + char *fmt; + fmt = gfc_widechar_to_char (dt->format_expr->value.character.string, + -1); + if (strtok (fmt, "DT") != NULL) + formatted = true; + } + else if (dt && dt->format_label == &format_asterisk) + { + /* List directed io must call the formatted DTIO procedure. */ + formatted = true; + } + + if (ts->type == BT_DERIVED) + derived = ts->u.derived; + else + derived = ts->u.derived->components->ts.u.derived; + + *dtio_sub = gfc_find_specific_dtio_proc (derived, last_dt == WRITE, + formatted); + + if (*dtio_sub) + return gfc_build_addr_expr (NULL, gfc_get_symbol_decl (*dtio_sub)); + + return NULL_TREE; + +} + /* Generate the call for a scalar transfer node. */ static void -transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code) +transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, + gfc_code * code, tree vptr) { tree tmp, function, arg2, arg3, field, expr; gfc_component *c; @@ -2212,43 +2305,81 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code) break; case_bt_struct: + case BT_CLASS: if (ts->u.derived->components == NULL) return; + if (ts->type == BT_DERIVED || ts->type == BT_CLASS) + { + gfc_symbol *derived; + gfc_symbol *dtio_sub = NULL; + /* Test for a specific DTIO subroutine. */ + if (ts->type == BT_DERIVED) + derived = ts->u.derived; + else + derived = ts->u.derived->components->ts.u.derived; - /* 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); + if (derived->attr.has_dtio_procs) + arg2 = get_dtio_proc (ts, code, &dtio_sub); - /* Make sure that the derived type has been built. An external - function, if only referenced in an io statement, requires this - check (see PR58771). */ - if (ts->u.derived->backend_decl == NULL_TREE) - (void) gfc_typenode_for_spec (ts); + if (dtio_sub != NULL) + { + tree decl; + decl = build_fold_indirect_ref_loc (input_location, + se->expr); + /* Remember that the first dummy of the DTIO subroutines + is CLASS(derived) for extensible derived types, so the + conversion must be done here for derived type and for + scalarized CLASS array element io-list objects. */ + if ((ts->type == BT_DERIVED + && !(ts->u.derived->attr.sequence + || ts->u.derived->attr.is_bind_c)) + || (ts->type == BT_CLASS + && !GFC_CLASS_TYPE_P (TREE_TYPE (decl)))) + gfc_conv_derived_to_class (se, code->expr1, + dtio_sub->formal->sym->ts, + vptr, false, false); + addr_expr = se->expr; + function = iocall[IOCALL_X_DERIVED]; + break; + } + else if (ts->type == BT_DERIVED) + { + /* 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); - } + /* Make sure that the derived type has been built. An external + function, if only referenced in an io statement, requires this + check (see PR58771). */ + if (ts->u.derived->backend_decl == NULL_TREE) + (void) gfc_typenode_for_spec (ts); + + 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, NULL_TREE); + } + } + return; + } + /* If a CLASS object gets through to here, fall through and ICE. */ } - return; - default: gfc_internal_error ("Bad IO basetype (%d)", ts->type); } @@ -2303,6 +2434,7 @@ gfc_trans_transfer (gfc_code * code) gfc_ss *ss; gfc_se se; tree tmp; + tree vptr; int n; gfc_start_block (&block); @@ -2315,8 +2447,18 @@ gfc_trans_transfer (gfc_code * code) if (expr->rank == 0) { /* Transfer a scalar value. */ - gfc_conv_expr_reference (&se, expr); - transfer_expr (&se, &expr->ts, se.expr, code); + if (expr->ts.type == BT_CLASS) + { + se.want_pointer = 1; + gfc_conv_expr (&se, expr); + vptr = gfc_get_vptr_from_expr (se.expr); + } + else + { + vptr = NULL_TREE; + gfc_conv_expr_reference (&se, expr); + } + transfer_expr (&se, &expr->ts, se.expr, code, vptr); } else { @@ -2330,7 +2472,8 @@ gfc_trans_transfer (gfc_code * code) gcc_assert (ref && ref->type == REF_ARRAY); } - if (!gfc_bt_struct (expr->ts.type) + if (!(gfc_bt_struct (expr->ts.type) + || expr->ts.type == BT_CLASS) && ref && ref->next == NULL && !is_subref_array (expr)) { @@ -2378,9 +2521,12 @@ gfc_trans_transfer (gfc_code * code) gfc_copy_loopinfo_to_se (&se, &loop); se.ss = ss; - gfc_conv_expr_reference (&se, expr); - transfer_expr (&se, &expr->ts, se.expr, code); + if (expr->ts.type == BT_CLASS) + vptr = gfc_get_vptr_from_expr (ss->info->data.array.descriptor); + else + vptr = NULL_TREE; + transfer_expr (&se, &expr->ts, se.expr, code, vptr); } finish_block_label: |