re PR fortran/38415 (procedure pointer assignment to abstract interface)

2008-12-06  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/38415
	* expr.c (gfc_check_pointer_assign): Added a check for abstract
	interfaces in procedure pointer assignments, removed check involving
	gfc_compare_interfaces until PR38290 is fixed completely.


2008-12-06  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/38415
	* gfortran.dg/proc_ptr_2.f90: Extended.
	* gfortran.dg/proc_ptr_11.f90: Modified.

From-SVN: r142520
This commit is contained in:
Janus Weil 2008-12-06 13:15:49 +01:00
parent 22493a73d5
commit fb7ca5a762
5 changed files with 34 additions and 2 deletions

View File

@ -1,3 +1,10 @@
2008-12-06 Janus Weil <janus@gcc.gnu.org>
PR fortran/38415
* expr.c (gfc_check_pointer_assign): Added a check for abstract
interfaces in procedure pointer assignments, removed check involving
gfc_compare_interfaces until PR38290 is fixed completely.
2008-12-05 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/38291

View File

@ -3125,6 +3125,13 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
&rvalue->where);
return FAILURE;
}
if (attr.abstract)
{
gfc_error ("Abstract interface '%s' is invalid "
"in procedure pointer assignment at %L",
rvalue->symtree->name, &rvalue->where);
}
/* TODO. See PR 38290.
if (rvalue->expr_type == EXPR_VARIABLE
&& lvalue->symtree->n.sym->attr.if_source != IFSRC_UNKNOWN
&& !gfc_compare_interfaces (lvalue->symtree->n.sym,
@ -3133,7 +3140,7 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
gfc_error ("Interfaces don't match "
"in procedure pointer assignment at %L", &rvalue->where);
return FAILURE;
}
}*/
return SUCCESS;
}

View File

@ -1,3 +1,9 @@
2008-12-06 Janus Weil <janus@gcc.gnu.org>
PR fortran/38415
* gfortran.dg/proc_ptr_2.f90: Extended.
* gfortran.dg/proc_ptr_11.f90: Modified.
2008-12-05 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/38291

View File

@ -14,8 +14,12 @@ program bsp
end interface
procedure( up ) , pointer :: pptr
procedure(isign), pointer :: q
pptr => add ! { dg-error "Interfaces don't match" }
! TODO. See PR 38290.
!pptr => add ! { "Interfaces don't match" }
q => add
print *, pptr() ! { dg-error "is not a function" }

View File

@ -8,10 +8,18 @@ PROCEDURE(REAL), POINTER :: ptr
PROCEDURE(REAL), SAVE :: noptr ! { dg-error "attribute conflicts with" }
REAL :: x
abstract interface
subroutine bar(a)
integer :: a
end subroutine bar
end interface
ptr => cos(4.0) ! { dg-error "Invalid procedure pointer assignment" }
ptr => x ! { dg-error "Invalid procedure pointer assignment" }
ptr => sin(x) ! { dg-error "Invalid procedure pointer assignment" }
ptr => bar ! { dg-error "is invalid in procedure pointer assignment" }
ALLOCATE(ptr) ! { dg-error "must be ALLOCATABLE" }
end