+2006-04-03 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/26981
+ * trans.h : Prototype for gfc_conv_missing_dummy.
+ * trans-expr (gfc_conv_missing_dummy): New function
+ (gfc_conv_function_call): Call it and tidy up some of the code.
+ * trans-intrinsic (gfc_conv_intrinsic_function_args): The same.
+
+ PR fortran/26976
+ * array.c (gfc_array_dimen_size): If available, return shape[dimen].
+ * resolve.c (resolve_function): If available, use the argument shape for the
+ function expression.
+ * iresolve.c (gfc_resolve_transfer): Set shape[0] = size.
+
2006-04-02 Erik Edelmann <eedelman@gcc.gnu.org>
* trans-array.c (gfc_trans_dealloc_allocated): Take a
}
}
+ if (array->shape && array->shape[dimen])
+ {
+ mpz_init_set (*result, array->shape[dimen]);
+ return SUCCESS;
+ }
+
if (spec_dimen_size (array->symtree->n.sym->as, dimen, result) == FAILURE)
return FAILURE;
{
f->rank = 1;
f->value.function.name = transfer1;
+ if (size && gfc_is_constant_expr (size))
+ {
+ f->shape = gfc_get_shape (1);
+ mpz_init_set (f->shape[0], size->value.integer);
+ }
}
}
const char *name;
try t;
int temp;
+ int i;
sym = NULL;
if (expr->symtree)
if (arg->expr != NULL && arg->expr->rank > 0)
{
expr->rank = arg->expr->rank;
+ if (!expr->shape && arg->expr->shape)
+ {
+ expr->shape = gfc_get_shape (expr->rank);
+ for (i = 0; i < expr->rank; i++)
+ mpz_init_set (expr->shape[i], arg->expr->shape[i]);
+ }
break;
}
}
}
+/* Converts a missing, dummy argument into a null or zero. */
+
+void
+gfc_conv_missing_dummy (gfc_se * se, gfc_expr * arg, gfc_typespec ts)
+{
+ tree present;
+ tree tmp;
+
+ present = gfc_conv_expr_present (arg->symtree->n.sym);
+ tmp = build3 (COND_EXPR, TREE_TYPE (se->expr), present, se->expr,
+ convert (TREE_TYPE (se->expr), integer_zero_node));
+ tmp = gfc_evaluate_now (tmp, &se->pre);
+ se->expr = tmp;
+ if (ts.type == BT_CHARACTER)
+ {
+ tmp = convert (gfc_charlen_type_node, integer_zero_node);
+ tmp = build3 (COND_EXPR, gfc_charlen_type_node, present,
+ se->string_length, tmp);
+ tmp = gfc_evaluate_now (tmp, &se->pre);
+ se->string_length = tmp;
+ }
+ return;
+}
+
+
/* Get the character length of an expression, looking through gfc_refs
if necessary. */
bool callee_alloc;
gfc_typespec ts;
gfc_charlen cl;
+ gfc_expr *e;
+ gfc_symbol *fsym;
arglist = NULL_TREE;
retargs = NULL_TREE;
/* Evaluate the arguments. */
for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
{
- if (arg->expr == NULL)
+ e = arg->expr;
+ fsym = formal ? formal->sym : NULL;
+ if (e == NULL)
{
if (se->ignore_optional)
{
/* An elemental function inside a scalarized loop. */
gfc_init_se (&parmse, se);
- gfc_conv_expr_reference (&parmse, arg->expr);
+ gfc_conv_expr_reference (&parmse, e);
}
else
{
/* A scalar or transformational function. */
gfc_init_se (&parmse, NULL);
- argss = gfc_walk_expr (arg->expr);
+ argss = gfc_walk_expr (e);
if (argss == gfc_ss_terminator)
{
- gfc_conv_expr_reference (&parmse, arg->expr);
- if (formal && formal->sym->attr.pointer
- && arg->expr->expr_type != EXPR_NULL)
+ gfc_conv_expr_reference (&parmse, e);
+ if (fsym && fsym->attr.pointer
+ && e->expr_type != EXPR_NULL)
{
/* Scalar pointer dummy args require an extra level of
indirection. The null pointer already contains
convention, and pass the address of the array descriptor
instead. Otherwise we use g77's calling convention. */
int f;
- f = (formal != NULL)
- && !(formal->sym->attr.pointer || formal->sym->attr.allocatable)
- && formal->sym->as->type != AS_ASSUMED_SHAPE;
+ f = (fsym != NULL)
+ && !(fsym->attr.pointer || fsym->attr.allocatable)
+ && fsym->as->type != AS_ASSUMED_SHAPE;
f = f || !sym->attr.always_explicit;
- if (arg->expr->expr_type == EXPR_VARIABLE
- && is_aliased_array (arg->expr))
+ if (e->expr_type == EXPR_VARIABLE
+ && is_aliased_array (e))
/* The actual argument is a component reference to an
array of derived types. In this case, the argument
is converted to a temporary, which is passed and then
written back after the procedure call. */
- gfc_conv_aliased_arg (&parmse, arg->expr, f);
+ gfc_conv_aliased_arg (&parmse, e, f);
else
- gfc_conv_array_parameter (&parmse, arg->expr, argss, f);
+ gfc_conv_array_parameter (&parmse, e, argss, f);
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
allocated on entry, it must be deallocated. */
- if (formal && formal->sym->attr.allocatable
- && formal->sym->attr.intent == INTENT_OUT)
+ if (fsym && fsym->attr.allocatable
+ && fsym->attr.intent == INTENT_OUT)
{
- tmp = arg->expr->symtree->n.sym->backend_decl;
- if (arg->expr->symtree->n.sym->attr.dummy)
+ tmp = e->symtree->n.sym->backend_decl;
+ if (e->symtree->n.sym->attr.dummy)
tmp = build_fold_indirect_ref (tmp);
tmp = gfc_trans_dealloc_allocated (tmp);
gfc_add_expr_to_block (&se->pre, tmp);
}
}
- if (formal && need_interface_mapping)
- gfc_add_interface_mapping (&mapping, formal->sym, &parmse);
+ /* If an optional argument is itself an optional dummy argument,
+ check its presence and substitute a null if absent. */
+ if (e && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional
+ && fsym && fsym->attr.optional)
+ gfc_conv_missing_dummy (&parmse, e, fsym->ts);
+
+ if (fsym && need_interface_mapping)
+ gfc_add_interface_mapping (&mapping, fsym, &parmse);
gfc_add_block_to_block (&se->pre, &parmse.pre);
gfc_add_block_to_block (&se->post, &parmse.post);
gfc_conv_intrinsic_function_args (gfc_se * se, gfc_expr * expr)
{
gfc_actual_arglist *actual;
- tree args;
+ gfc_expr *e;
+ gfc_intrinsic_arg *formal;
gfc_se argse;
+ tree args;
args = NULL_TREE;
- for (actual = expr->value.function.actual; actual; actual = actual->next)
+ formal = expr->value.function.isym->formal;
+
+ for (actual = expr->value.function.actual; actual; actual = actual->next,
+ formal = formal ? formal->next : NULL)
{
+ e = actual->expr;
/* Skip omitted optional arguments. */
- if (!actual->expr)
+ if (!e)
continue;
/* Evaluate the parameter. This will substitute scalarized
references automatically. */
gfc_init_se (&argse, se);
- if (actual->expr->ts.type == BT_CHARACTER)
+ if (e->ts.type == BT_CHARACTER)
{
- gfc_conv_expr (&argse, actual->expr);
+ gfc_conv_expr (&argse, e);
gfc_conv_string_parameter (&argse);
args = gfc_chainon_list (args, argse.string_length);
}
else
- gfc_conv_expr_val (&argse, actual->expr);
+ gfc_conv_expr_val (&argse, e);
+
+ /* If an optional argument is itself an optional dummy argument,
+ check its presence and substitute a null if absent. */
+ if (e->expr_type ==EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional
+ && formal
+ && formal->optional)
+ gfc_conv_missing_dummy (&argse, e, formal->ts);
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
/* Return an expression which determines if a dummy parameter is present. */
tree gfc_conv_expr_present (gfc_symbol *);
+/* Convert a missing, dummy argument into a null or zero. */
+void gfc_conv_missing_dummy (gfc_se *, gfc_expr *, gfc_typespec);
/* Generate code to allocate a string temporary. */
tree gfc_conv_string_tmp (gfc_se *, tree, tree);
+2006-04-03 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/26981
+ * gfortran.dg/missing_optional_dummy_1.f90: New test.
+
+ PR fortran/26976
+ * gfortran.dg/compliant_elemental_intrinsics_1.f90: New test.
+ * gfortran.dg/initialization_1.f90: Make assignment compliant.
+ * gfortran.dg/transfer_array_intrinsic_1.f90: Simplify.
+ * gfortran.dg/transfer_array_intrinsic_2.f90: Make assignments compliant and detect
+ bigendian-ness.
+
2006-04-02 Erik Edelmann <eedelman@gcc.gnu.org>
* gfortran.dg/allocatable_dummy_1.f90: Also check that allocatable
--- /dev/null
+! { dg-do compile }
+! Tests the fix for PR26976, in which non-compliant elemental
+! intrinsic function results were not detected. At the same
+! time, the means to tests the compliance of TRANSFER with the
+! optional SIZE parameter was added.
+!
+! Contributed by Dominique Dhumieres <dominiq@lps.ens.fr>
+!
+real(4) :: pi, a(2), b(3)
+character(26) :: ch
+
+pi = acos(-1.0)
+b = pi
+
+a = cos(b) ! { dg-error "different shape for Array assignment" }
+
+a = -pi
+b = cos(a) ! { dg-error "different shape for Array assignment" }
+
+ch = "abcdefghijklmnopqrstuvwxyz"
+a = transfer (ch, pi, 3) ! { dg-error "different shape for Array assignment" }
+
+! This already generated an error
+b = reshape ((/1.0/),(/1/)) ! { dg-error "different shape for Array assignment" }
+
+end
real(8) :: x (1:2, *)
real(8) :: y (0:,:)
integer :: i
+ real :: z(2, 2)
! However, this gives a warning because it is an initialization expression.
integer :: l1 = len (ch1) ! { dg-warning "assumed character length variable" }
--- /dev/null
+! { dg-do run }
+! Test the fix for PR26891, in which an optional argument, whose actual
+! is a missing dummy argument would cause a segfault.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+ logical :: back =.false.
+
+! This was the case that would fail - PR case was an intrinsic call.
+ if (scan ("A quick brown fox jumps over the lazy dog", "lazy", back) &
+ .ne. myscan ("A quick brown fox jumps over the lazy dog", "lazy")) &
+ call abort ()
+
+! Check that the patch works with non-intrinsic functions.
+ if (myscan ("A quick brown fox jumps over the lazy dog", "fox", back) &
+ .ne. thyscan ("A quick brown fox jumps over the lazy dog", "fox")) &
+ call abort ()
+
+! Check that missing, optional character actual arguments are OK.
+ if (scan ("A quick brown fox jumps over the lazy dog", "over", back) &
+ .ne. thyscan ("A quick brown fox jumps over the lazy dog")) &
+ call abort ()
+
+contains
+ integer function myscan (str, substr, back)
+ character(*), intent(in) :: str, substr
+ logical, optional, intent(in) :: back
+ myscan = scan (str, substr, back)
+ end function myscan
+
+ integer function thyscan (str, substr, back)
+ character(*), intent(in) :: str
+ character(*), optional, intent(in) :: substr
+ logical, optional, intent(in) :: back
+ thyscan = isscan (str, substr, back)
+ end function thyscan
+
+ integer function isscan (str, substr, back)
+ character(*), intent(in) :: str
+ character(*), optional :: substr
+ logical, optional, intent(in) :: back
+ if (.not.present(substr)) then
+ isscan = myscan (str, "over", back)
+ else
+ isscan = myscan (str, substr, back)
+ end if
+ end function isscan
+
+end
-! { dg-do run { target i?86-*-* x86_64-*-* } }
+! { dg-do run }
! Tests the patch to implement the array version of the TRANSFER
! intrinsic (PR17298).
-! Contributed by Paul Thomas <pault@gcc.gnu.org>
- character(8) :: ch(2) = (/"lmnoPQRS","LMNOpqrs"/)
-
-! tests numeric transfers(including PR testcase).
+! test the PR is fixed.
call test1 ()
-! tests numeric/character transfers.
-
- call test2 ()
-
-! Test dummies, automatic objects and assumed character length.
-
- call test3 (ch, ch, ch, 8)
-
contains
subroutine test1 ()
cmp = transfer (z, cmp) * 2.0
if (any (cmp .ne. (/2.0, 4.0/))) call abort ()
-! Check that size smaller than the source word length is OK.
-
- z = (-1.0, -2.0)
- cmp = transfer (z, cmp, 1) * 8.0
- if (any (cmp .ne. (/-8.0, 4.0/))) call abort ()
-
-! Check multi-dimensional sources and that transfer works as an actual
-! argument of reshape.
-
- a = reshape ((/(rand (), i = 1, 16)/), (/4,4/))
- jt = transfer (a, it)
- it = reshape (jt, (/4, 2, 4/))
- if (any (reshape (transfer (it, a), (/4,4/)) .ne. a)) call abort ()
-
end subroutine test1
- subroutine test2 ()
- integer(4) :: y(4), z(2)
- character(4) :: ch(4)
- y = (/(i + ishft (i + 1, 8) + ishft (i + 2, 16) &
- + ishft (i + 3, 24), i = 65, 80 , 4)/)
-
-! Check source array sections in both directions.
-
- ch = "wxyz"
- ch = transfer (y(2:4:2), ch)
- if (any (ch .ne. (/"EFGH","MNOP","wxyz","wxyz"/))) call abort ()
- ch = "wxyz"
- ch = transfer (y(4:2:-2), ch)
- if (any (ch .ne. (/"MNOP","EFGH","wxyz","wxyz"/))) call abort ()
-
-! Check that a complete array transfers with size absent.
-
- ch = transfer (y, ch)
- if (any (ch .ne. (/"ABCD","EFGH","IJKL","MNOP"/))) call abort ()
-
-! Check that a character array section is OK
-
- z = transfer (ch(2:3), y)
- if (any (z .ne. y(2:3))) call abort ()
-
-! Check dest array sections in both directions.
-
- ch = "wxyz"
- ch(3:4) = transfer (y, ch, 2)
- if (any (ch .ne. (/"wxyz","wxyz","ABCD","EFGH"/))) call abort ()
- ch = "wxyz"
- ch(3:2:-1) = transfer (y, ch, 3)
- if (any (ch .ne. (/"wxyz","EFGH","ABCD","wxyz"/))) call abort ()
-
-! Check that too large a value of size is cut off.
-
- ch = "wxyz"
- ch(1:2) = transfer (y, ch, 3)
- if (any (ch .ne. (/"ABCD","EFGH","wxyz","wxyz"/))) call abort ()
-
-! Make sure that character to numeric is OK.
-
- z = transfer (ch, y)
- if (any (y(1:2) .ne. z)) call abort ()
-
- end subroutine test2
-
- subroutine test3 (ch1, ch2, ch3, clen)
- integer clen
- character(8) :: ch1(:)
- character(*) :: ch2(2)
- character(clen) :: ch3(2)
- character(8) :: cntrl(2) = (/"lmnoPQRS","LMNOpqrs"/)
- integer(8) :: ic(2)
- ic = transfer (cntrl, ic)
-
-! Check assumed shape.
-
- if (any (ic .ne. transfer (ch1, ic))) call abort ()
-
-! Check assumed character length.
-
- if (any (ic .ne. transfer (ch2, ic))) call abort ()
-
-! Check automatic character length.
-
- if (any (ic .ne. transfer (ch3, ic))) call abort ()
-
- end subroutine test3
-
end
-! { dg-do run { target i?86-*-* x86_64-*-* } }
-! { dg-options "-fpack-derived" }
- call test3()
+! { dg-do run }
+! Tests the patch to implement the array version of the TRANSFER
+! intrinsic (PR17298).
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+
+! Bigendian test posted by Perseus in comp.lang.fortran on 4 July 2005.
+! Original had parameter but this fails, at present, if is_gimple_var with -Ox, x>0
+
+ LOGICAL :: bigend
+ integer :: icheck = 1
+
+ character(8) :: ch(2) = (/"lmnoPQRS","LMNOpqrs"/)
+
+ bigend = IACHAR(TRANSFER(icheck,"a")) == 0
+
+! tests numeric transfers other than original testscase.
+
+ call test1 ()
+
+! tests numeric/character transfers.
+
+ call test2 ()
+
+! Test dummies, automatic objects and assumed character length.
+
+ call test3 (ch, ch, ch, 8)
+
contains
- subroutine test3 ()
- type mytype
- sequence
- real(8) :: x = 3.14159
- character(4) :: ch = "wxyz"
- integer(2) :: i = 77
- end type mytype
- type(mytype) :: z(2)
- character(1) :: c(32)
- character(4) :: chr
- real(8) :: a
- integer(2) :: l
- equivalence (a, c(15)), (chr, c(23)), (l, c(27))
- c = transfer(z, c)
- if (a .ne. z(1)%x) call abort ()
- if (chr .ne. z(1)%ch) call abort ()
- if (l .ne. z(1)%i) call abort ()
- end subroutine test3
+
+ subroutine test1 ()
+ real(4) :: a(4, 4)
+ integer(2) :: it(4, 2, 4), jt(32)
+
+! Check multi-dimensional sources and that transfer works as an actual
+! argument of reshape.
+
+ a = reshape ((/(rand (), i = 1, 16)/), (/4,4/))
+ jt = transfer (a, it)
+ it = reshape (jt, (/4, 2, 4/))
+ if (any (reshape (transfer (it, a), (/4,4/)) .ne. a)) call abort ()
+
+ end subroutine test1
+
+ subroutine test2 ()
+ integer(4) :: y(4), z(2)
+ character(4) :: ch(4)
+
+! Allow for endian-ness
+ if (bigend) then
+ y = (/(i + 3 + ishft (i + 2, 8) + ishft (i + 1, 16) &
+ + ishft (i, 24), i = 65, 80 , 4)/)
+ else
+ y = (/(i + ishft (i + 1, 8) + ishft (i + 2, 16) &
+ + ishft (i + 3, 24), i = 65, 80 , 4)/)
+ end if
+
+! Check source array sections in both directions.
+
+ ch = "wxyz"
+ ch(1:2) = transfer (y(2:4:2), ch)
+ if (any (ch(1:2) .ne. (/"EFGH","MNOP"/))) call abort ()
+ ch = "wxyz"
+ ch(1:2) = transfer (y(4:2:-2), ch)
+ if (any (ch(1:2) .ne. (/"MNOP","EFGH"/))) call abort ()
+
+! Check that a complete array transfers with size absent.
+
+ ch = transfer (y, ch)
+ if (any (ch .ne. (/"ABCD","EFGH","IJKL","MNOP"/))) call abort ()
+
+! Check that a character array section is OK
+
+ z = transfer (ch(2:3), y)
+ if (any (z .ne. y(2:3))) call abort ()
+
+! Check dest array sections in both directions.
+
+ ch = "wxyz"
+ ch(3:4) = transfer (y, ch, 2)
+ if (any (ch(3:4) .ne. (/"ABCD","EFGH"/))) call abort ()
+ ch = "wxyz"
+ ch(3:2:-1) = transfer (y, ch, 2)
+ if (any (ch(2:3) .ne. (/"EFGH","ABCD"/))) call abort ()
+
+! Make sure that character to numeric is OK.
+
+ ch = "wxyz"
+ ch(1:2) = transfer (y, ch, 2)
+ if (any (ch(1:2) .ne. (/"ABCD","EFGH"/))) call abort ()
+
+ z = transfer (ch, y)
+ if (any (y(1:2) .ne. z)) call abort ()
+
+ end subroutine test2
+
+ subroutine test3 (ch1, ch2, ch3, clen)
+ integer clen
+ character(8) :: ch1(:)
+ character(*) :: ch2(2)
+ character(clen) :: ch3(2)
+ character(8) :: cntrl(2) = (/"lmnoPQRS","LMNOpqrs"/)
+ integer(8) :: ic(2)
+ ic = transfer (cntrl, ic)
+
+! Check assumed shape.
+
+ if (any (ic .ne. transfer (ch1, ic))) call abort ()
+
+! Check assumed character length.
+
+ if (any (ic .ne. transfer (ch2, ic))) call abort ()
+
+! Check automatic character length.
+
+ if (any (ic .ne. transfer (ch3, ic))) call abort ()
+
+ end subroutine test3
+
end
projects / platform / upstream / linaro-gcc.git / commitdiff