&& (expr2->expr_type != EXPR_OP
|| expr2->value.op.op != INTRINSIC_CONCAT))
return 0;
-
+
if (!gfc_check_dependency (expr1, expr2, true))
return 0;
return ns;
}
+
+/* Insert a call to the intrinsic len. Use a different name for
+ the symbol tree so we don't run into trouble when the user has
+ renamed len for some reason. */
+
+static gfc_expr*
+get_len_call (gfc_expr *str)
+{
+ gfc_expr *fcn;
+ gfc_actual_arglist *actual_arglist;
+
+ fcn = gfc_get_expr ();
+ fcn->expr_type = EXPR_FUNCTION;
+ fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN);
+ actual_arglist = gfc_get_actual_arglist ();
+ actual_arglist->expr = str;
+
+ fcn->value.function.actual = actual_arglist;
+ fcn->where = str->where;
+ fcn->ts.type = BT_INTEGER;
+ fcn->ts.kind = gfc_charlen_int_kind;
+
+ gfc_get_sym_tree ("__internal_len", current_ns, &fcn->symtree, false);
+ fcn->symtree->n.sym->ts = fcn->ts;
+ fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+ fcn->symtree->n.sym->attr.function = 1;
+ fcn->symtree->n.sym->attr.elemental = 1;
+ fcn->symtree->n.sym->attr.referenced = 1;
+ fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
+ gfc_commit_symbol (fcn->symtree->n.sym);
+
+ return fcn;
+}
+
+
/* Returns a new expression (a variable) to be used in place of the old one,
with an optional assignment statement before the current statement to set
the value of the variable. Creates a new BLOCK for the statement if that
length = constant_string_length (e);
if (length)
symbol->ts.u.cl->length = length;
+ else if (e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->ts.type == BT_CHARACTER
+ && e->ts.u.cl->length)
+ symbol->ts.u.cl->length = get_len_call (gfc_copy_expr (e));
else
{
symbol->attr.allocatable = 1;
{
/* Check for (a(i,i), i=1,3). */
int j;
-
+
for (j=0; j<i; j++)
if (iters[j] && iters[j]->var->symtree == start->symtree)
return false;
|| var_in_expr (var, iters[j]->end)
|| var_in_expr (var, iters[j]->step)))
return false;
- }
+ }
}
}
return fcn;
}
+
/* Optimize expressions for equality. */
static bool
/* If we do not know about the stepsize, the loop may be zero trip.
Do not warn in this case. */
-
+
if (dl->ext.iterator->step->expr_type == EXPR_CONSTANT)
mpz_init_set (do_step, dl->ext.iterator->step->value.integer);
else
else
have_do_start = false;
-
+
if (dl->ext.iterator->end->expr_type == EXPR_CONSTANT)
{
have_do_end = true;
{
gfc_expr *e, *n;
bool *found = (bool *) data;
-
+
e = *ep;
if (e->expr_type != EXPR_FUNCTION
return 0;
/* Check if this is already in the form c = matmul(a,b). */
-
+
if ((*current_code)->expr2 == e)
return 0;
n = create_var (e, "matmul");
-
+
/* If create_var is unable to create a variable (for example if
-fno-realloc-lhs is in force with a variable that does not have bounds
known at compile-time), just return. */
if (n == NULL)
return 0;
-
+
*ep = n;
*found = true;
return 0;
inserted_block = NULL;
changed_statement = NULL;
}
-
+
return 0;
}
bool a_tmp, b_tmp;
gfc_expr *matrix_a, *matrix_b;
bool conjg_a, conjg_b, transpose_a, transpose_b;
-
+
co = *c;
if (co->op != EXEC_ASSIGN)
if (!a_tmp && !b_tmp)
return 0;
-
+
current_code = c;
inserted_block = NULL;
changed_statement = NULL;
/* For assumed size, we need to keep around the final
reference in order not to get an error on resolution
below, and we cannot use AR_FULL. */
-
+
if (ar->as->type == AS_ASSUMED_SIZE)
{
ar->type = AR_SECTION;
default:
gcc_unreachable ();
}
- }
+ }
/* Handle the reallocation, if needed. */
int n[GFC_MAX_DIMENSIONS];
} ind_type;
-/* Callback function to determine if an expression is the
+/* Callback function to determine if an expression is the
corresponding variable. */
static int
gfc_forall_iterator *fa;
ind_type *ind;
int i, j;
-
+
if (co->op != EXEC_FORALL && co->op != EXEC_DO_CONCURRENT)
return 0;
if (co->op == EXEC_SELECT)
select_level --;
-
+
in_omp_workshare = saved_in_omp_workshare;
in_where = saved_in_where;
}
! Tests the fix for PR85603.
!
! Contributed by Walt Spector <w6ws@earthlink.net>
+!_____________________________________________
+! Module for a test against a regression that occurred with
+! the first patch for this PR.
+!
+MODULE TN4
+ IMPLICIT NONE
+ PRIVATE
+ INTEGER,PARAMETER::SH4=KIND('a')
+ TYPE,PUBLIC::TOP
+ CHARACTER(:,KIND=SH4),ALLOCATABLE::ROR
+ CHARACTER(:,KIND=SH4),ALLOCATABLE::VI8
+ CONTAINS
+ PROCEDURE,NON_OVERRIDABLE::SB=>TPX
+ END TYPE TOP
+CONTAINS
+ SUBROUTINE TPX(TP6,PP4)
+ CLASS(TOP),INTENT(INOUT)::TP6
+ INTEGER,INTENT(IN)::PP4
+ TP6%ROR=TP6%ROR(:PP4-1)
+ TP6%VI8=TP6%ROR(:PP4-1)
+ END SUBROUTINE TPX
+END MODULE TN4
+!_____________________________________________
!
program strlen_bug
implicit none
'somewhat longer' ]
maxlen = maxval (len_trim (strings))
if (maxlen .ne. 15) stop 1
- strings = strings(:)(:maxlen) ! Used to ICE
- if (any (strings .ne. ['short ','somewhat longer'])) stop 2
+
+! Used to cause an ICE and in the later version of the problem did not reallocate.
+ strings = strings(:)(:maxlen)
+ if (any (strings .ne. ['short ','somewhat longer' ])) stop 2
+ if (len (strings) .ne. maxlen) stop 3
+
+! Try something a bit more complicated.
+ strings = strings(:)(2:maxlen - 5)
+ if (any (strings .ne. ['hort ','omewhat l' ])) stop 4
+ if (len (strings) .ne. maxlen - 6) stop 5
deallocate (strings) ! To check for memory leaks
+
+! Test the regression, noted by Dominique d'Humieres is fixed.
+! Referenced in https://groups.google.com/forum/#!topic/comp.lang.fortran/nV3TlRlVKBc
+!
+ call foo
+contains
+ subroutine foo
+ USE TN4
+ TYPE(TOP) :: Z
+
+ Z%ROR = 'abcd'
+ call Z%SB (3)
+ if (Z%VI8 .ne. 'ab') stop 6
+end
+
end program
projects / gcc.git / commitdiff