+2008-07-02 Janus Weil <janus@gcc.gnu.org>
+ Tobias Burnus <burnus@net-b.de>
+ Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/32580
+ * gfortran.h (struct gfc_symbol): New member "proc_pointer".
+ * check.c (gfc_check_associated,gfc_check_null): Implement
+ procedure pointers.
+ * decl.c (match_procedure_decl): Ditto.
+ * expr.c (gfc_check_pointer_assign,gfc_check_assign_symbol): Ditto.
+ * interface.c (compare_actual_formal): Ditto.
+ * match.h: Ditto.
+ * match.c (gfc_match_pointer_assignment): Ditto.
+ * parse.c (parse_interface): Ditto.
+ * primary.c (gfc_match_rvalue,match_variable): Ditto.
+ * resolve.c (resolve_fl_procedure): Ditto.
+ * symbol.c (check_conflict,gfc_add_external,gfc_add_pointer,
+ gfc_copy_attr,gen_fptr_param,build_formal_args): Ditto.
+ * trans-decl.c (get_proc_pointer_decl,gfc_get_extern_function_decl,
+ create_function_arglist): Ditto.
+ * trans-expr.c (gfc_conv_variable,gfc_conv_function_val,
+ gfc_conv_function_call,gfc_trans_pointer_assignment): Ditto.
+
2008-07-02 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/36590
try
gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
{
- symbol_attribute attr;
+ symbol_attribute attr1, attr2;
int i;
try t;
locus *where;
where = &pointer->where;
if (pointer->expr_type == EXPR_VARIABLE)
- attr = gfc_variable_attr (pointer, NULL);
+ attr1 = gfc_variable_attr (pointer, NULL);
else if (pointer->expr_type == EXPR_FUNCTION)
- attr = pointer->symtree->n.sym->attr;
+ attr1 = pointer->symtree->n.sym->attr;
else if (pointer->expr_type == EXPR_NULL)
goto null_arg;
else
gcc_assert (0); /* Pointer must be a variable or a function. */
- if (!attr.pointer)
+ if (!attr1.pointer && !attr1.proc_pointer)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
gfc_current_intrinsic_arg[0], gfc_current_intrinsic,
goto null_arg;
if (target->expr_type == EXPR_VARIABLE)
- attr = gfc_variable_attr (target, NULL);
+ attr2 = gfc_variable_attr (target, NULL);
else if (target->expr_type == EXPR_FUNCTION)
- attr = target->symtree->n.sym->attr;
+ attr2 = target->symtree->n.sym->attr;
else
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer "
return FAILURE;
}
- if (!attr.pointer && !attr.target)
+ if (attr1.pointer && !attr2.pointer && !attr2.target)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER "
"or a TARGET", gfc_current_intrinsic_arg[1],
attr = gfc_variable_attr (mold, NULL);
- if (!attr.pointer)
+ if (!attr.pointer && !attr.proc_pointer)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L must be a POINTER",
gfc_current_intrinsic_arg[0],
locus old_loc, entry_loc;
gfc_symbol *sym, *proc_if = NULL;
int num;
+ gfc_expr *initializer = NULL;
old_loc = entry_loc = gfc_current_locus;
return MATCH_ERROR;
}
- if (!sym->attr.pointer && gfc_add_external (&sym->attr, NULL) == FAILURE)
+ if (gfc_add_external (&sym->attr, NULL) == FAILURE)
return MATCH_ERROR;
if (gfc_add_proc (&sym->attr, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
sym->attr.function = sym->ts.interface->attr.function;
}
+ if (gfc_match (" =>") == MATCH_YES)
+ {
+ if (!current_attr.pointer)
+ {
+ gfc_error ("Initialization at %C isn't for a pointer variable");
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
+ m = gfc_match_null (&initializer);
+ if (m == MATCH_NO)
+ {
+ gfc_error ("Pointer initialization requires a NULL() at %C");
+ m = MATCH_ERROR;
+ }
+
+ if (gfc_pure (NULL))
+ {
+ gfc_error ("Initialization of pointer at %C is not allowed in "
+ "a PURE procedure");
+ m = MATCH_ERROR;
+ }
+
+ if (m != MATCH_YES)
+ goto cleanup;
+
+ if (add_init_expr_to_sym (sym->name, &initializer, &gfc_current_locus)
+ != SUCCESS)
+ goto cleanup;
+
+ }
+
+ gfc_set_sym_referenced (sym);
+
if (gfc_match_eos () == MATCH_YES)
return MATCH_YES;
if (gfc_match_char (',') != MATCH_YES)
syntax:
gfc_error ("Syntax error in PROCEDURE statement at %C");
return MATCH_ERROR;
+
+cleanup:
+ /* Free stuff up and return. */
+ gfc_free_expr (initializer);
+ return m;
}
int is_pure;
int pointer, check_intent_in;
- if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN)
+ if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
+ && !lvalue->symtree->n.sym->attr.proc_pointer)
{
gfc_error ("Pointer assignment target is not a POINTER at %L",
&lvalue->where);
/* Check INTENT(IN), unless the object itself is the component or
sub-component of a pointer. */
check_intent_in = 1;
- pointer = lvalue->symtree->n.sym->attr.pointer;
+ pointer = lvalue->symtree->n.sym->attr.pointer
+ | lvalue->symtree->n.sym->attr.proc_pointer;
for (ref = lvalue->ref; ref; ref = ref->next)
{
if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
return SUCCESS;
+ /* TODO checks on rvalue for a procedure pointer assignment. */
+ if (lvalue->symtree->n.sym->attr.proc_pointer)
+ return SUCCESS;
+
if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
{
gfc_error ("Different types in pointer assignment at %L; attempted "
lvalue.symtree->n.sym = sym;
lvalue.where = sym->declared_at;
- if (sym->attr.pointer)
+ if (sym->attr.pointer || sym->attr.proc_pointer)
r = gfc_check_pointer_assign (&lvalue, rvalue);
else
r = gfc_check_assign (&lvalue, rvalue, 1);
unsigned allocatable:1, dimension:1, external:1, intrinsic:1,
optional:1, pointer:1, target:1, value:1, volatile_:1,
dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1,
- implied_index:1, subref_array_pointer:1;
+ implied_index:1, subref_array_pointer:1, proc_pointer:1;
ENUM_BITFIELD (save_state) save:2;
return 0;
}
+ /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
+ is provided for a procedure pointer formal argument. */
+ if (f->sym->attr.proc_pointer
+ && !a->expr->symtree->n.sym->attr.proc_pointer)
+ {
+ if (where)
+ gfc_error ("Expected a procedure pointer for argument '%s' at %L",
+ f->sym->name, &a->expr->where);
+ return 0;
+ }
+
/* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
provided for a procedure formal argument. */
if (a->expr->ts.type != BT_PROCEDURE
#include "match.h"
#include "parse.h"
+int gfc_matching_procptr_assignment = 0;
/* For debugging and diagnostic purposes. Return the textual representation
of the intrinsic operator OP. */
old_loc = gfc_current_locus;
lvalue = rvalue = NULL;
+ gfc_matching_procptr_assignment = 0;
m = gfc_match (" %v =>", &lvalue);
if (m != MATCH_YES)
goto cleanup;
}
+ if (lvalue->symtree->n.sym->attr.proc_pointer)
+ gfc_matching_procptr_assignment = 1;
+
m = gfc_match (" %e%t", &rvalue);
+ gfc_matching_procptr_assignment = 0;
if (m != MATCH_YES)
goto cleanup;
separate. */
extern gfc_st_label *gfc_statement_label;
+extern int gfc_matching_procptr_assignment;
+
/****************** All gfc_match* routines *****************/
/* match.c. */
new_state = COMP_SUBROUTINE;
else if (st == ST_FUNCTION)
new_state = COMP_FUNCTION;
+ if (gfc_new_block->attr.pointer)
+ {
+ gfc_new_block->attr.pointer = 0;
+ gfc_new_block->attr.proc_pointer = 1;
+ }
if (gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
gfc_new_block->formal, NULL) == FAILURE)
{
}
}
+ if (gfc_matching_procptr_assignment)
+ goto procptr0;
+
if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
goto function0;
/* If we're here, then the name is known to be the name of a
procedure, yet it is not sure to be the name of a function. */
case FL_PROCEDURE:
+
+ /* Procedure Pointer Assignments. */
+ procptr0:
+ if (gfc_matching_procptr_assignment)
+ {
+ gfc_gobble_whitespace ();
+ if (sym->attr.function && gfc_peek_ascii_char () == '(')
+ /* Parse functions returning a procptr. */
+ goto function0;
+
+ if (sym->attr.flavor == FL_UNKNOWN) sym->attr.flavor = FL_PROCEDURE;
+ if (gfc_intrinsic_name (sym->name, 0)
+ || gfc_intrinsic_name (sym->name, 1))
+ sym->attr.intrinsic = 1;
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_VARIABLE;
+ e->symtree = symtree;
+ m = match_varspec (e, 0);
+ break;
+ }
+
if (sym->attr.subroutine)
{
gfc_error ("Unexpected use of subroutine name '%s' at %C",
break;
}
+ if (sym->attr.proc_pointer)
+ break;
+
/* Fall through to error */
default:
}
}
- if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION)
+ if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION
+ && !sym->attr.proc_pointer)
{
gfc_error ("Function '%s' at %L cannot have an initializer",
sym->name, &sym->declared_at);
}
/* An external symbol may not have an initializer because it is taken to be
- a procedure. */
- if (sym->attr.external && sym->value)
+ a procedure. Exception: Procedure Pointers. */
+ if (sym->attr.external && sym->value && !sym->attr.proc_pointer)
{
gfc_error ("External object '%s' at %L may not have an initializer",
sym->name, &sym->declared_at);
case FL_BLOCK_DATA:
case FL_MODULE:
case FL_LABEL:
- case FL_PROCEDURE:
case FL_DERIVED:
case FL_PARAMETER:
a1 = gfc_code2string (flavors, attr->flavor);
a2 = save;
goto conflict;
+ case FL_PROCEDURE:
+ if (attr->proc_pointer)
+ break;
+ a1 = gfc_code2string (flavors, attr->flavor);
+ a2 = save;
+ goto conflict;
+
case FL_VARIABLE:
case FL_NAMELIST:
default:
conf (procedure, value)
conf (procedure, volatile_)
conf (procedure, entry)
- /* TODO: Implement procedure pointers. */
- if (attr->procedure && attr->pointer)
- {
- gfc_error ("Fortran 2003: Procedure pointers at %L are "
- "not yet implemented in gfortran", where);
- return FAILURE;
- }
a1 = gfc_code2string (flavors, attr->flavor);
break;
case FL_PROCEDURE:
- conf2 (intent);
+ if (!attr->proc_pointer)
+ conf2 (intent);
if (attr->subroutine)
{
- conf2 (pointer);
conf2 (target);
conf2 (allocatable);
conf2 (result);
return FAILURE;
}
+ if (attr->pointer && attr->if_source != IFSRC_IFBODY)
+ {
+ attr->pointer = 0;
+ attr->proc_pointer = 1;
+ }
+
attr->external = 1;
return check_conflict (attr, NULL, where);
if (check_used (attr, NULL, where))
return FAILURE;
- attr->pointer = 1;
+ if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
+ && gfc_find_state (COMP_INTERFACE) == FAILURE))
+ {
+ duplicate_attr ("POINTER", where);
+ return FAILURE;
+ }
+
+ if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
+ || (attr->if_source == IFSRC_IFBODY
+ && gfc_find_state (COMP_INTERFACE) == FAILURE))
+ attr->proc_pointer = 1;
+ else
+ attr->pointer = 1;
+
return check_conflict (attr, NULL, where);
}
goto fail;
if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
goto fail;
+ if (src->proc_pointer)
+ dest->proc_pointer = 1;
return SUCCESS;
gen_fptr_param (gfc_formal_arglist **head,
gfc_formal_arglist **tail,
const char *module_name,
- gfc_namespace *ns, const char *f_ptr_name)
+ gfc_namespace *ns, const char *f_ptr_name, int proc)
{
gfc_symbol *param_sym = NULL;
gfc_symtree *param_symtree = NULL;
/* Set up the necessary fields for the fptr output param sym. */
param_sym->refs++;
- param_sym->attr.pointer = 1;
+ if (proc)
+ param_sym->attr.proc_pointer = 1;
+ else
+ param_sym->attr.pointer = 1;
param_sym->attr.dummy = 1;
param_sym->attr.use_assoc = 1;
gfc_current_ns->proc_name = new_proc_sym;
/* Generate the params. */
- if ((old_sym->intmod_sym_id == ISOCBINDING_F_POINTER) ||
- (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER))
+ if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
{
gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
gfc_current_ns, "cptr", old_sym->intmod_sym_id);
gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
- gfc_current_ns, "fptr");
-
+ gfc_current_ns, "fptr", 1);
+ }
+ else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
+ {
+ gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module,
+ gfc_current_ns, "cptr", old_sym->intmod_sym_id);
+ gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module,
+ gfc_current_ns, "fptr", 0);
/* If we're dealing with c_f_pointer, it has an optional third arg. */
- if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER)
- {
- gen_shape_param (&head, &tail,
- (const char *) new_proc_sym->module,
- gfc_current_ns, "shape");
- }
+ gen_shape_param (&head, &tail,(const char *) new_proc_sym->module,
+ gfc_current_ns, "shape");
+
}
else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
{
}
+/* Declare a procedure pointer. */
+
+static tree
+get_proc_pointer_decl (gfc_symbol *sym)
+{
+ tree decl;
+
+ decl = sym->backend_decl;
+ if (decl)
+ return decl;
+
+ decl = build_decl (VAR_DECL, get_identifier (sym->name),
+ build_pointer_type (gfc_get_function_type (sym)));
+
+ if (sym->ns->proc_name->backend_decl == current_function_decl
+ || sym->attr.contained)
+ gfc_add_decl_to_function (decl);
+ else
+ gfc_add_decl_to_parent_function (decl);
+
+ sym->backend_decl = decl;
+
+ if (!sym->attr.use_assoc
+ && (sym->attr.save != SAVE_NONE || sym->attr.data
+ || (sym->value && sym->ns->proc_name->attr.is_main_program)))
+ TREE_STATIC (decl) = 1;
+
+ if (TREE_STATIC (decl) && sym->value)
+ {
+ /* Add static initializer. */
+ DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
+ TREE_TYPE (decl), sym->attr.dimension, sym->attr.proc_pointer);
+ }
+
+ return decl;
+}
+
+
/* Get a basic decl for an external function. */
tree
to know that. */
gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
+ if (sym->attr.proc_pointer)
+ return get_proc_pointer_decl (sym);
+
if (sym->attr.intrinsic)
{
/* Call the resolution function to get the actual name. This is
type = gfc_sym_type (f->sym);
}
+ if (f->sym->attr.proc_pointer)
+ type = build_pointer_type (type);
+
/* Build a the argument declaration. */
parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
else if (sym->attr.flavor == FL_PROCEDURE
&& se->expr != current_function_decl)
{
- gcc_assert (se->want_pointer);
- if (!sym->attr.dummy)
+ if (!sym->attr.dummy && !sym->attr.proc_pointer)
{
gcc_assert (TREE_CODE (se->expr) == FUNCTION_DECL);
se->expr = build_fold_addr_expr (se->expr);
if (sym->attr.dummy)
{
tmp = gfc_get_symbol_decl (sym);
+ if (sym->attr.proc_pointer)
+ tmp = build_fold_indirect_ref (tmp);
gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == POINTER_TYPE
&& TREE_CODE (TREE_TYPE (TREE_TYPE (tmp))) == FUNCTION_TYPE);
}
else
{
gfc_conv_expr_reference (&parmse, e);
- if (fsym && fsym->attr.pointer
- && fsym->attr.flavor != FL_PROCEDURE
- && e->expr_type != EXPR_NULL)
+ if (fsym && e->expr_type != EXPR_NULL
+ && ((fsym->attr.pointer
+ && fsym->attr.flavor != FL_PROCEDURE)
+ || fsym->attr.proc_pointer))
{
/* Scalar pointer dummy args require an extra level of
indirection. The null pointer already contains
gfc_init_se (&rse, NULL);
rse.want_pointer = 1;
gfc_conv_expr (&rse, expr2);
+
+ if (expr1->symtree->n.sym->attr.proc_pointer
+ && expr1->symtree->n.sym->attr.dummy)
+ lse.expr = build_fold_indirect_ref (lse.expr);
+
gfc_add_block_to_block (&block, &lse.pre);
gfc_add_block_to_block (&block, &rse.pre);
gfc_add_modify_expr (&block, lse.expr,
+2008-07-02 Janus Weil <janus@gcc.gnu.org>
+ Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/32580
+ * gfortran.dg/c_f_pointer_tests_3.f90: Updated.
+ * gfortran.dg/proc_decl_1.f90: Updated.
+ * gfortran.dg/proc_ptr_1.f90: New.
+ * gfortran.dg/proc_ptr_2.f90: New.
+ * gfortran.dg/proc_ptr_3.f90: New.
+ * gfortran.dg/proc_ptr_4.f90: New.
+ * gfortran.dg/proc_ptr_5.f90: New.
+ * gfortran.dg/proc_ptr_6.f90: New.
+ * gfortran.dg/proc_ptr_7.f90: New.
+ * gfortran.dg/proc_ptr_8.f90: New.
+
2008-07-02 Joseph Myers <joseph@codesourcery.com>
* gcc.target/arm/neon/polytypes.c: Use dg-message separately from
type(c_funptr) :: cfunptr
integer(4), pointer :: fptr
integer(4), pointer :: fptr_array(:)
-! procedure(integer(4)), pointer :: fprocptr ! TODO
+ procedure(integer(4)), pointer :: fprocptr
call c_f_pointer(cptr, fptr)
call c_f_pointer(cptr, fptr_array, [ 1 ])
-! call c_f_procpointer(cfunptr, fprocptr) ! TODO
+ call c_f_procpointer(cfunptr, fprocptr)
end program test
! Make sure there is only a single function call:
! { dg-final { scan-tree-dump-times " fptr = .integer.kind=4. .. cptr" 1 "original" } }
!
! Check c_f_procpointer
-! TODO { scan-tree-dump-times " fprocptr = .integer.kind=4. .\\*<.*>. .void.. cfunptr;" 1 "original" } } TODO
+! { dg-final { scan-tree-dump-times " fprocptr = .integer.kind=4. .\\*<.*>. .void.. cfunptr;" 1 "original" } }
!
! { dg-final { cleanup-tree-dump "original" } }
procedure(dcos) :: my1
procedure(amax0) :: my2 ! { dg-error "not allowed in PROCEDURE statement" }
- procedure(),pointer:: ptr ! { dg-error "not yet implemented" }
-
type t
procedure(),pointer:: p ! { dg-error "not yet implemented" }
end type
--- /dev/null
+! { dg-do run }
+!
+! basic tests of PROCEDURE POINTERS
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+module m
+contains
+ subroutine proc1(arg)
+ character (5) :: arg
+ arg = "proc1"
+ end subroutine
+ integer function proc2(arg)
+ integer, intent(in) :: arg
+ proc2 = arg**2
+ end function
+ complex function proc3(re, im)
+ real, intent(in) :: re, im
+ proc3 = complex (re, im)
+ end function
+end module
+
+subroutine foo1
+end subroutine
+
+real function foo2()
+ foo2=6.3
+end function
+
+program procPtrTest
+ use m, only: proc1, proc2, proc3
+ character (5) :: str
+ PROCEDURE(proc1), POINTER :: ptr1
+ PROCEDURE(proc2), POINTER :: ptr2
+ PROCEDURE(proc3), POINTER :: ptr3 => NULL()
+ PROCEDURE(REAL), SAVE, POINTER :: ptr4
+ PROCEDURE(), POINTER :: ptr5,ptr6
+
+ EXTERNAL :: foo1,foo2
+ real :: foo2
+
+ if(ASSOCIATED(ptr3)) call abort()
+
+ NULLIFY(ptr1)
+ if (ASSOCIATED(ptr1)) call abort()
+ ptr1 => proc1
+ if (.not. ASSOCIATED(ptr1)) call abort()
+ call ptr1 (str)
+ if (str .ne. "proc1") call abort ()
+
+ ptr2 => NULL()
+ if (ASSOCIATED(ptr2)) call abort()
+ ptr2 => proc2
+ if (.not. ASSOCIATED(ptr2,proc2)) call abort()
+ if (10*ptr2 (10) .ne. 1000) call abort ()
+
+ ptr3 => NULL (ptr3)
+ if (ASSOCIATED(ptr3)) call abort()
+ ptr3 => proc3
+ if (ptr3 (1.0, 2.0) .ne. (1.0, 2.0)) call abort ()
+
+ ptr4 => cos
+ if (ptr4(0.0)/=1.0) call abort()
+
+ ptr5 => foo1
+ call ptr5()
+
+ ptr6 => foo2
+ if (ptr6()/=6.3) call abort()
+
+end program
+
+! { dg-final { cleanup-modules "m" } }
--- /dev/null
+! { dg-do compile }
+!
+! checking invalid code for PROCEDURE POINTERS
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+PROCEDURE(REAL), POINTER :: ptr
+PROCEDURE(REAL), SAVE :: noptr ! { dg-error "attribute conflicts with" }
+
+ptr => cos(4.0) ! { dg-error "Invalid character" }
+
+ALLOCATE(ptr) ! { dg-error "must be ALLOCATABLE" }
+
+end
--- /dev/null
+! { dg-do run }
+!
+! PROCEDURE POINTERS without the PROCEDURE statement
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+real function e1(x)
+ real :: x
+ print *,'e1!',x
+ e1 = x * 3.0
+end function
+
+subroutine e2(a,b)
+ real, intent(inout) :: a
+ real, intent(in) :: b
+ print *,'e2!',a,b
+ a = a + b
+end subroutine
+
+program proc_ptr_3
+
+real, external, pointer :: fp
+
+pointer :: sp
+interface
+ subroutine sp(a,b)
+ real, intent(inout) :: a
+ real, intent(in) :: b
+ end subroutine sp
+end interface
+
+external :: e1,e2
+real :: c = 1.2
+
+fp => e1
+
+if (abs(fp(2.5)-7.5)>0.01) call abort()
+
+sp => e2
+
+call sp(c,3.4)
+
+if (abs(c-4.6)>0.01) call abort()
+
+end
--- /dev/null
+! { dg-do compile }
+!
+! PROCEDURE POINTERS & pointer-valued functions
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+interface
+ integer function f1()
+ end function
+end interface
+
+interface
+ function f2()
+ integer, pointer :: f2
+ end function
+end interface
+
+interface
+ function pp1()
+ integer :: pp1
+ end function
+end interface
+pointer :: pp1
+
+pointer :: pp2
+interface
+ function pp2()
+ integer :: pp2
+ end function
+end interface
+
+pointer :: pp3
+interface
+ function pp3()
+ integer, pointer :: pp3
+ end function
+end interface
+
+interface
+ function pp4()
+ integer, pointer :: pp4
+ end function
+end interface
+pointer :: pp4
+
+
+pp1 => f1
+
+pp2 => pp1
+
+f2 => f1 ! { dg-error "is not a variable" }
+
+pp3 => f2
+
+pp4 => pp3
+
+end
\ No newline at end of file
--- /dev/null
+! { dg-do run }
+!
+! NULL() initialization for PROCEDURE POINTERS
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+program main
+implicit none
+call test(.true.)
+call test(.false.)
+
+contains
+
+integer function hello()
+ hello = 42
+end function hello
+
+subroutine test(first)
+ logical :: first
+ integer :: i
+ procedure(integer), pointer :: x => null()
+
+ if(first) then
+ if(associated(x)) call abort()
+ x => hello
+ else
+ if(.not. associated(x)) call abort()
+ i = x()
+ if(i /= 42) call abort()
+ end if
+ end subroutine test
+
+end program main
--- /dev/null
+! { dg-do run }
+!
+! PROCEDURE POINTERS as actual/formal arguments
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+subroutine foo(j)
+ INTEGER, INTENT(OUT) :: j
+ j = 6
+end subroutine
+
+program proc_ptr_6
+
+PROCEDURE(),POINTER :: ptr1
+PROCEDURE(REAL),POINTER :: ptr2
+EXTERNAL foo
+INTEGER :: k = 0
+
+ptr1 => foo
+call s_in(ptr1,k)
+if (k /= 6) call abort()
+
+call s_out(ptr2)
+if (ptr2(-3.0) /= 3.0) call abort()
+
+contains
+
+subroutine s_in(p,i)
+ PROCEDURE(),POINTER,INTENT(IN) :: p
+ INTEGER, INTENT(OUT) :: i
+ call p(i)
+end subroutine
+
+subroutine s_out(p)
+ PROCEDURE(REAL),POINTER,INTENT(OUT) :: p
+ p => abs
+end subroutine
+
+end program
--- /dev/null
+/* Procedure pointer test. Used by proc_ptr_7.f90.
+ PR fortran/32580. */
+
+int f(void) {
+ return 42;
+}
+
+void assignf_(int(**ptr)(void)) {
+ *ptr = f;
+}
--- /dev/null
+! { dg-do run }
+! { dg-additional-sources proc_ptr_7.c }
+!
+! PR fortran/32580
+! Procedure pointer test
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+program proc_pointer_test
+ use iso_c_binding, only: c_int
+ implicit none
+
+ interface
+ subroutine assignF(f)
+ import c_int
+ procedure(Integer(c_int)), pointer :: f
+ end subroutine
+ end interface
+
+ procedure(Integer(c_int)), pointer :: ptr
+
+ call assignF(ptr)
+ if(ptr() /= 42) call abort()
+
+ ptr => f55
+ if(ptr() /= 55) call abort()
+
+ call foo(ptr)
+ if(ptr() /= 65) call abort()
+
+contains
+
+ subroutine foo(a)
+ procedure(integer(c_int)), pointer :: a
+ if(a() /= 55) call abort()
+ a => f65
+ if(a() /= 65) call abort()
+ end subroutine foo
+
+ integer(c_int) function f55()
+ f55 = 55
+ end function f55
+
+ integer(c_int) function f65()
+ f65 = 65
+ end function f65
+end program proc_pointer_test
--- /dev/null
+/* Used by proc_ptr_8.f90.
+ PR fortran/32580. */
+
+int (*funpointer)(int);
+
+int f(int t)
+{
+ return t*3;
+}
+
+void init()
+{
+ funpointer=f;
+}
--- /dev/null
+! { dg-do run }
+! { dg-additional-sources proc_ptr_8.c }
+!
+! PR fortran/32580
+! Original test case
+!
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+
+MODULE X
+
+ USE ISO_C_BINDING
+ INTERFACE
+ INTEGER(KIND=C_INT) FUNCTION mytype( a ) BIND(C)
+ USE ISO_C_BINDING
+ INTEGER(KIND=C_INT), VALUE :: a
+ END FUNCTION
+ SUBROUTINE init() BIND(C,name="init")
+ END SUBROUTINE
+ END INTERFACE
+
+ TYPE(C_FUNPTR), BIND(C,name="funpointer") :: funpointer
+
+END MODULE X
+
+USE X
+PROCEDURE(mytype), POINTER :: ptype
+
+CALL init()
+CALL C_F_PROCPOINTER(funpointer,ptype)
+if (ptype(3) /= 9) call abort()
+
+END
+
+! { dg-final { cleanup-modules "X" } }
projects / gcc.git / commitdiff