Sorry, no testcase changes. See http://gcc.gnu.org/ml/fortran/2012-10/msg00126.html for those diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index a490238..20d6bbd 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -2801,7 +2801,7 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) /* CLASS arguments: Make sure the vtab of from is present. */ if (to->ts.type == BT_CLASS) - gfc_find_derived_vtab (from->ts.u.derived); + gfc_get_derived_vtab (from->ts.u.derived); return SUCCESS; } diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 2e347cb..6759812 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -416,7 +416,7 @@ gfc_class_null_initializer (gfc_typespec *ts) { gfc_constructor *ctor = gfc_constructor_get(); if (strcmp (comp->name, "_vptr") == 0) - ctor->expr = gfc_lval_expr_from_sym (gfc_find_derived_vtab (ts->u.derived)); + ctor->expr = gfc_lval_expr_from_sym (gfc_get_derived_vtab (ts->u.derived)); else ctor->expr = gfc_get_null_expr (NULL); gfc_constructor_append (&init->value.constructor, ctor); @@ -454,7 +454,7 @@ get_unique_hashed_string (char *string, gfc_symbol *derived) char tmp[2*GFC_MAX_SYMBOL_LEN+2]; get_unique_type_string (&tmp[0], derived); /* If string is too long, use hash value in hex representation (allow for - extra decoration, cf. gfc_build_class_symbol & gfc_find_derived_vtab). + extra decoration, cf. gfc_build_class_symbol & gfc_get_derived_vtab). We need space to for 15 characters "__class_" + symbol name + "_%d_%da", where %d is the (co)rank which can be up to n = 15. */ if (strlen (tmp) > GFC_MAX_SYMBOL_LEN - 15) @@ -583,7 +583,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, c->ts.u.derived = NULL; else { - vtab = gfc_find_derived_vtab (ts->u.derived); + vtab = gfc_get_derived_vtab (ts->u.derived); gcc_assert (vtab); c->ts.u.derived = vtab->ts.u.derived; } @@ -684,7 +684,7 @@ copy_vtab_proc_comps (gfc_symbol *declared, gfc_symbol *vtype) gfc_component *cmp; gfc_symbol *vtab; - vtab = gfc_find_derived_vtab (declared); + vtab = gfc_get_derived_vtab (declared); for (cmp = vtab->ts.u.derived->components; cmp; cmp = cmp->next) { @@ -731,7 +731,7 @@ has_finalizer_component (gfc_symbol *derived) static void finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, - gfc_expr *stat, gfc_code **code) + gfc_symbol *stat, gfc_symbol *fini_coarray, gfc_code **code) { gfc_expr *e; gfc_ref *ref; @@ -779,12 +779,36 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, e->rank = ref->next->u.ar.as->rank; } + /* Call DEALLOCATE (comp, stat=ignore). */ if (comp->attr.allocatable || (comp->ts.type == BT_CLASS && CLASS_DATA (comp) && CLASS_DATA (comp)->attr.allocatable)) { - /* Call DEALLOCATE (comp, stat=ignore). */ - gfc_code *dealloc; + gfc_code *dealloc, *block = NULL; + + /* Add IF (fini_coarray). */ + if (comp->attr.codimension + || (comp->ts.type == BT_CLASS && CLASS_DATA (comp) + && CLASS_DATA (comp)->attr.allocatable)) + { + block = XCNEW (gfc_code); + if (*code) + { + (*code)->next = block; + (*code) = (*code)->next; + } + else + (*code) = block; + + block->loc = gfc_current_locus; + block->op = EXEC_IF; + + block->block = XCNEW (gfc_code); + block = block->block; + block->loc = gfc_current_locus; + block->op = EXEC_IF; + block->expr1 = gfc_lval_expr_from_sym (fini_coarray); + } dealloc = XCNEW (gfc_code); dealloc->op = EXEC_DEALLOCATE; @@ -792,9 +816,11 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, dealloc->ext.alloc.list = gfc_get_alloc (); dealloc->ext.alloc.list->expr = e; + dealloc->expr1 = gfc_lval_expr_from_sym (stat); - dealloc->expr1 = stat; - if (*code) + if (block) + block->next = dealloc; + else if (*code) { (*code)->next = dealloc; (*code) = (*code)->next; @@ -811,7 +837,7 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, gfc_symbol *vtab; gfc_component *c; - vtab = gfc_find_derived_vtab (comp->ts.u.derived); + vtab = gfc_get_derived_vtab (comp->ts.u.derived); for (c = vtab->ts.u.derived->components; c; c = c->next) if (strcmp (c->name, "_final") == 0) break; @@ -839,7 +865,7 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, gfc_component *c; for (c = comp->ts.u.derived->components; c; c = c->next) - finalize_component (e, c->ts.u.derived, c, stat, code); + finalize_component (e, comp->ts.u.derived, c, stat, fini_coarray, code); gfc_free_expr (e); } } @@ -847,12 +873,11 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, /* Generate code equivalent to CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) - + idx * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE., c_ptr), - ptr). */ + + idx * stride, c_ptr), ptr). */ static gfc_code * finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr, - gfc_namespace *sub_ns) + gfc_symbol *stride, gfc_namespace *sub_ns) { gfc_code *block; gfc_expr *expr, *expr2, *expr3; @@ -919,56 +944,144 @@ finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr, expr->ts.kind = gfc_index_integer_kind; expr2->value.function.actual->expr = expr; - /* STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */ + /* Offset calculation: idx * stride (in bytes). */ + block->ext.actual->expr = gfc_get_expr (); + expr3 = block->ext.actual->expr; + expr3->expr_type = EXPR_OP; + expr3->value.op.op = INTRINSIC_TIMES; + expr3->value.op.op1 = gfc_lval_expr_from_sym (idx); + expr3->value.op.op2 = gfc_lval_expr_from_sym (stride); + expr3->ts = expr->ts; + + /* + . */ block->ext.actual->expr = gfc_get_expr (); - expr = block->ext.actual->expr; + block->ext.actual->expr->expr_type = EXPR_OP; + block->ext.actual->expr->value.op.op = INTRINSIC_PLUS; + block->ext.actual->expr->value.op.op1 = expr2; + block->ext.actual->expr->value.op.op2 = expr3; + block->ext.actual->expr->ts = expr->ts; + + /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */ + block->ext.actual->next = gfc_get_actual_arglist (); + block->ext.actual->next->expr = gfc_lval_expr_from_sym (ptr); + block->ext.actual->next->next = gfc_get_actual_arglist (); + + return block; +} + + +/* Insert code of the following form: + + if (stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE) then + call final_rank3 (array) + else + block + if (fstack-array) { + type(t) :: tmp(size (array)) + } else { + type(t), allocatable :: tmp(:) + allocate (tmp(size (array))) + } + do i = 0, size (array)-1 + addr = transfer (c_loc (array), addr) + i * stride + call c_f_pointer (transfer (addr, cptr), ptr) + tmp(i+1) = ptr + end do + call final_rank3 (tmp) + if (!fstack-array) { + deallocate (tmp) + } + end block */ + +static void +finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, + gfc_symbol * array, gfc_symbol * stride, + gfc_namespace *sub_ns) +{ + gfc_expr *expr; + gfc_namespace *ns; + + block->next = XCNEW (gfc_code); + block = block->next; + block->loc = gfc_current_locus; + block->op = EXEC_IF; + + block->block = XCNEW (gfc_code); + block = block->block; + block->loc = gfc_current_locus; + block->op = EXEC_IF; + + /* IF condition: stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE. */ + block->expr1 = gfc_get_expr (); + block->expr1->expr_type = EXPR_FUNCTION; + block->expr1->ts.type = BT_LOGICAL; + block->expr1->ts.kind = 4; + block->expr1->expr_type = EXPR_OP; + block->expr1->where = gfc_current_locus; + block->expr1->value.op.op = INTRINSIC_EQ; + block->expr1->value.op.op1 = gfc_lval_expr_from_sym (stride); + + /* STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE. */ + expr = gfc_get_expr (); + block->expr1->value.op.op2 = expr; + expr->where = gfc_current_locus; expr->expr_type = EXPR_OP; expr->value.op.op = INTRINSIC_DIVIDE; /* STORAGE_SIZE (array,kind=c_intptr_t). */ expr->value.op.op1 = gfc_get_expr (); + expr->value.op.op1->where = gfc_current_locus; expr->value.op.op1->expr_type = EXPR_FUNCTION; expr->value.op.op1->value.function.isym - = gfc_intrinsic_function_by_id (GFC_ISYM_STORAGE_SIZE); + = gfc_intrinsic_function_by_id (GFC_ISYM_STORAGE_SIZE); gfc_get_sym_tree ("storage_size", sub_ns, &expr->value.op.op1->symtree, - false); + false); expr->value.op.op1->symtree->n.sym->attr.flavor = FL_PROCEDURE; expr->value.op.op1->symtree->n.sym->attr.intrinsic = 1; gfc_commit_symbol (expr->value.op.op1->symtree->n.sym); expr->value.op.op1->value.function.actual = gfc_get_actual_arglist (); expr->value.op.op1->value.function.actual->expr - = gfc_lval_expr_from_sym (array); + = gfc_lval_expr_from_sym (array); expr->value.op.op1->value.function.actual->next = gfc_get_actual_arglist (); expr->value.op.op1->value.function.actual->next->expr - = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); + = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL, - gfc_character_storage_size); + gfc_character_storage_size); expr->value.op.op1->ts = expr->value.op.op2->ts; expr->ts = expr->value.op.op1->ts; - /* Offset calculation: idx * (STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE). */ - block->ext.actual->expr = gfc_get_expr (); - expr3 = block->ext.actual->expr; - expr3->expr_type = EXPR_OP; - expr3->value.op.op = INTRINSIC_TIMES; - expr3->value.op.op1 = gfc_lval_expr_from_sym (idx); - expr3->value.op.op2 = expr; - expr3->ts = expr->ts; + block->next = XCNEW (gfc_code); + block->next->op = EXEC_CALL; + block->next->loc = gfc_current_locus; + block->next->symtree = fini->proc_tree; + block->next->resolved_sym = fini->proc_tree->n.sym; + block->next->ext.actual = gfc_get_actual_arglist (); + block->next->ext.actual->expr = gfc_lval_expr_from_sym (array); - /* + . */ - block->ext.actual->expr = gfc_get_expr (); - block->ext.actual->expr->expr_type = EXPR_OP; - block->ext.actual->expr->value.op.op = INTRINSIC_PLUS; - block->ext.actual->expr->value.op.op1 = expr2; - block->ext.actual->expr->value.op.op2 = expr3; - block->ext.actual->expr->ts = expr->ts; + /* ELSE. */ - /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */ - block->ext.actual->next = gfc_get_actual_arglist (); - block->ext.actual->next->expr = gfc_lval_expr_from_sym (ptr); - block->ext.actual->next->next = gfc_get_actual_arglist (); + block->block = XCNEW (gfc_code); + block = block->block; + block->loc = gfc_current_locus; + block->op = EXEC_IF; - return block; + block->next = XCNEW (gfc_code); + block = block->next; + + /* BLOCK ... END BLOCK. */ + block->op = EXEC_BLOCK; + block->loc = gfc_current_locus; + ns = gfc_build_block_ns (sub_ns); + block->ext.block.ns = ns; + block->ext.block.assoc = NULL; + + block->next = XCNEW (gfc_code); + block->next->op = EXEC_CALL; + block->next->loc = gfc_current_locus; + block->next->symtree = fini->proc_tree; + block->next->resolved_sym = fini->proc_tree->n.sym; + block->next->ext.actual = gfc_get_actual_arglist (); + block->next->ext.actual->expr = gfc_lval_expr_from_sym (array); } @@ -979,19 +1092,27 @@ finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr, subroutine of the parent. The generated wrapper procedure takes as argument an assumed-rank array. If neither allocatable components nor FINAL subroutines exists, the vtab - will contain a NULL pointer. */ + will contain a NULL pointer. + The generated function has the form + _final(assumed-rank array, stride, skip_corarray) + where the array has to be contiguous (except of the lowest dimension). The + stride (in bytes) is used to allow different sizes for ancestor types by + skipping over the additionally added components in the scalarizer. If + "fini_coarray" is false, coarray components are not finalized to allow for + the correct semantic with intrinsic assignment. */ static void generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, const char *tname, gfc_component *vtab_final) { - gfc_symbol *final, *array, *nelem; + gfc_symbol *final, *array, *nelem, *fini_coarray, *stride; gfc_symbol *ptr = NULL, *idx = NULL; gfc_component *comp; gfc_namespace *sub_ns; gfc_code *last_code; char name[GFC_MAX_SYMBOL_LEN+1]; bool finalizable_comp = false; + bool expr_null_wrapper = false; gfc_expr *ancestor_wrapper = NULL; /* Search for the ancestor's finalizers. */ @@ -1002,7 +1123,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, gfc_symbol *vtab; gfc_component *comp; - vtab = gfc_find_derived_vtab (derived->components->ts.u.derived); + vtab = gfc_get_derived_vtab (derived->components->ts.u.derived); for (comp = vtab->ts.u.derived->components; comp; comp = comp->next) if (comp->name[0] == '_' && comp->name[1] == 'f') { @@ -1011,40 +1132,44 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, } } - /* No wrapper of the ancestor and no own FINAL subroutines and - allocatable components: Return a NULL() expression. */ + /* No wrapper of the ancestor and no own FINAL subroutines and allocatable + components: Return a NULL() expression; we defer this a bit to have have + an interface declaration. */ if ((!ancestor_wrapper || ancestor_wrapper->expr_type == EXPR_NULL) && !derived->attr.alloc_comp && (!derived->f2k_derived || !derived->f2k_derived->finalizers) && !has_finalizer_component (derived)) - { - vtab_final->initializer = gfc_get_null_expr (NULL); - return; - } - - /* Check whether there are new allocatable components. */ - for (comp = derived->components; comp; comp = comp->next) - { - if (comp == derived->components && derived->attr.extension - && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL) + expr_null_wrapper = true; + else + /* Check whether there are new allocatable components. */ + for (comp = derived->components; comp; comp = comp->next) + { + if (comp == derived->components && derived->attr.extension + && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL) continue; - if (comp->ts.type != BT_CLASS && !comp->attr.pointer - && (comp->attr.alloc_comp || comp->attr.allocatable - || (comp->ts.type == BT_DERIVED - && has_finalizer_component (comp->ts.u.derived)))) - finalizable_comp = true; - else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp) - && CLASS_DATA (comp)->attr.allocatable) - finalizable_comp = true; - } + if (comp->ts.type != BT_CLASS && !comp->attr.pointer + && (comp->attr.allocatable + || (comp->ts.type == BT_DERIVED + && (comp->ts.u.derived->attr.alloc_comp + || has_finalizer_component (comp->ts.u.derived) + || (comp->ts.u.derived->f2k_derived + && comp->ts.u.derived->f2k_derived->finalizers))))) + finalizable_comp = true; + else if (comp->ts.type == BT_CLASS && CLASS_DATA (comp) + && CLASS_DATA (comp)->attr.allocatable) + finalizable_comp = true; + } /* If there is no new finalizer and no new allocatable, return with an expr to the ancestor's one. */ - if ((!derived->f2k_derived || !derived->f2k_derived->finalizers) - && !finalizable_comp) + if (!expr_null_wrapper && !finalizable_comp + && (!derived->f2k_derived || !derived->f2k_derived->finalizers)) { + gcc_assert (ancestor_wrapper && ancestor_wrapper->ref == NULL + && ancestor_wrapper->expr_type == EXPR_VARIABLE); vtab_final->initializer = gfc_copy_expr (ancestor_wrapper); + vtab_final->ts.interface = vtab_final->initializer->symtree->n.sym; return; } @@ -1057,12 +1182,13 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, 3. Call the ancestor's finalizer. */ /* Declare the wrapper function; it takes an assumed-rank array - as argument. */ + and a VALUE logical as arguments. */ /* Set up the namespace. */ sub_ns = gfc_get_namespace (ns, 0); sub_ns->sibling = ns->contained; - ns->contained = sub_ns; + if (!expr_null_wrapper) + ns->contained = sub_ns; sub_ns->resolved = 1; /* Set up the procedure symbol. */ @@ -1070,13 +1196,17 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, gfc_get_symbol (name, sub_ns, &final); sub_ns->proc_name = final; final->attr.flavor = FL_PROCEDURE; - final->attr.subroutine = 1; - final->attr.pure = 1; + final->attr.function = 1; + final->attr.pure = 0; + final->result = final; + final->ts.type = BT_INTEGER; + final->ts.kind = 4; final->attr.artificial = 1; - final->attr.if_source = IFSRC_DECL; + final->attr.if_source = expr_null_wrapper ? IFSRC_IFBODY : IFSRC_DECL; if (ns->proc_name->attr.flavor == FL_MODULE) final->module = ns->proc_name->name; gfc_set_sym_referenced (final); + gfc_commit_symbol (final); /* Set up formal argument. */ gfc_get_symbol ("array", sub_ns, &array); @@ -1096,6 +1226,50 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, final->formal->sym = array; gfc_commit_symbol (array); + /* Set up formal argument. */ + gfc_get_symbol ("stride", sub_ns, &stride); + stride->ts.type = BT_INTEGER; + stride->ts.kind = gfc_index_integer_kind; + stride->attr.flavor = FL_VARIABLE; + stride->attr.dummy = 1; + stride->attr.value = 1; + stride->attr.artificial = 1; + gfc_set_sym_referenced (stride); + final->formal->next = gfc_get_formal_arglist (); + final->formal->next->sym = stride; + gfc_commit_symbol (stride); + + /* Set up formal argument. */ + gfc_get_symbol ("fini_coarray", sub_ns, &fini_coarray); + fini_coarray->ts.type = BT_LOGICAL; + fini_coarray->ts.kind = 4; + fini_coarray->attr.flavor = FL_VARIABLE; + fini_coarray->attr.dummy = 1; + fini_coarray->attr.value = 1; + fini_coarray->attr.artificial = 1; + gfc_set_sym_referenced (fini_coarray); + final->formal->next->next = gfc_get_formal_arglist (); + final->formal->next->next->sym = fini_coarray; + gfc_commit_symbol (fini_coarray); + + /* Return with a NULL() expression but with an interface which has + the formal arguments. */ + if (expr_null_wrapper) + { + vtab_final->initializer = gfc_get_null_expr (NULL); + vtab_final->ts.interface = final; + return; + } + + + /* Set return value to 0. */ + last_code = XCNEW (gfc_code); + last_code->op = EXEC_ASSIGN; + last_code->loc = gfc_current_locus; + last_code->expr1 = gfc_lval_expr_from_sym (final); + last_code->expr2 = gfc_get_int_expr (4, NULL, 0); + sub_ns->code = last_code; + /* Obtain the size (number of elements) of "array" MINUS ONE, which is used in the scalarization. */ gfc_get_symbol ("nelem", sub_ns, &nelem); @@ -1107,7 +1281,8 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, gfc_commit_symbol (nelem); /* Generate: nelem = SIZE (array) - 1. */ - last_code = XCNEW (gfc_code); + last_code->next = XCNEW (gfc_code); + last_code = last_code->next; last_code->op = EXEC_ASSIGN; last_code->loc = gfc_current_locus; @@ -1154,10 +1329,32 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, select case (rank (array)) case (3) - call final_rank3 (array) + if (stride == STORAGE_SIZE(array)/NUMERIC_STORAGE_SIZE) then + call final_rank3 (array) + else + block + if (fstack-array) { + type(t) :: tmp(size (array)) + } else { + type(t), allocatable :: tmp(:) + allocate (tmp(size (array))) + } + do i = 0, size (array)-1 + addr = transfer (c_loc (array), addr) + i * stride + call c_f_pointer (transfer (addr, cptr), ptr) + tmp(i+1) = ptr + end do + call final_rank3 (tmp) + if (!fstack-array) { + deallocate (tmp) + } + end block + ! NOTE: With the new array descriptor, this packing only required if the + ! actual argument is CONTIGUOUS or not assumed shape. + case default: do i = 0, size (array)-1 - addr = transfer (c_loc (array), addr) + i * STORAGE_SIZE (array) + addr = transfer (c_loc (array), addr) + i * stride call c_f_pointer (transfer (addr, cptr), ptr) call elemental_final (ptr) end do @@ -1221,14 +1418,19 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, block->ext.block.case_list->high = block->ext.block.case_list->low; - /* CALL fini_rank (array). */ - block->next = XCNEW (gfc_code); - block->next->op = EXEC_CALL; - block->next->loc = gfc_current_locus; - block->next->symtree = fini->proc_tree; - block->next->resolved_sym = fini->proc_tree->n.sym; - block->next->ext.actual = gfc_get_actual_arglist (); - block->next->ext.actual->expr = gfc_lval_expr_from_sym (array); + /* CALL fini_rank (array) - possibly with packing. */ + if (fini->proc_tree->n.sym->formal->sym->attr.dimension) + finalizer_insert_packed_call (block, fini, array, stride, sub_ns); + else + { + block->next = XCNEW (gfc_code); + block->next->op = EXEC_CALL; + block->next->loc = gfc_current_locus; + block->next->symtree = fini->proc_tree; + block->next->resolved_sym = fini->proc_tree->n.sym; + block->next->ext.actual = gfc_get_actual_arglist (); + block->next->ext.actual->expr = gfc_lval_expr_from_sym (array); + } } /* Elemental call - scalarized. */ @@ -1284,8 +1486,9 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, /* Create code for CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) - + idx * STORAGE_SIZE (array), c_ptr), ptr). */ - block->block->next = finalization_scalarizer (idx, array, ptr, sub_ns); + + idx * stride, c_ptr), ptr). */ + block->block->next = finalization_scalarizer (idx, array, ptr, stride, + sub_ns); block = block->block->next; /* CALL final_elemental (array). */ @@ -1356,8 +1559,9 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, /* Create code for CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) - + idx * STORAGE_SIZE (array), c_ptr), ptr). */ - last_code->block->next = finalization_scalarizer (idx, array, ptr, sub_ns); + + idx * stride, c_ptr), ptr). */ + last_code->block->next = finalization_scalarizer (idx, array, ptr, stride, + sub_ns); block = last_code->block->next; for (comp = derived->components; comp; comp = comp->next) @@ -1367,7 +1571,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, continue; finalize_component (gfc_lval_expr_from_sym (ptr), derived, comp, - gfc_lval_expr_from_sym (stat), &block); + stat, fini_coarray, &block); if (!last_code->block->next) last_code->block->next = block; } @@ -1386,9 +1590,13 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, last_code->ext.actual = gfc_get_actual_arglist (); last_code->ext.actual->expr = gfc_lval_expr_from_sym (array); + last_code->ext.actual->next = gfc_get_actual_arglist (); + last_code->ext.actual->next->expr = gfc_lval_expr_from_sym (stride); + last_code->ext.actual->next->next = gfc_get_actual_arglist (); + last_code->ext.actual->next->next->expr + = gfc_lval_expr_from_sym (fini_coarray); } - gfc_commit_symbol (final); vtab_final->initializer = gfc_lval_expr_from_sym (final); vtab_final->ts.interface = final; } @@ -1419,10 +1627,10 @@ add_procs_to_declared_vtab (gfc_symbol *derived, gfc_symbol *vtype) } -/* Find (or generate) the symbol for a derived type's vtab. */ +/* Find or generate the symbol for a derived type's vtab. */ -gfc_symbol * -gfc_find_derived_vtab (gfc_symbol *derived) +static gfc_symbol * +find_derived_vtab (gfc_symbol *derived, bool generate) { gfc_namespace *ns; gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL; @@ -1440,7 +1648,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) if (ns) { char name[GFC_MAX_SYMBOL_LEN+1], tname[GFC_MAX_SYMBOL_LEN+1]; - + get_unique_hashed_string (tname, derived); sprintf (name, "__vtab_%s", tname); @@ -1451,6 +1659,9 @@ gfc_find_derived_vtab (gfc_symbol *derived) if (vtab == NULL) gfc_find_symbol (name, derived->ns, 0, &vtab); + if (!generate && !vtab) + return NULL; + if (vtab == NULL) { gfc_get_symbol (name, ns, &vtab); @@ -1464,7 +1675,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) vtab->attr.access = ACCESS_PUBLIC; gfc_set_sym_referenced (vtab); sprintf (name, "__vtype_%s", tname); - + gfc_find_symbol (name, ns, 0, &vtype); if (vtype == NULL) { @@ -1509,7 +1720,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) parent = gfc_get_derived_super_type (derived); if (parent) { - parent_vtab = gfc_find_derived_vtab (parent); + parent_vtab = gfc_get_derived_vtab (parent); c->ts.type = BT_DERIVED; c->ts.u.derived = parent_vtab->ts.u.derived; c->initializer = gfc_get_expr (); @@ -1627,9 +1838,6 @@ gfc_find_derived_vtab (gfc_symbol *derived) components and the calls to finalization subroutines. Note: The actual wrapper function can only be generated at resolution time. */ - /* FIXME: Enable ABI-breaking "_final" generation. */ - if (0) - { if (gfc_add_component (vtype, "_final", &c) == FAILURE) goto cleanup; c->attr.proc_pointer = 1; @@ -1637,7 +1845,6 @@ gfc_find_derived_vtab (gfc_symbol *derived) c->tb = XCNEW (gfc_typebound_proc); c->tb->ppc = 1; generate_finalization_wrapper (derived, ns, tname, c); - } /* Add procedure pointers for type-bound procedures. */ add_procs_to_declared_vtab (derived, vtype); @@ -1675,6 +1882,20 @@ cleanup: } +gfc_symbol * +gfc_find_derived_vtab (gfc_symbol *derived) +{ + return find_derived_vtab (derived, false); +} + + +gfc_symbol * +gfc_get_derived_vtab (gfc_symbol *derived) +{ + return find_derived_vtab (derived, true); +} + + /* General worker function to find either a type-bound procedure or a type-bound user operator. */ diff --git a/gcc/fortran/config-lang.in b/gcc/fortran/config-lang.in index 43aab7a..6402adb 100644 --- a/gcc/fortran/config-lang.in +++ b/gcc/fortran/config-lang.in @@ -27,7 +27,7 @@ language="fortran" compilers="f951\$(exeext)" -target_libs=target-libgfortran +target_libs="target-libgfortran target-libbacktrace" gtfiles="\$(srcdir)/fortran/f95-lang.c \$(srcdir)/fortran/trans-decl.c \$(srcdir)/fortran/trans-intrinsic.c \$(srcdir)/fortran/trans-io.c \$(srcdir)/fortran/trans-stmt.c \$(srcdir)/fortran/trans-types.c \$(srcdir)/fortran/trans-types.h \$(srcdir)/fortran/trans.h \$(srcdir)/fortran/trans-const.h" diff --git a/gcc/fortran/error.c b/gcc/fortran/error.c index 4b06156..611540c 100644 --- a/gcc/fortran/error.c +++ b/gcc/fortran/error.c @@ -387,7 +387,7 @@ show_locus (locus *loc, int c1, int c2) cmax -= offset; p = &(lb->line[offset]); - for (i = 0; i <= cmax; i++) + for (i = 0; i < cmax; i++) { int spaces, j; spaces = gfc_widechar_display_length (*p++); @@ -401,6 +401,11 @@ show_locus (locus *loc, int c1, int c2) error_char (' '); } + if (i == c1) + error_char ('1'); + else if (i == c2) + error_char ('2'); + error_char ('\n'); } diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 211f304..34b6f90 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3571,7 +3571,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) if (lvalue->ts.type == BT_CLASS && rvalue->ts.type == BT_DERIVED) /* Make sure the vtab is present. */ - gfc_find_derived_vtab (rvalue->ts.u.derived); + gfc_get_derived_vtab (rvalue->ts.u.derived); /* Check rank remapping. */ if (rank_remap) @@ -3693,7 +3693,9 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) warn = lvalue->symtree->n.sym->attr.dummy || lvalue->symtree->n.sym->attr.result || lvalue->symtree->n.sym->attr.function - || lvalue->symtree->n.sym->attr.host_assoc + || (lvalue->symtree->n.sym->attr.host_assoc + && lvalue->symtree->n.sym->ns + != rvalue->symtree->n.sym->ns) || lvalue->symtree->n.sym->attr.use_assoc || lvalue->symtree->n.sym->attr.in_common; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index fabc16a..00f5055 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2956,6 +2956,7 @@ unsigned int gfc_hash_value (gfc_symbol *); gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *, gfc_array_spec **, bool); gfc_symbol *gfc_find_derived_vtab (gfc_symbol *); +gfc_symbol *gfc_get_derived_vtab (gfc_symbol *); gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*, const char*, bool, locus*); gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*, diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index d90fc73..d2a4ec9 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1847,7 +1847,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED) /* Make sure the vtab symbol is present when the module variables are generated. */ - gfc_find_derived_vtab (actual->ts.u.derived); + gfc_get_derived_vtab (actual->ts.u.derived); if (actual->ts.type == BT_PROCEDURE) { diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 3f981d8..83a896a 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -945,7 +945,7 @@ gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo) gfc_add_vptr_component (a); else if (a->ts.type == BT_DERIVED) { - vtab = gfc_find_derived_vtab (a->ts.u.derived); + vtab = gfc_get_derived_vtab (a->ts.u.derived); /* Clear the old expr. */ gfc_free_ref_list (a->ref); memset (a, '\0', sizeof (gfc_expr)); @@ -961,7 +961,7 @@ gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo) gfc_add_vptr_component (mo); else if (mo->ts.type == BT_DERIVED) { - vtab = gfc_find_derived_vtab (mo->ts.u.derived); + vtab = gfc_get_derived_vtab (mo->ts.u.derived); /* Clear the old expr. */ gfc_free_ref_list (mo->ref); memset (mo, '\0', sizeof (gfc_expr)); diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 89c45b7..cde5739 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -2597,7 +2597,7 @@ mio_component (gfc_component *c, int vtype) c->attr.class_ok = 1; c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types); - if (!vtype) + if (!vtype || strcmp (c->name, "_final") == 0) mio_expr (&c->initializer); if (c->attr.proc_pointer) @@ -6157,6 +6157,8 @@ gfc_use_module (gfc_use_list *module) "intrinsic module at %C") != FAILURE) { use_iso_fortran_env_module (); + free_rename (module->rename); + module->rename = NULL; gfc_current_locus = old_locus; module->intrinsic = true; return; @@ -6167,6 +6169,8 @@ gfc_use_module (gfc_use_list *module) "ISO_C_BINDING module at %C") != FAILURE) { import_iso_c_binding_module(); + free_rename (module->rename); + module->rename = NULL; gfc_current_locus = old_locus; module->intrinsic = true; return; @@ -6359,8 +6363,6 @@ gfc_use_modules (void) next = module_list->next; rename_list_remove_duplicate (module_list->rename); gfc_use_module (module_list); - if (module_list->intrinsic) - free_rename (module_list->rename); free (module_list); } gfc_rename_list = NULL; diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 659e9fc..0f1fa57 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -1998,8 +1998,7 @@ parse_derived_contains (void) case ST_FINAL: if (gfc_notify_std (GFC_STD_F2003, - "FINAL procedure declaration" - " at %C") == FAILURE) + "FINAL procedure declaration at %C") == FAILURE) goto error; accept_statement (ST_FINAL); @@ -2010,7 +2009,7 @@ parse_derived_contains (void) to_finish = true; if (!seen_comps - && (gfc_notify_std (GFC_STD_F2008, "Derived type " + && (gfc_notify_std (GFC_STD_F2003, "Derived type " "definition at %C with empty CONTAINS " "section") == FAILURE)) goto error; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index f3d3beb..6b48b59 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -428,7 +428,11 @@ resolve_formal_arglist (gfc_symbol *proc) if (!gfc_pure(sym)) proc->attr.implicit_pure = 0; } - else if (!sym->attr.pointer) + else if ((sym->ts.type != BT_CLASS && sym->attr.pointer) + || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) + && CLASS_DATA (sym)->attr.class_pointer)) + proc->attr.implicit_pure = 0; + else { if (proc->attr.function && sym->attr.intent != INTENT_IN && !sym->value) @@ -6214,7 +6218,7 @@ resolve_typebound_function (gfc_expr* e) declared = ts.u.derived; c = gfc_find_component (declared, "_vptr", true, true); if (c->ts.u.derived == NULL) - c->ts.u.derived = gfc_find_derived_vtab (declared); + c->ts.u.derived = gfc_get_derived_vtab (declared); if (resolve_compcall (e, &name) == FAILURE) return FAILURE; @@ -6342,7 +6346,7 @@ resolve_typebound_subroutine (gfc_code *code) declared = expr->ts.u.derived; c = gfc_find_component (declared, "_vptr", true, true); if (c->ts.u.derived == NULL) - c->ts.u.derived = gfc_find_derived_vtab (declared); + c->ts.u.derived = gfc_get_derived_vtab (declared); if (resolve_typebound_call (code, &name) == FAILURE) return FAILURE; @@ -7369,7 +7373,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) ts = code->expr3->ts; else if (code->ext.alloc.ts.type == BT_DERIVED) ts = code->ext.alloc.ts; - gfc_find_derived_vtab (ts.u.derived); + gfc_get_derived_vtab (ts.u.derived); if (dimension) e = gfc_expr_to_initialize (e); } @@ -8567,7 +8571,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (code->expr1->symtree); new_st->expr1->value.function.actual->expr->where = code->loc; gfc_add_vptr_component (new_st->expr1->value.function.actual->expr); - vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived); + vtab = gfc_get_derived_vtab (body->ext.block.case_list->ts.u.derived); st = gfc_find_symtree (vtab->ns->sym_root, vtab->name); new_st->expr1->value.function.actual->next = gfc_get_actual_arglist (); new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st); @@ -11286,11 +11290,7 @@ error: " defined at %L, suggest also scalar one", derived->name, &derived->declared_at); - /* TODO: Remove this error when finalization is finished. */ - gfc_error ("Finalization at %L is not yet implemented", - &derived->declared_at); - - gfc_find_derived_vtab (derived); + gfc_get_derived_vtab (derived); return result; } @@ -11850,7 +11850,7 @@ resolve_typebound_procedures (gfc_symbol* derived) resolve_bindings_result = SUCCESS; /* Make sure the vtab has been generated. */ - gfc_find_derived_vtab (derived); + gfc_get_derived_vtab (derived); if (derived->f2k_derived->tb_sym_root) gfc_traverse_symtree (derived->f2k_derived->tb_sym_root, @@ -12405,7 +12405,7 @@ resolve_fl_derived (gfc_symbol *sym) gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true); if (vptr->ts.u.derived == NULL) { - gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived); + gfc_symbol *vtab = gfc_get_derived_vtab (data->ts.u.derived); gcc_assert (vtab); vptr->ts.u.derived = vtab->ts.u.derived; } @@ -12618,6 +12618,9 @@ resolve_symbol (gfc_symbol *sym) if (sym->attr.artificial) return; + if (sym->attr.artificial) + return; + if (sym->attr.flavor == FL_UNKNOWN || (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic && !sym->attr.generic && !sym->attr.external diff --git a/gcc/fortran/scanner.c b/gcc/fortran/scanner.c index e0556a9..765c0f9 100644 --- a/gcc/fortran/scanner.c +++ b/gcc/fortran/scanner.c @@ -1068,10 +1068,12 @@ restart: && gfc_current_locus.lb->truncated) { int maxlen = gfc_option.free_line_length; + gfc_char_t *current_nextc = gfc_current_locus.nextc; + gfc_current_locus.lb->truncated = 0; - gfc_current_locus.nextc += maxlen; + gfc_current_locus.nextc = gfc_current_locus.lb->line + maxlen; gfc_warning_now ("Line truncated at %L", &gfc_current_locus); - gfc_current_locus.nextc -= maxlen; + gfc_current_locus.nextc = current_nextc; } if (c != '&') diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 24adfde..0689892 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -7589,7 +7589,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, CLASS_DATA (c)->attr.codimension); else { - tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL, + tmp = gfc_deallocate_scalar_with_status (comp, NULL_TREE, true, NULL, CLASS_DATA (c)->ts); gfc_add_expr_to_block (&tmpblock, tmp); called_dealloc_with_status = true; diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 3bee178..f383ac0 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -1206,7 +1206,7 @@ gfc_get_symbol_decl (gfc_symbol * sym) gfc_component *c = CLASS_DATA (sym); if (!c->ts.u.derived->backend_decl) { - gfc_find_derived_vtab (c->ts.u.derived); + gfc_get_derived_vtab (c->ts.u.derived); gfc_get_derived_type (sym->ts.u.derived); } } @@ -3430,7 +3430,65 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block) && !f->sym->attr.pointer && f->sym->ts.type == BT_DERIVED) { - if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value) + gfc_symbol *vtab = gfc_find_derived_vtab (f->sym->ts.u.derived); + gfc_expr *final_expr = NULL; + + if (vtab) + { + gfc_component *final; + + final = vtab->ts.u.derived->components->next->next->next->next->next; + gcc_assert (strcmp (final->name, "_final") == 0); + + if (final->initializer && final->initializer->expr_type != EXPR_NULL) + final_expr = final->initializer; + } + + if (final_expr) + { + gfc_code *code; + tree elem_size; + + f->sym->attr.referenced = 1; + code = gfc_get_code (); + if (f->sym->ts.type == BT_DERIVED) + code->resolved_sym = final_expr->symtree->n.sym; + else /* FIXME: This shouldn't be reachable for INTENT(OUT), should it? */ + code->resolved_sym = gfc_get_proc_ptr_comp (final_expr)->ts.interface; + + elem_size = gfc_typenode_for_spec (&f->sym->ts); + elem_size = TYPE_SIZE_UNIT (elem_size); + gcc_assert (TREE_INT_CST_HIGH (elem_size) == 0); + + code->ext.actual = gfc_get_actual_arglist (); + code->ext.actual->expr = gfc_lval_expr_from_sym (f->sym); + code->ext.actual->next = gfc_get_actual_arglist (); + code->ext.actual->next->expr + = gfc_get_int_expr (gfc_index_integer_kind, NULL, + TREE_INT_CST_LOW (elem_size)); + code->ext.actual->next->next = gfc_get_actual_arglist (); + code->ext.actual->next->next->expr + = gfc_get_logical_expr (4, NULL, true); + code->expr1 = gfc_copy_expr (final_expr); + code->op = EXEC_CALL; + tmp = gfc_trans_call (code, true, NULL, NULL, false); + + if (f->sym->attr.optional + || f->sym->ns->proc_name->attr.entry_master) + { + present = gfc_conv_expr_present (f->sym); + tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), + present, tmp, + build_empty_stmt (input_location)); + } + + gfc_add_expr_to_block (&init, tmp); + gfc_free_statements (code); + + if (f->sym->value) + gfc_init_default_dt (f->sym, &init, false); + } + else if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value) { tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived, f->sym->backend_decl, @@ -3452,25 +3510,68 @@ init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block) } else if (f->sym && f->sym->attr.intent == INTENT_OUT && f->sym->ts.type == BT_CLASS - && !CLASS_DATA (f->sym)->attr.class_pointer - && CLASS_DATA (f->sym)->ts.u.derived->attr.alloc_comp) + && !CLASS_DATA (f->sym)->attr.class_pointer) { - tmp = gfc_class_data_get (f->sym->backend_decl); - if (CLASS_DATA (f->sym)->as == NULL) - tmp = build_fold_indirect_ref_loc (input_location, tmp); - tmp = gfc_deallocate_alloc_comp (CLASS_DATA (f->sym)->ts.u.derived, - tmp, - CLASS_DATA (f->sym)->as ? - CLASS_DATA (f->sym)->as->rank : 0); - - if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master) - { - present = gfc_conv_expr_present (f->sym); + gfc_expr *final_expr = NULL; + gfc_expr *vptr_size; + gfc_code *code; + gfc_symbol *vtab; + gfc_component *final; + + /* Make sure the vtab is available. */ + gfc_get_derived_vtab (f->sym->ts.u.derived); + final_expr = gfc_lval_expr_from_sym (f->sym); + vptr_size = gfc_lval_expr_from_sym (f->sym); + gfc_add_vptr_component (final_expr); + gfc_add_component_ref (final_expr, "_final"); + gfc_add_vptr_component (vptr_size); + gfc_add_component_ref (vptr_size, "_size"); + + f->sym->attr.referenced = 1; + code = gfc_get_code (); + code->resolved_sym = gfc_get_proc_ptr_comp (final_expr)->ts.interface; + code->ext.actual = gfc_get_actual_arglist (); + code->ext.actual->expr = gfc_lval_expr_from_sym (f->sym); + code->ext.actual->next = gfc_get_actual_arglist (); + code->ext.actual->next->expr = vptr_size; + code->ext.actual->next->next = gfc_get_actual_arglist (); + code->ext.actual->next->next->expr = gfc_get_logical_expr (4, NULL, + true); + code->expr1 = gfc_copy_expr (final_expr); + code->op = EXEC_CALL; + tmp = gfc_trans_call (code, true, NULL, NULL, false); + + /* We don't need add a run-time check when we know that a + finalization wrapper exists. */ + vtab = gfc_find_derived_vtab (f->sym->ts.u.derived); + gcc_assert (vtab); + final = vtab->ts.u.derived->components->next->next->next->next->next; + gcc_assert (strcmp (final->name, "_final") == 0); + + if (!final->initializer || final->initializer->expr_type == EXPR_NULL) + { + tree cond; +/* FIXME: For OPTIONAL, the condition is completely missing, see: PR fortran/54618 */ +/* cond = gfc_class_data_get (f->sym->backend_decl); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cond))) + cond = gfc_conv_descriptor_data_get (cond); + else if (!POINTER_TYPE_P (TREE_TYPE (cond))) + cond = gfc_build_addr_expr (NULL_TREE, cond); */ + cond = gfc_vtable_final_get (f->sym->backend_decl); + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + cond, build_int_cst (TREE_TYPE (cond), 0)); + + if (f->sym->attr.optional + || f->sym->ns->proc_name->attr.entry_master) + { + present = gfc_conv_expr_present (f->sym); + cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, present, cond); + } + tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), - present, tmp, - build_empty_stmt (input_location)); + cond, tmp, build_empty_stmt (input_location)); } - gfc_add_expr_to_block (&init, tmp); } @@ -3780,14 +3881,15 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) NULL_TREE, true, NULL, true); else - tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, - true, NULL, - sym->ts); + tmp = gfc_deallocate_scalar_with_status (se.expr, NULL_TREE, + true, + gfc_lval_expr_from_sym (sym), + sym->ts); } if (sym->ts.type == BT_CLASS) { /* Initialize _vptr to declared type. */ - gfc_symbol *vtab = gfc_find_derived_vtab (sym->ts.u.derived); + gfc_symbol *vtab = gfc_get_derived_vtab (sym->ts.u.derived); tree rhs; gfc_save_backend_locus (&loc); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index d6410d3..a7072d7 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -95,6 +95,7 @@ conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr) #define VTABLE_EXTENDS_FIELD 2 #define VTABLE_DEF_INIT_FIELD 3 #define VTABLE_COPY_FIELD 4 +#define VTABLE_FINAL_FIELD 5 tree @@ -180,6 +181,13 @@ gfc_vtable_copy_get (tree decl) } +tree +gfc_vtable_final_get (tree decl) +{ + return gfc_vtable_field_get (decl, VTABLE_FINAL_FIELD); +} + + #undef CLASS_DATA_FIELD #undef CLASS_VPTR_FIELD #undef VTABLE_HASH_FIELD @@ -187,6 +195,7 @@ gfc_vtable_copy_get (tree decl) #undef VTABLE_EXTENDS_FIELD #undef VTABLE_DEF_INIT_FIELD #undef VTABLE_COPY_FIELD +#undef VTABLE_FINAL_FIELD /* Obtain the vptr of the last class reference in an expression. */ @@ -263,7 +272,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, { /* In this case the vtab corresponds to the derived type and the vptr must point to it. */ - vtab = gfc_find_derived_vtab (e->ts.u.derived); + vtab = gfc_get_derived_vtab (e->ts.u.derived); gcc_assert (vtab); tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); } @@ -859,9 +868,9 @@ gfc_trans_class_assign (gfc_expr *expr1, gfc_expr *expr2, gfc_exec_op op) gfc_add_vptr_component (lhs); if (expr2->ts.type == BT_DERIVED) - vtab = gfc_find_derived_vtab (expr2->ts.u.derived); + vtab = gfc_get_derived_vtab (expr2->ts.u.derived); else if (expr2->expr_type == EXPR_NULL) - vtab = gfc_find_derived_vtab (expr1->ts.u.derived); + vtab = gfc_get_derived_vtab (expr1->ts.u.derived); gcc_assert (vtab); rhs = gfc_get_expr (); @@ -1510,7 +1519,7 @@ conv_parent_component_references (gfc_se * se, gfc_ref * ref) dt = ref->u.c.sym; c = ref->u.c.component; - /* Return if the component is not in the parent type. */ + /* Return if the component is in the parent type. */ for (cmp = dt->components; cmp; cmp = cmp->next) if (strcmp (c->name, cmp->name) == 0) return; @@ -1714,6 +1723,9 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) conv_parent_component_references (se, ref); gfc_conv_component_ref (se, ref); + if (!ref->next && ref->u.c.sym->attr.codimension + && se->want_pointer && se->descriptor_only) + return; break; diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index e9eb307..23a4401 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -7321,7 +7321,7 @@ conv_intrinsic_move_alloc (gfc_code *code) /* Deallocate "to". */ tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, true, - to_expr2, to_expr->ts); + to_expr, to_expr->ts); gfc_add_expr_to_block (&block, tmp); /* Assign (_data) pointers. */ @@ -7356,7 +7356,7 @@ conv_intrinsic_move_alloc (gfc_code *code) else { gfc_symbol *vtab; - vtab = gfc_find_derived_vtab (from_expr->ts.u.derived); + vtab = gfc_get_derived_vtab (from_expr->ts.u.derived); gcc_assert (vtab); tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); } @@ -7387,7 +7387,7 @@ conv_intrinsic_move_alloc (gfc_code *code) else { gfc_symbol *vtab; - vtab = gfc_find_derived_vtab (from_expr->ts.u.derived); + vtab = gfc_get_derived_vtab (from_expr->ts.u.derived); gcc_assert (vtab); tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); } diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index bdc559b..876cde5 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5099,7 +5099,7 @@ gfc_trans_allocate (gfc_code * code) if (ts->type == BT_DERIVED) { - vtab = gfc_find_derived_vtab (ts->u.derived); + vtab = gfc_get_derived_vtab (ts->u.derived); gcc_assert (vtab); gfc_init_se (&lse, NULL); lse.want_pointer = 1; @@ -5186,10 +5186,11 @@ gfc_trans_allocate (gfc_code * code) } else ppc = gfc_lval_expr_from_sym - (gfc_find_derived_vtab (rhs->ts.u.derived)); + (gfc_get_derived_vtab (rhs->ts.u.derived)); gfc_add_component_ref (ppc, "_copy"); ppc_code = gfc_get_code (); + /* FIXME: Probably, the interface is not avilable, cf. _final ...*/ ppc_code->resolved_sym = ppc->symtree->n.sym; /* Although '_copy' is set to be elemental in class.c, it is not staying that way. Find out why, sometime.... */ @@ -5349,13 +5350,107 @@ gfc_trans_deallocate (gfc_code *code) gfc_init_se (&se, NULL); gfc_start_block (&se.pre); +/* FIXME: HOW is var == NULL handled? And how are coarrays error stats handled? */ se.want_pointer = 1; se.descriptor_only = 1; gfc_conv_expr (&se, expr); if (expr->rank || gfc_is_coarray (expr)) { - if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp) + gfc_expr *final_expr = NULL; + gfc_expr *elem_size = NULL; + gfc_code *code; + + if (al->expr->ts.type == BT_CLASS) + { + final_expr = gfc_copy_expr (al->expr); + gfc_add_vptr_component (final_expr); + gfc_add_component_ref (final_expr, "_final"); + + elem_size = gfc_copy_expr (expr); + gfc_add_vptr_component (elem_size); + gfc_add_component_ref (elem_size, "_size"); + } + else if (al->expr->ts.type == BT_DERIVED) + { + gfc_symbol *vtab = gfc_find_derived_vtab (al->expr->ts.u.derived); + if (vtab) + { + gfc_component *final; + final = vtab->ts.u.derived->components; + final = final->next->next->next->next->next; + gcc_assert (strcmp (final->name, "_final") == 0); + + if (final->initializer + && final->initializer->expr_type != EXPR_NULL) + { + tree size; + + final_expr = final->initializer; + + size = gfc_typenode_for_spec (&al->expr->ts); + size = TYPE_SIZE_UNIT (size); + gcc_assert (TREE_INT_CST_HIGH (size) == 0); + elem_size = gfc_get_int_expr (gfc_index_integer_kind, + NULL, + TREE_INT_CST_LOW (size)); + } + } + } + + if (final_expr) + { + tree cond; + + tmp = gfc_conv_descriptor_data_get (se.expr); + STRIP_NOPS (se.expr); + + cond = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, tmp, + null_pointer_node); + + if (al->expr->ts.type == BT_CLASS) + { + tree cond2; + gfc_se se2; + + gfc_init_se (&se2, NULL); + se2.want_pointer = 1; + gfc_conv_expr (&se2, final_expr); + cond2 = fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, se2.expr, + build_int_cst (TREE_TYPE (se2.expr), + 0)); + cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, + boolean_type_node, cond, cond2); + } + + code = gfc_get_code (); + if (al->expr->ts.type == BT_DERIVED) + code->resolved_sym = final_expr->symtree->n.sym; + else /* FIXME: Is this reachable? */ + code->resolved_sym = gfc_get_proc_ptr_comp (final_expr)->ts.interface; + + code->ext.actual = gfc_get_actual_arglist (); + code->ext.actual->expr = gfc_copy_expr (expr); + code->ext.actual->next = gfc_get_actual_arglist (); + code->ext.actual->expr = gfc_copy_expr (expr); + code->ext.actual->next->next = gfc_get_actual_arglist (); + code->ext.actual->next->next->expr = gfc_get_logical_expr (4, NULL, + true); + code->expr1 = gfc_copy_expr (final_expr); + code->op = EXEC_CALL; + tmp = gfc_trans_call (code, true, NULL, NULL, false); + + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + cond, tmp, + build_empty_stmt (input_location)); + gfc_free_statements (code); + gfc_add_expr_to_block (&se.pre, tmp); + } + + if (!final_expr && expr->ts.type == BT_DERIVED + && expr->ts.u.derived->attr.alloc_comp) { gfc_ref *ref; gfc_ref *last = NULL; @@ -5380,7 +5475,7 @@ gfc_trans_deallocate (gfc_code *code) else { tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, false, - expr, expr->ts); + al->expr, al->expr->ts); gfc_add_expr_to_block (&se.pre, tmp); /* Set to zero after deallocation. */ @@ -5393,7 +5488,7 @@ gfc_trans_deallocate (gfc_code *code) { /* Reset _vptr component to declared type. */ gfc_expr *rhs, *lhs = gfc_copy_expr (al->expr); - gfc_symbol *vtab = gfc_find_derived_vtab (al->expr->ts.u.derived); + gfc_symbol *vtab = gfc_get_derived_vtab (al->expr->ts.u.derived); gfc_add_vptr_component (lhs); rhs = gfc_lval_expr_from_sym (vtab); tmp = gfc_trans_pointer_assignment (lhs, rhs); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 35a39c5..caf9eb6 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -2654,7 +2654,7 @@ create_fn_spec (gfc_symbol *sym, tree fntype) { gfc_symbol *result = sym->result ? sym->result : sym; - if (result->attr.pointer || sym->attr.proc_pointer) + if (result->attr.pointer || result->attr.proc_pointer) spec[spec_len++] = '.'; else spec[spec_len++] = 'w'; diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 6365213..0b0752a 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1077,21 +1077,96 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail, gfc_start_block (&non_null); /* Free allocatable components. */ - if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp) +{ + gfc_expr *final_expr = NULL; + gfc_expr *elem_size = NULL; + gfc_code *code; + +/* FIXME: !expr && ts.type == BT_CLASS shouldn't happen. + Cf. trans-array.c's structure_alloc_comps for a case where it does occur. */ + if (expr && ts.type == BT_CLASS) { - tmp = build_fold_indirect_ref_loc (input_location, pointer); - tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0); + final_expr = gfc_copy_expr (expr); + gfc_add_vptr_component (final_expr); + gfc_add_component_ref (final_expr, "_final"); + + elem_size = gfc_copy_expr (expr); + gfc_add_vptr_component (elem_size); + gfc_add_component_ref (elem_size, "_size"); + } + else if (expr && ts.type == BT_DERIVED) + { + gfc_symbol *vtab = gfc_find_derived_vtab (ts.u.derived); + if (vtab) + { + gfc_component *final; + final = vtab->ts.u.derived->components->next->next->next->next->next; + gcc_assert (strcmp (final->name, "_final") == 0); + + if (final->initializer && final->initializer->expr_type != EXPR_NULL) + { + tree size; + + final_expr = final->initializer; + + size = gfc_typenode_for_spec (&ts); + size = TYPE_SIZE_UNIT (size); + gcc_assert (TREE_INT_CST_HIGH (size) == 0); + elem_size = gfc_get_int_expr (gfc_index_integer_kind, NULL, + TREE_INT_CST_LOW (size)); + } + } + } + + if (final_expr) + { + gcc_assert (expr); + gcc_assert (final_expr->expr_type == EXPR_VARIABLE); + + code = gfc_get_code (); + if (ts.type == BT_DERIVED) + code->resolved_sym = final_expr->symtree->n.sym; + else /* FIXME: IS this properly reachable and makes sense? and initialized above? */ + code->resolved_sym = gfc_get_proc_ptr_comp (final_expr)->ts.interface; + + code->ext.actual = gfc_get_actual_arglist (); + code->ext.actual->expr = gfc_copy_expr (expr); + code->ext.actual->next = gfc_get_actual_arglist (); + code->ext.actual->next->expr = elem_size; + code->ext.actual->next->next = gfc_get_actual_arglist (); + code->ext.actual->next->next->expr = gfc_get_logical_expr (4, NULL, + true); + code->expr1 = gfc_copy_expr (final_expr); + code->op = EXEC_CALL; + tmp = gfc_trans_call (code, true, NULL, NULL, false); + + if (ts.type == BT_CLASS) + { + tree cond; + gfc_se se; + + gfc_init_se (&se, NULL); + se.want_pointer = 1; + gfc_conv_expr (&se, final_expr); + cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + se.expr, + build_int_cst (TREE_TYPE (se.expr), 0)); + + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + cond, tmp, build_empty_stmt (input_location)); + } + + gfc_free_statements (code); gfc_add_expr_to_block (&non_null, tmp); } - else if (ts.type == BT_CLASS - && ts.u.derived->components->ts.u.derived->attr.alloc_comp) + + if (!final_expr && ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp) { tmp = build_fold_indirect_ref_loc (input_location, pointer); - tmp = gfc_deallocate_alloc_comp (ts.u.derived->components->ts.u.derived, - tmp, 0); + tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0); gfc_add_expr_to_block (&non_null, tmp); } - +} tmp = build_call_expr_loc (input_location, builtin_decl_explicit (BUILT_IN_FREE), 1, fold_convert (pvoid_type_node, pointer)); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 954dcd3..1779575 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -348,6 +348,7 @@ tree gfc_vtable_size_get (tree); tree gfc_vtable_extends_get (tree); tree gfc_vtable_def_init_get (tree); tree gfc_vtable_copy_get (tree); +tree gfc_vtable_final_get (tree); tree gfc_get_vptr_from_expr (tree); tree gfc_get_class_array_ref (tree, tree); tree gfc_copy_class_to_class (tree, tree, tree);