diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 4655ffe384a..589db075e1b 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2009-02-13 Paul Thomas + + PR fortran/36703 + PR fortran/36528 + * trans-expr.c (gfc_conv_function_val): Stabilize Cray-pointer + function references to ensure that a valid expression is used. + (gfc_conv_function_call): Pass Cray pointers to procedures. + 2009-02-03 Jakub Jelinek * gfortranspec.c (lang_specific_driver): Update copyright notice diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 5d41145df06..f0434b2b58a 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1505,9 +1505,17 @@ gfc_conv_function_val (gfc_se * se, gfc_symbol * sym) sym->backend_decl = gfc_get_extern_function_decl (sym); tmp = sym->backend_decl; + if (sym->attr.cray_pointee) - tmp = convert (build_pointer_type (TREE_TYPE (tmp)), - gfc_get_symbol_decl (sym->cp_pointer)); + { + /* TODO - make the cray pointee a pointer to a procedure, + assign the pointer to it and use it for the call. This + will do for now! */ + tmp = convert (build_pointer_type (TREE_TYPE (tmp)), + gfc_get_symbol_decl (sym->cp_pointer)); + tmp = gfc_evaluate_now (tmp, &se->pre); + } + if (!POINTER_TYPE_P (TREE_TYPE (tmp))) { gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL); @@ -2623,7 +2631,18 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym, if (argss == gfc_ss_terminator) { - if (fsym && fsym->attr.value) + if (e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.cray_pointee + && fsym && fsym->attr.flavor == FL_PROCEDURE) + { + /* The Cray pointer needs to be converted to a pointer to + a type given by the expression. */ + gfc_conv_expr (&parmse, e); + type = build_pointer_type (TREE_TYPE (parmse.expr)); + tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer); + parmse.expr = convert (type, tmp); + } + else if (fsym && fsym->attr.value) { if (fsym->ts.type == BT_CHARACTER && fsym->ts.is_c_interop diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index d3f7ed7f841..a0f16507404 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2009-02-13 Paul Thomas + + PR fortran/36528 + * gfortran.dg/cray_pointers_8.f90: New test. + + PR fortran/36703 + * gfortran.dg/cray_pointers_9.f90: New test. + 2009-02-13 Jason Merrill PR c++/39070 diff --git a/gcc/testsuite/gfortran.dg/cray_pointers_8.f90 b/gcc/testsuite/gfortran.dg/cray_pointers_8.f90 new file mode 100644 index 00000000000..887c9625ac7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/cray_pointers_8.f90 @@ -0,0 +1,63 @@ +! { dg-do run } +! { dg-options "-fcray-pointer" } +! +! Test the fix for PR36528 in which the Cray pointer was not passed +! correctly to 'euler' so that an undefined reference to fcn was +! generated by the linker. +! +! Reported by Tobias Burnus +! from http://groups.google.com/group/comp.lang.fortran/msg/86b65bad78e6af78 +! +real function p1(x) + real, intent(in) :: x + p1 = x +end + +real function euler(xp,xk,dx,f) + real, intent(in) :: xp, xk, dx + interface + real function f(x) + real, intent(in) :: x + end function + end interface + real x, y + y = 0.0 + x = xp + do while (x .le. xk) + y = y + f(x)*dx + x = x + dx + end do + euler = y +end +program main + interface + real function p1 (x) + real, intent(in) :: x + end function + real function fcn (x) + real, intent(in) :: x + end function + real function euler (xp,xk,dx,f) + real, intent(in) :: xp, xk ,dx + interface + real function f(x) + real, intent(in) :: x + end function + end interface + end function + end interface + real x, xp, xk, dx, y, z + pointer (pfcn, fcn) + pfcn = loc(p1) + xp = 0.0 + xk = 1.0 + dx = 0.0005 + y = 0.0 + x = xp + do while (x .le. xk) + y = y + fcn(x)*dx + x = x + dx + end do + z = euler(0.0,1.0,0.0005,fcn) + if (abs (y - z) .gt. 1e-6) call abort +end diff --git a/gcc/testsuite/gfortran.dg/cray_pointers_9.f90 b/gcc/testsuite/gfortran.dg/cray_pointers_9.f90 new file mode 100644 index 00000000000..81bcb199a1e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/cray_pointers_9.f90 @@ -0,0 +1,104 @@ +! { dg-do compile } +! { dg-options "-fcray-pointer" } +! +! Test the fix for PR36703 in which the Cray pointer was not passed +! correctly so that the call to 'fun' at line 102 caused an ICE. +! +! Contributed by James van Buskirk on com.lang.fortran +! http://groups.google.com/group/comp.lang.fortran/msg/b600c081a3654936 +! Reported by Tobias Burnus +! +module funcs + use ISO_C_BINDING ! Added this USE statement + implicit none +! Interface block for function program fptr will invoke +! to get the C_FUNPTR + interface + function get_proc(mess) bind(C,name='BlAh') + use ISO_C_BINDING + implicit none + character(kind=C_CHAR) mess(*) + type(C_FUNPTR) get_proc + end function get_proc + end interface +end module funcs + +module other_fun + use ISO_C_BINDING + implicit none + private +! Message to be returned by procedure pointed to +! by the C_FUNPTR + character, allocatable, save :: my_message(:) +! Interface block for the procedure pointed to +! by the C_FUNPTR + public abstract_fun + abstract interface + function abstract_fun(x) + use ISO_C_BINDING + import my_message + implicit none + integer(C_INT) x(:) + character(size(my_message),C_CHAR) abstract_fun(size(x)) + end function abstract_fun + end interface + contains +! Procedure to store the message and get the C_FUNPTR + function gp(message) bind(C,name='BlAh') + character(kind=C_CHAR) message(*) + type(C_FUNPTR) gp + integer(C_INT64_T) i + + i = 1 + do while(message(i) /= C_NULL_CHAR) + i = i+1 + end do + allocate (my_message(i+1)) ! Added this allocation + my_message = message(int(1,kind(i)):i-1) + gp = get_funloc(make_mess,aux) + end function gp + +! Intermediate procedure to pass the function and get +! back the C_FUNPTR + function get_funloc(x,y) + procedure(abstract_fun) x + type(C_FUNPTR) y + external y + type(C_FUNPTR) get_funloc + + get_funloc = y(x) + end function get_funloc + +! Procedure to convert the function to C_FUNPTR + function aux(x) + interface + subroutine x() bind(C) + end subroutine x + end interface + type(C_FUNPTR) aux + + aux = C_FUNLOC(x) + end function aux + +! Procedure pointed to by the C_FUNPTR + function make_mess(x) + integer(C_INT) x(:) + character(size(my_message),C_CHAR) make_mess(size(x)) + + make_mess = transfer(my_message,make_mess(1)) + end function make_mess +end module other_fun + +program fptr + use funcs + use other_fun + implicit none + procedure(abstract_fun) fun ! Removed INTERFACE + pointer(p,fun) + type(C_FUNPTR) fp + + fp = get_proc('Hello, world'//achar(0)) + p = transfer(fp,p) + write(*,'(a)') fun([1,2,3]) +end program fptr +! { dg-final { cleanup-modules "funcs other_fun" } }