This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[Patch, Fortran] PR55852 fix ubound /size ICE and cleanup class.c's finalizer
- From: Tobias Burnus <burnus at net-b dot de>
- To: gcc patches <gcc-patches at gcc dot gnu dot org>, gfortran <fortran at gcc dot gnu dot org>, Thomas Koenig <tkoenig at gcc dot gnu dot org>
- Date: Mon, 07 Jan 2013 10:13:31 +0100
- Subject: [Patch, Fortran] PR55852 fix ubound /size ICE and cleanup class.c's finalizer
Dear all,
the following patch is based on Thomas' comment 5 in PR55852. He
independently created a patch for the PR; his version is in comment 6:
http://gcc.gnu.org/bugzilla/show_bug.cgi?id=55852#c6
The problem with the current trunk's version of gfc_build_intrinsic_call
is that it assumes that gfc_find_symtree will return the intrinsic
function ("size" in this case); if the user has a different symbol named
"size" or hasn't used "size", the code doesn't work.
My version is attached.
In my version, the gfc_build_intrinsic_call takes "gfc_isym_id" as
identifier for the intrinsic - the passed string is mangled via
GFC_PREFIX to avoid issues with symbol declarations of the user.
I do set rather bluntly "n.sym... = ", assuming that under mangled name
one always finds this intrinsic function.
Besides fixing the ICE, I used the opportunity to cleanup class.c, where
I now use gfc_build_intrinsic_call, which is a nice cleanup: 4 files
changed, 65 insertions(+), 143 deletions(-)
Build and regtested on x86-64-gnu-linux.
OK for the trunk?
Tobias
2013-01-07 Tobias Burnus <burnus@net-b.de>
Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/55852
* expr.c (gfc_build_intrinsic_call): Avoid clashes
with user's procedures.
* gfortran.h (gfc_build_intrinsic_call): Update prototype.
* simplify.c (gfc_simplify_size): Update call.
* class.c (finalization_scalarizer, finalization_get_offset,
finalizer_insert_packed_call, generate_finalization_wrapper):
Clean up by using gfc_build_intrinsic_call.
2013-01-07 Tobias Burnus <burnus@net-b.de>
PR fortran/55852
* gfortran.dg/intrinsic_size_3.f90: New.
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 0d34e78..5fdf0a3 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -969,31 +969,6 @@ finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr,
/* The <addr> part: TRANSFER (C_LOC (array), c_intptr_t). */
- /* TRANSFER. */
- expr2 = gfc_get_expr ();
- expr2->expr_type = EXPR_FUNCTION;
- expr2->value.function.name = "__transfer0";
- expr2->value.function.isym
- = gfc_intrinsic_function_by_id (GFC_ISYM_TRANSFER);
- /* Set symtree for -fdump-parse-tree. */
- gfc_get_sym_tree ("transfer", sub_ns, &expr2->symtree, false);
- expr2->symtree->n.sym->intmod_sym_id = GFC_ISYM_TRANSFER;
- expr2->symtree->n.sym->attr.flavor = FL_PROCEDURE;
- expr2->symtree->n.sym->attr.intrinsic = 1;
- gfc_commit_symbol (expr2->symtree->n.sym);
- expr2->value.function.actual = gfc_get_actual_arglist ();
- expr2->value.function.actual->expr
- = gfc_lval_expr_from_sym (array);
- expr2->ts.type = BT_INTEGER;
- expr2->ts.kind = gfc_index_integer_kind;
-
- /* TRANSFER's second argument: 0_c_intptr_t. */
- expr2->value.function.actual = gfc_get_actual_arglist ();
- expr2->value.function.actual->next = gfc_get_actual_arglist ();
- expr2->value.function.actual->next->expr
- = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
- expr2->value.function.actual->next->next = gfc_get_actual_arglist ();
-
/* TRANSFER's first argument: C_LOC (array). */
expr = gfc_get_expr ();
expr->expr_type = EXPR_FUNCTION;
@@ -1010,7 +985,14 @@ finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr,
gfc_commit_symbol (expr->symtree->n.sym);
expr->ts.type = BT_INTEGER;
expr->ts.kind = gfc_index_integer_kind;
- expr2->value.function.actual->expr = expr;
+
+ /* TRANSFER. */
+ expr2 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_TRANSFER, "transfer",
+ gfc_current_locus, 2, expr,
+ gfc_get_int_expr (gfc_index_integer_kind,
+ NULL, 0));
+ expr2->ts.type = BT_INTEGER;
+ expr2->ts.kind = gfc_index_integer_kind;
/* <array addr> + <offset>. */
block->ext.actual->expr = gfc_get_expr ();
@@ -1072,27 +1054,18 @@ finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset,
* strides(idx2). */
/* mod (idx, sizes(idx2)). */
- expr = gfc_get_expr ();
- expr->expr_type = EXPR_FUNCTION;
- expr->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_MOD);
- gfc_get_sym_tree ("mod", sub_ns, &expr->symtree, false);
- expr->symtree->n.sym->intmod_sym_id = GFC_ISYM_MOD;
- expr->symtree->n.sym->attr.flavor = FL_PROCEDURE;
- expr->symtree->n.sym->attr.intrinsic = 1;
- gfc_commit_symbol (expr->symtree->n.sym);
- expr->value.function.actual = gfc_get_actual_arglist ();
- expr->value.function.actual->expr = gfc_lval_expr_from_sym (idx);
- expr->value.function.actual->next = gfc_get_actual_arglist ();
- expr->value.function.actual->next->expr = gfc_lval_expr_from_sym (sizes);
- expr->value.function.actual->next->expr->ref = gfc_get_ref ();
- expr->value.function.actual->next->expr->ref->type = REF_ARRAY;
- expr->value.function.actual->next->expr->ref->u.ar.as = sizes->as;
- expr->value.function.actual->next->expr->ref->u.ar.type = AR_ELEMENT;
- expr->value.function.actual->next->expr->ref->u.ar.dimen = 1;
- expr->value.function.actual->next->expr->ref->u.ar.dimen_type[0]
- = DIMEN_ELEMENT;
- expr->value.function.actual->next->expr->ref->u.ar.start[0]
- = gfc_lval_expr_from_sym (idx2);
+ expr = gfc_lval_expr_from_sym (sizes);
+ expr->ref = gfc_get_ref ();
+ expr->ref->type = REF_ARRAY;
+ expr->ref->u.ar.as = sizes->as;
+ expr->ref->u.ar.type = AR_ELEMENT;
+ expr->ref->u.ar.dimen = 1;
+ expr->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT;
+ expr->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx2);
+
+ expr = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_MOD, "mod",
+ gfc_current_locus, 2,
+ gfc_lval_expr_from_sym (idx), expr);
expr->ts = idx->ts;
/* (...) / sizes(idx2-1). */
@@ -1195,7 +1168,7 @@ static void
finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
gfc_symbol *array, gfc_symbol *byte_stride,
gfc_symbol *idx, gfc_symbol *ptr,
- gfc_symbol *nelem, gfc_symtree *size_intr,
+ gfc_symbol *nelem,
gfc_symbol *strides, gfc_symbol *sizes,
gfc_symbol *idx2, gfc_symbol *offset,
gfc_symbol *is_contiguous, gfc_expr *rank,
@@ -1225,24 +1198,12 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
size_expr->value.op.op = INTRINSIC_DIVIDE;
/* STORAGE_SIZE (array,kind=c_intptr_t). */
- size_expr->value.op.op1 = gfc_get_expr ();
- size_expr->value.op.op1->where = gfc_current_locus;
- size_expr->value.op.op1->expr_type = EXPR_FUNCTION;
- size_expr->value.op.op1->value.function.isym
- = gfc_intrinsic_function_by_id (GFC_ISYM_STORAGE_SIZE);
- gfc_get_sym_tree ("storage_size", sub_ns, &size_expr->value.op.op1->symtree,
- false);
- size_expr->value.op.op1->symtree->n.sym->intmod_sym_id
- = GFC_ISYM_STORAGE_SIZE;
- size_expr->value.op.op1->symtree->n.sym->attr.flavor = FL_PROCEDURE;
- size_expr->value.op.op1->symtree->n.sym->attr.intrinsic = 1;
- gfc_commit_symbol (size_expr->value.op.op1->symtree->n.sym);
- size_expr->value.op.op1->value.function.actual = gfc_get_actual_arglist ();
- size_expr->value.op.op1->value.function.actual->expr
- = gfc_lval_expr_from_sym (array);
- size_expr->value.op.op1->value.function.actual->next = gfc_get_actual_arglist ();
- size_expr->value.op.op1->value.function.actual->next->expr
- = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+ size_expr->value.op.op1
+ = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STORAGE_SIZE,
+ "storage_size", gfc_current_locus, 2,
+ gfc_lval_expr_from_sym (array));
+ gfc_get_int_expr (gfc_index_integer_kind,
+ NULL, 0);
/* NUMERIC_STORAGE_SIZE. */
size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
@@ -1356,21 +1317,14 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
tmp_array->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
NULL, 1);
/* SIZE (array, dim=i+1, kind=default_kind). */
- shape_expr = gfc_get_expr ();
- shape_expr->expr_type = EXPR_FUNCTION;
- shape_expr->value.function.isym
- = gfc_intrinsic_function_by_id (GFC_ISYM_SIZE);
- shape_expr->symtree = size_intr;
- shape_expr->value.function.actual = gfc_get_actual_arglist ();
- shape_expr->value.function.actual->expr = gfc_lval_expr_from_sym (array);
- shape_expr->value.function.actual->next = gfc_get_actual_arglist ();
- shape_expr->value.function.actual->next->expr
- = gfc_get_int_expr (gfc_default_integer_kind, NULL, i+1);
- shape_expr->value.function.actual->next->next = gfc_get_actual_arglist ();
- shape_expr->value.function.actual->next->next->expr
- = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
- shape_expr->ts = shape_expr->value.function.isym->ts;
-
+ shape_expr
+ = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_SIZE, "size",
+ gfc_current_locus, 3,
+ gfc_lval_expr_from_sym (array),
+ gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, i+1),
+ gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, 0));
tmp_array->as->upper[i] = shape_expr;
}
gfc_set_sym_referenced (tmp_array);
@@ -1495,7 +1449,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
{
gfc_symbol *final, *array, *fini_coarray, *byte_stride, *sizes, *strides;
gfc_symbol *ptr = NULL, *idx, *idx2, *is_contiguous, *offset, *nelem;
- gfc_symtree *size_intr;
gfc_component *comp;
gfc_namespace *sub_ns;
gfc_code *last_code, *block;
@@ -1678,17 +1631,9 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
gfc_commit_symbol (offset);
/* Create RANK expression. */
- rank = gfc_get_expr ();
- rank->expr_type = EXPR_FUNCTION;
- rank->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_RANK);
- gfc_get_sym_tree ("rank", sub_ns, &rank->symtree, false);
- rank->symtree->n.sym->intmod_sym_id = GFC_ISYM_RANK;
- rank->symtree->n.sym->attr.flavor = FL_PROCEDURE;
- rank->symtree->n.sym->attr.intrinsic = 1;
- gfc_commit_symbol (rank->symtree->n.sym);
- rank->value.function.actual = gfc_get_actual_arglist ();
- rank->value.function.actual->expr = gfc_lval_expr_from_sym (array);
- rank->ts = rank->value.function.isym->ts;
+ rank = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_RANK, "rank",
+ gfc_current_locus, 1,
+ gfc_lval_expr_from_sym (array));
gfc_convert_type (rank, &idx->ts, 2);
/* Create is_contiguous variable. */
@@ -1805,23 +1750,10 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
block->expr1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx);
block->expr1->ref->u.ar.as = strides->as;
- block->expr2 = gfc_get_expr ();
- block->expr2->expr_type = EXPR_FUNCTION;
- block->expr2->value.function.isym
- = gfc_intrinsic_function_by_id (GFC_ISYM_STRIDE);
- gfc_get_sym_tree (GFC_PREFIX ("stride"), sub_ns,
- &block->expr2->symtree, false);
- block->expr2->symtree->n.sym->intmod_sym_id = GFC_ISYM_STRIDE;
- block->expr2->symtree->n.sym->attr.flavor = FL_PROCEDURE;
- block->expr2->symtree->n.sym->attr.intrinsic = 1;
- gfc_commit_symbol (block->expr2->symtree->n.sym);
- block->expr2->value.function.actual = gfc_get_actual_arglist ();
- block->expr2->value.function.actual->expr = gfc_lval_expr_from_sym (array);
- /* dim=idx. */
- block->expr2->value.function.actual->next = gfc_get_actual_arglist ();
- block->expr2->value.function.actual->next->expr
- = gfc_lval_expr_from_sym (idx);
- block->expr2->ts = block->expr2->value.function.isym->ts;
+ block->expr2 = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_STRIDE, "stride",
+ gfc_current_locus, 2,
+ gfc_lval_expr_from_sym (array),
+ gfc_lval_expr_from_sym (idx));
/* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */
block->next = XCNEW (gfc_code);
@@ -1862,32 +1794,13 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
= block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op1->ts;
/* size(array, dim=idx, kind=index_kind). */
- block->expr2->value.op.op2 = gfc_get_expr ();
- block->expr2->value.op.op2->expr_type = EXPR_FUNCTION;
- block->expr2->value.op.op2->value.function.isym
- = gfc_intrinsic_function_by_id (GFC_ISYM_SIZE);
- gfc_get_sym_tree ("size", sub_ns, &block->expr2->value.op.op2->symtree,
- false);
- size_intr = block->expr2->value.op.op2->symtree;
- block->expr2->value.op.op2->symtree->n.sym->intmod_sym_id = GFC_ISYM_SIZE;
- block->expr2->value.op.op2->symtree->n.sym->attr.flavor = FL_PROCEDURE;
- block->expr2->value.op.op2->symtree->n.sym->attr.intrinsic = 1;
- gfc_commit_symbol (block->expr2->value.op.op2->symtree->n.sym);
- block->expr2->value.op.op2->value.function.actual
- = gfc_get_actual_arglist ();
- block->expr2->value.op.op2->value.function.actual->expr
- = gfc_lval_expr_from_sym (array);
- /* dim=idx. */
- block->expr2->value.op.op2->value.function.actual->next
- = gfc_get_actual_arglist ();
- block->expr2->value.op.op2->value.function.actual->next->expr
- = gfc_lval_expr_from_sym (idx);
- /* kind=c_intptr_t. */
- block->expr2->value.op.op2->value.function.actual->next->next
- = gfc_get_actual_arglist ();
- block->expr2->value.op.op2->value.function.actual->next->next->expr
- = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
- block->expr2->value.op.op2->ts = idx->ts;
+ block->expr2->value.op.op2
+ = gfc_build_intrinsic_call (sub_ns, GFC_ISYM_SIZE, "size",
+ gfc_current_locus, 3,
+ gfc_lval_expr_from_sym (array),
+ gfc_lval_expr_from_sym (idx),
+ gfc_get_int_expr (gfc_index_integer_kind,
+ NULL, 0));
block->expr2->ts = idx->ts;
/* if (strides(idx) /= sizes(idx-1)) is_contiguous = .false. */
@@ -2053,7 +1966,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
/* CALL fini_rank (array) - possibly with packing. */
if (fini->proc_tree->n.sym->formal->sym->attr.dimension)
finalizer_insert_packed_call (block, fini, array, byte_stride,
- idx, ptr, nelem, size_intr, strides,
+ idx, ptr, nelem, strides,
sizes, idx2, offset, is_contiguous,
rank, sub_ns);
else
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 2610784..74a17eb 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4622,28 +4622,34 @@ gfc_is_simply_contiguous (gfc_expr *expr, bool strict)
want to add arguments but with a NULL-expression. */
gfc_expr*
-gfc_build_intrinsic_call (const char* name, locus where, unsigned numarg, ...)
+gfc_build_intrinsic_call (gfc_namespace *ns, gfc_isym_id id, const char* name,
+ locus where, unsigned numarg, ...)
{
gfc_expr* result;
gfc_actual_arglist* atail;
gfc_intrinsic_sym* isym;
va_list ap;
unsigned i;
+ const char *mangled_name = gfc_get_string (GFC_PREFIX ("%s"), name);
- isym = gfc_find_function (name);
+ isym = gfc_intrinsic_function_by_id (id);
gcc_assert (isym);
result = gfc_get_expr ();
result->expr_type = EXPR_FUNCTION;
result->ts = isym->ts;
result->where = where;
- result->value.function.name = name;
+ result->value.function.name = mangled_name;
result->value.function.isym = isym;
- result->symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
+ gfc_get_sym_tree (mangled_name, ns, &result->symtree, false);
+ gfc_commit_symbol (result->symtree->n.sym);
gcc_assert (result->symtree
&& (result->symtree->n.sym->attr.flavor == FL_PROCEDURE
|| result->symtree->n.sym->attr.flavor == FL_UNKNOWN));
+ result->symtree->n.sym->intmod_sym_id = id;
+ result->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+ result->symtree->n.sym->attr.intrinsic = 1;
va_start (ap, numarg);
atail = NULL;
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 027cab6..5a68873 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2798,7 +2798,8 @@ int gfc_get_corank (gfc_expr *);
bool gfc_has_ultimate_allocatable (gfc_expr *);
bool gfc_has_ultimate_pointer (gfc_expr *);
-gfc_expr* gfc_build_intrinsic_call (const char*, locus, unsigned, ...);
+gfc_expr* gfc_build_intrinsic_call (gfc_namespace *, gfc_isym_id, const char*,
+ locus, unsigned, ...);
gfc_try gfc_check_vardef_context (gfc_expr*, bool, bool, bool, const char*);
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index eb3e8c3..9f148ba 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -5584,7 +5584,9 @@ gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
/* Otherwise, we build a new SIZE call. This is hopefully at least
simpler than the original one. */
if (!simplified)
- simplified = gfc_build_intrinsic_call ("size", array->where, 3,
+ simplified = gfc_build_intrinsic_call (gfc_current_ns,
+ GFC_ISYM_SIZE, "size",
+ array->where, 3,
gfc_copy_expr (replacement),
gfc_copy_expr (dim),
gfc_copy_expr (kind));
diff --git a/gcc/testsuite/gfortran.dg/intrinsic_size_3.f90 b/gcc/testsuite/gfortran.dg/intrinsic_size_3.f90
new file mode 100644
index 0000000..d5f4bd2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/intrinsic_size_3.f90
@@ -0,0 +1,26 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! PR fortran/55852
+!
+! Contributed by A. Kasahara
+!
+program bug
+ implicit none
+
+ Real, allocatable:: a(:)
+ integer(2) :: iszs
+
+ allocate(a(1:3))
+
+ iszs = ubound((a), 1)! Was ICEing
+! print*, ubound((a), 1) ! Was ICEing
+! print*, ubound(a, 1) ! OK
+! print*, lbound((a), 1) ! OK
+! print*, lbound(a, 1) ! OK
+
+ stop
+end program bug
+
+! { dg-final { scan-tree-dump-times "iszs = \\(integer\\(kind=2\\)\\) MAX_EXPR <\\(D.....->dim.0..ubound - D.....->dim.0..lbound\\) \\+ 1, 0>;" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }