re PR fortran/55852 (internal compiler error: in gfc_build_intrinsic_call, at fortran...

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.

Co-Authored-By: Thomas Koenig <tkoenig@gcc.gnu.org>
From-SVN: r194966

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 72661108e4f24a3d8d82c80dff58117fcbff9655..344407374e7e8978b44060323d98bf229c72d42e 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,15 @@
+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.
+
 2012-01-07  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/55763

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 0d34e78e5de3c13223a471f15b22a6ea9a0d17d2..5fdf0a30ce8c226fe2fe4c789d0ac3357b73b4d8 100644 (file)
--- 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 261078460d255ceefaad5c3db908f784f4ede17b..74a17eb93f390cf661967a18cc4e195bc026240d 100644 (file)
--- 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 027cab6b356dfc3a13c4b0c6f68cfc6c80248ffe..5a6887317522f85f9e3166ac5ca436de9024c8aa 100644 (file)
--- 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 eb3e8c3cfbb1c461df5a0fda14c8208942af6766..9f148ba36483ccf87f2ca0bba298c3335fbac601 100644 (file)
--- 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 0d36ca2cf39afdbcdb1ad9dc236dfe37461a332e..435e49ee09e0f95e1a26ff1954d1b7d822d50d9e 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2013-01-07  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/55852
+       * gfortran.dg/intrinsic_size_3.f90: New.
+
 2012-01-07  Tobias Burnus  <burnus@net-b.de>
 
        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 (file)
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" } }