Commit f18075ff by Tobias Burnus Committed by Tobias Burnus

re PR fortran/52270 ([OOP] Polymorphic vars: wrong intent(in) check, passing…

re PR fortran/52270 ([OOP] Polymorphic vars: wrong intent(in) check, passing nonptr variable to intent(in) ptr dummy)

2012-03-02  Tobias Burnus  <burnus@net-b.de>

        PR fortran/52270
        * expr.c (gfc_check_vardef_context): Fix check for
        intent-in polymorphic pointer .
        * interface.c (compare_parameter): Allow passing TYPE to
        intent-in polymorphic pointer.

2012-03-02  Tobias Burnus  <burnus@net-b.de>

        PR fortran/52270
        * gfortran.dg/class_51.f90: New.

From-SVN: r184784
parent 2d68f67f
2012-03-02 Tobias Burnus <burnus@net-b.de> 2012-03-02 Tobias Burnus <burnus@net-b.de>
PR fortran/52270
* expr.c (gfc_check_vardef_context): Fix check for
intent-in polymorphic pointer .
* interface.c (compare_parameter): Allow passing TYPE to
intent-in polymorphic pointer.
2012-03-02 Tobias Burnus <burnus@net-b.de>
PR fortran/52452 PR fortran/52452
* resolve.c (resolve_intrinsic): Don't search for a * resolve.c (resolve_intrinsic): Don't search for a
function if we know that it is a subroutine. function if we know that it is a subroutine.
......
...@@ -4648,7 +4648,8 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, ...@@ -4648,7 +4648,8 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
the component of sub-component of a pointer. Obviously, the component of sub-component of a pointer. Obviously,
procedure pointers are of no interest here. */ procedure pointers are of no interest here. */
check_intentin = true; check_intentin = true;
ptr_component = sym->attr.pointer; ptr_component = (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer;
for (ref = e->ref; ref && check_intentin; ref = ref->next) for (ref = e->ref; ref && check_intentin; ref = ref->next)
{ {
if (ptr_component && ref->type == REF_COMPONENT) if (ptr_component && ref->type == REF_COMPONENT)
......
...@@ -1579,7 +1579,9 @@ compare_pointer (gfc_symbol *formal, gfc_expr *actual) ...@@ -1579,7 +1579,9 @@ compare_pointer (gfc_symbol *formal, gfc_expr *actual)
{ {
symbol_attribute attr; symbol_attribute attr;
if (formal->attr.pointer) if (formal->attr.pointer
|| (formal->ts.type == BT_CLASS && CLASS_DATA (formal)
&& CLASS_DATA (formal)->attr.class_pointer))
{ {
attr = gfc_expr_attr (actual); attr = gfc_expr_attr (actual);
...@@ -1706,10 +1708,11 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, ...@@ -1706,10 +1708,11 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
gfc_typename (&formal->ts)); gfc_typename (&formal->ts));
return 0; return 0;
} }
/* F2008, 12.5.2.5. */ /* F2008, 12.5.2.5; IR F08/0073. */
if (formal->ts.type == BT_CLASS if (formal->ts.type == BT_CLASS
&& (CLASS_DATA (formal)->attr.class_pointer && ((CLASS_DATA (formal)->attr.class_pointer
&& !formal->attr.intent == INTENT_IN)
|| CLASS_DATA (formal)->attr.allocatable)) || CLASS_DATA (formal)->attr.allocatable))
{ {
if (actual->ts.type != BT_CLASS) if (actual->ts.type != BT_CLASS)
......
2012-03-02 Tobias Burnus <burnus@net-b.de> 2012-03-02 Tobias Burnus <burnus@net-b.de>
PR fortran/52270
* gfortran.dg/class_51.f90: New.
2012-03-02 Tobias Burnus <burnus@net-b.de>
PR fortran/52452 PR fortran/52452
* gfortran.dg/intrinsic_8.f90: New. * gfortran.dg/intrinsic_8.f90: New.
......
! { dg-do compile }
! { dg-options "-fdump-tree-original" }
!
! PR fortran/52270
!
! From IR F08/0073 by Malcolm Cohen
!
Program m013
Type t
Real c
End Type
Type(t),Target :: x
Call sub(x)
Print *,x%c
if (x%c /= 3) call abort ()
Contains
Subroutine sub(p)
Class(t),Pointer,Intent(In) :: p
p%c = 3
End Subroutine
End Program
! { dg-final { scan-tree-dump-times "sub \\(&class" 1 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
! { dg-do compile }
! { dg-options "-std=f2003" }
!
! PR fortran/52270
!
! From IR F08/0073 by Malcolm Cohen
!
Program m013
Type t
Real c
End Type
Type(t),Target :: x
Call sub(x) ! { dg-error "Fortran 2008: Non-pointer actual argument" }
Print *,x%c
if (x%c /= 3) call abort ()
Contains
Subroutine sub(p)
Class(t),Pointer,Intent(In) :: p
p%c = 3
End Subroutine
End Program
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment