PR fortran/31215
* trans-expr.c (gfc_apply_interface_mapping_to_expr): Return
int result that is non-zero if the expression is the function
result. Only the characteristics of the result expression
can be used in a procedure interface, so simplify LEN in situ
using its character length.
PR fortran/31219
PR fortran/31200
* trans-expr.c (gfc_conv_function_call): Do not use
gfc_conv_expr_reference for actual pointer function with formal
target because a temporary is created that does not transfer
the reference correctly. Do not indirect formal pointer
functions since it is the function reference that is needed.
2007-03-24 Paul Thomas <pault@gcc.gnu.org>
PR fortran/31219
* gfortran.dg/pointer_function_actual_1.f90: New test.
PR fortran/31200
* gfortran.dg/pointer_function_actual_2.f90: New test.
PR fortran/31215
* gfortran.dg/result_in_spec_1.f90: New test.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@123183
138bc75d-0d04-0410-961f-
82ee72b054a4
+2007-03-24 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/31215
+ * trans-expr.c (gfc_apply_interface_mapping_to_expr): Return
+ int result that is non-zero if the expression is the function
+ result. Only the characteristics of the result expression
+ can be used in a procedure interface, so simplify LEN in situ
+ using its character length.
+
+ PR fortran/31219
+ PR fortran/31200
+ * trans-expr.c (gfc_conv_function_call): Do not use
+ gfc_conv_expr_reference for actual pointer function with formal
+ target because a temporary is created that does not transfer
+ the reference correctly. Do not indirect formal pointer
+ functions since it is the function reference that is needed.
+
2007-03-24 Brooks Moses <brooks.moses@codesourcery.com>
* gfortran.h: Edit comments on GFC_STD_*.
#include "dependency.h"
static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr);
-static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
+static int gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *,
gfc_expr *);
/* Copy the scalarization loop variables. */
dummy arguments that MAPPING maps to actual arguments. Replace each such
reference with a reference to the associated actual argument. */
-static void
+static int
gfc_apply_interface_mapping_to_expr (gfc_interface_mapping * mapping,
gfc_expr * expr)
{
gfc_interface_sym_mapping *sym;
gfc_actual_arglist *actual;
+ int seen_result = 0;
if (!expr)
- return;
+ return 0;
/* Copying an expression does not copy its length, so do that here. */
if (expr->ts.type == BT_CHARACTER && expr->ts.cl)
switch (expr->expr_type)
{
case EXPR_VARIABLE:
+ if (expr->symtree->n.sym->attr.result)
+ seen_result = 1;
case EXPR_CONSTANT:
case EXPR_NULL:
case EXPR_SUBSTRING:
break;
case EXPR_FUNCTION:
+ if (expr->value.function.actual->expr->expr_type == EXPR_VARIABLE
+ && gfc_apply_interface_mapping_to_expr (mapping,
+ expr->value.function.actual->expr)
+ && expr->value.function.esym == NULL
+ && expr->value.function.isym != NULL
+ && expr->value.function.isym->generic_id == GFC_ISYM_LEN)
+ {
+ gfc_expr *new_expr;
+ new_expr = gfc_copy_expr (expr->value.function.actual->expr->ts.cl->length);
+ *expr = *new_expr;
+ gfc_free (new_expr);
+ gfc_apply_interface_mapping_to_expr (mapping, expr);
+ break;
+ }
+
for (sym = mapping->syms; sym; sym = sym->next)
if (sym->old == expr->value.function.esym)
expr->value.function.esym = sym->new->n.sym;
gfc_apply_interface_mapping_to_cons (mapping, expr->value.constructor);
break;
}
+ return seen_result;
}
/* Argument list functions %VAL, %LOC and %REF are signalled
through arg->name. */
conv_arglist_function (&parmse, arg->expr, arg->name);
+ else if ((e->expr_type == EXPR_FUNCTION)
+ && e->symtree->n.sym->attr.pointer
+ && fsym && fsym->attr.target)
+ {
+ gfc_conv_expr (&parmse, e);
+ parmse.expr = build_fold_addr_expr (parmse.expr);
+ }
else
{
gfc_conv_expr_reference (&parmse, e);
if (fsym && fsym->attr.pointer
- && e->expr_type != EXPR_NULL)
+ && fsym->attr.flavor != FL_PROCEDURE
+ && e->expr_type != EXPR_NULL)
{
/* Scalar pointer dummy args require an extra level of
indirection. The null pointer already contains
+2007-03-24 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/31219
+ * gfortran.dg/pointer_function_actual_1.f90: New test.
+
+ PR fortran/31200
+ * gfortran.dg/pointer_function_actual_2.f90: New test.
+
+ PR fortran/31215
+ * gfortran.dg/result_in_spec_1.f90: New test.
+
2007-03-23 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
PR fortran/30834
--- /dev/null
+! { dg-do run }
+! Tests the fix for PR31219, in which an ICE would result because
+! the reference to the pointer function f would be indirected, as
+! if it were the result that is being passed.
+!
+! COntributed by Joost VandeVondele <jv244@cam.ac.uk>
+!
+FUNCTION F() RESULT(RES)
+ INTEGER, POINTER :: RES
+ ALLOCATE(RES)
+ RES=2
+END FUNCTION F
+
+SUBROUTINE S1(f,*,*)
+ INTERFACE
+ FUNCTION F() RESULT(RES)
+ INTEGER, POINTER :: RES
+ END FUNCTION F
+ END INTERFACE
+ RETURN F()
+END SUBROUTINE
+
+PROGRAM TEST
+ INTERFACE
+ FUNCTION F() RESULT(RES)
+ INTEGER, POINTER :: RES
+ END FUNCTION F
+ END INTERFACE
+
+
+ INTERFACE
+ SUBROUTINE S1(f,*,*)
+ INTERFACE
+ FUNCTION F() RESULT(RES)
+ INTEGER, POINTER :: RES
+ END FUNCTION F
+ END INTERFACE
+ END SUBROUTINE
+ END INTERFACE
+
+ CALL S1(F,*1,*2)
+
+ 1 CONTINUE
+ CALL ABORT()
+
+ GOTO 3
+ 2 CONTINUE
+
+ 3 CONTINUE
+END
+
--- /dev/null
+! { dg-do run }
+! Tests the fix for PR31200, in which the target x would
+! not be associated with p
+!
+! COntributed by Joost VandeVondele <jv244@cam.ac.uk>
+!
+ REAL,TARGET :: x
+ CALL s3(f(x))
+CONTAINS
+ FUNCTION f(a)
+ REAL,POINTER :: f
+ REAL,TARGET :: a
+ f => a
+ END FUNCTION
+ SUBROUTINE s3(targ)
+ REAL,TARGET :: targ
+ REAL,POINTER :: p
+ p => targ
+ IF (.NOT. ASSOCIATED(p,x)) CALL ABORT()
+ END SUBROUTINE
+END
+
--- /dev/null
+! { dg-do run }
+! Tests the check for PR31215, in which actual/formal interface
+! was not being correctly handled for the size of 'r' because
+! it is a result.
+!
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+!
+module test1
+ implicit none
+contains
+ character(f(x)) function test2(x) result(r)
+ implicit integer (x)
+ dimension r(len(r)+1)
+ integer, intent(in) :: x
+ interface
+ pure function f(x)
+ integer, intent(in) :: x
+ integer f
+ end function f
+ end interface
+ integer i
+ do i = 1, len(r)
+ r(:)(i:i) = achar(mod(i,32)+iachar('@'))
+ end do
+ end function test2
+end module test1
+
+program test
+ use test1
+ implicit none
+! Original problem
+ if (len(test2(10)) .ne. 21) call abort ()
+! Check non-intrinsic calls are OK and check that fix does
+! not confuse result variables.
+ if (any (myfunc (test2(1)) .ne. "ABC")) call abort ()
+contains
+ function myfunc (ch) result (chr)
+ character(len(ch)) :: chr(2)
+ character (*) :: ch(:)
+ if (len (ch) .ne. 3) call abort ()
+ if (any (ch .ne. "ABC")) call abort ()
+ chr = test2 (1)
+ if (len(test2(len(chr))) .ne. 7) call abort ()
+ end function myfunc
+end program test
+
+pure function f(x)
+ integer, intent(in) :: x
+ integer f
+ f = 2*x+1
+end function f
+! { dg-final { cleanup-modules "test1" } }
OSDN Git Service
