From 2dbe0f4c8ce1ac533cdb312bc3c243f6949c893c Mon Sep 17 00:00:00 2001 From: burnus Date: Mon, 7 Jan 2013 11:10:53 +0000 Subject: [PATCH] 2013-01-07 Tobias Burnus Thomas Koenig 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 PR fortran/55852 * gfortran.dg/intrinsic_size_3.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@194966 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 12 ++ gcc/fortran/class.c | 187 +++++++------------------ gcc/fortran/expr.c | 14 +- gcc/fortran/gfortran.h | 3 +- gcc/fortran/simplify.c | 4 +- gcc/testsuite/ChangeLog | 5 + gcc/testsuite/gfortran.dg/intrinsic_size_3.f90 | 26 ++++ 7 files changed, 108 insertions(+), 143 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/intrinsic_size_3.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 7266110..3444073 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,15 @@ +2013-01-07 Tobias Burnus + Thomas Koenig + + 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. + 2012-01-07 Tobias Burnus PR fortran/55763 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 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; /* + . */ 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/ChangeLog b/gcc/testsuite/ChangeLog index 0d36ca2..435e49e 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2013-01-07 Tobias Burnus + + PR fortran/55852 + * gfortran.dg/intrinsic_size_3.f90: New. + 2012-01-07 Tobias Burnus PR fortran/55763 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" } } -- 2.7.4