[patches,fortran] Add POINTER INTENT(*) support (PR29624)

[patches,fortran] Add POINTER INTENT(*) support (PR29624)

[Tobias Burnus]

[-- Attachment #1: Type: text/plain, Size: 922 bytes --]

:ADDPATCH fortran:

The standard can be found at
http://gcc.gnu.org/bugzilla/show_bug.cgi?id=29624#c0

In a nutshell: With intent(in) the pointer dummy argument's association
shall not be changed, the target may.

Thanks to Tobias S. for pointing out that I was looking at the wrong
thing in terms of attributes.

Quick remark to compound structures:
- If the last subobject is a pointer & its association is changed, I
check whether somewhere higher up in the hierarchy is already a pointer,
because then the subobject is a target of that one. => Modification allowed.
- If the last subobject is a pointer & its value target value is changed
=> Modification always allowed
- If the last subobject is a nonpointer: Check whether somewhere higher
up in the hierarchy is already a pointer, because then the subobject is
a target of that one. => Modification allowed.


Regression tested on x86_64-unknown-linux-gnu.

Tobias

[-- Attachment #2: pointer-intent.diff --]
[-- Type: text/x-patch, Size: 21996 bytes --]

fortran/
2006-12-12  Tobias Burnus  <burnus@net-b.de>

	PR fortran/29624
	* interface.c (compare_parameter_intent): New function.
	  (check_intents): Support pointer intents.
	* symbol.c (check_conflict): Support pointer intents,
	  better conflict_std message.
	* expr.c (gfc_check_assign,gfc_check_pointer_assign):
	  Support pointer intents.
	* resolve.c (resolve_deallocate_expr,resolve_allocate_expr):
	  Support pointer intents.

testsuite/
2006-12-12  Tobias Burnus  <burnus@net-b.de>

	PR fortran/29624
	* gfortran.dg/allocatable_dummy_2.f90: Update dg-error.
	* gfortran.dg/protected_4.f90: Add pointer intent check.
	* gfortran.dg/protected_6.f90: Add pointer intent check.
	* gfortran.dg/pointer_intent_1.f90: New test.
	* gfortran.dg/pointer_intent_2.f90: New test.
	* gfortran.dg/pointer_intent_3.f90: New test.

Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c	(Revision 119747)
--- gcc/fortran/interface.c	(Arbeitskopie)
*************** check_some_aliasing (gfc_formal_arglist 
*** 1648,1653 ****
--- 1648,1675 ----
  }
  
  
+ /* Given a symbol of a formal argument list and an expression, see if
+    their intents are compatible.  Returns nonzero if compatible,
+    zero if not compatible.  */
+ 
+ static int
+ compare_parameter_intent (gfc_symbol * formal, gfc_expr * actual)
+ {
+   if (actual->symtree->n.sym->attr.pointer
+       && !formal->attr.pointer)
+     return 1;
+ 
+   if (actual->symtree->n.sym->attr.intent != INTENT_IN)
+     return 1;
+ 
+   if (formal->attr.intent == INTENT_INOUT
+       || formal->attr.intent == INTENT_OUT)
+     return 0;
+ 
+   return 1;
+ }
+ 
+ 
  /* Given formal and actual argument lists that correspond to one
     another, check that they are compatible in the sense that intents
     are not mismatched.  */
*************** check_some_aliasing (gfc_formal_arglist 
*** 1655,1661 ****
  static try
  check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
  {
!   sym_intent a_intent, f_intent;
  
    for (;; f = f->next, a = a->next)
      {
--- 1677,1683 ----
  static try
  check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
  {
!   sym_intent f_intent;
  
    for (;; f = f->next, a = a->next)
      {
*************** check_intents (gfc_formal_arglist * f, g
*** 1667,1678 ****
        if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
  	continue;
  
-       a_intent = a->expr->symtree->n.sym->attr.intent;
        f_intent = f->sym->attr.intent;
  
!       if (a_intent == INTENT_IN
! 	  && (f_intent == INTENT_INOUT
! 	      || f_intent == INTENT_OUT))
  	{
  
  	  gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
--- 1689,1697 ----
        if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
  	continue;
  
        f_intent = f->sym->attr.intent;
  
!       if (!compare_parameter_intent(f->sym, a->expr))
  	{
  
  	  gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c	(Revision 119747)
--- gcc/fortran/symbol.c	(Arbeitskopie)
*************** check_conflict (symbol_attribute * attr,
*** 288,294 ****
      {
        a1 = pointer;
        a2 = intent;
!       goto conflict;
      }
  
    /* Check for attributes not allowed in a BLOCK DATA.  */
--- 288,295 ----
      {
        a1 = pointer;
        a2 = intent;
!       standard = GFC_STD_F2003;
!       goto conflict_std;
      }
  
    /* Check for attributes not allowed in a BLOCK DATA.  */
*************** conflict:
*** 571,584 ****
  conflict_std:
    if (name == NULL)
      {
!       return gfc_notify_std (standard, "In the selected standard, %s attribute "
!                              "conflicts with %s attribute at %L", a1, a2,
!                              where);
      }
    else
      {
!       return gfc_notify_std (standard, "In the selected standard, %s attribute "
!                              "conflicts with %s attribute in '%s' at %L",
                               a1, a2, name, where);
      }
  }
--- 572,589 ----
  conflict_std:
    if (name == NULL)
      {
!       return gfc_notify_std (standard, "%s: %s attribute with %s attribute "
!                              "at %L",
!                              (standard == GFC_STD_F2003)
!                                ? "Fortran 2003" : "Not in the selected standard",
!                              a1, a2, where);
      }
    else
      {
!       return gfc_notify_std (standard, "%s: %s attribute with %s attribute "
!                              "in '%s' at %L",
!                              (standard == GFC_STD_F2003)
!                                ? "Fortran 2003" : "Not in the selected standard",
                               a1, a2, name, where);
      }
  }
Index: gcc/fortran/expr.c
===================================================================
*** gcc/fortran/expr.c	(Revision 119747)
--- gcc/fortran/expr.c	(Arbeitskopie)
*************** try
*** 2188,2199 ****
  gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
  {
    gfc_symbol *sym;
  
    sym = lvalue->symtree->n.sym;
  
!   if (sym->attr.intent == INTENT_IN)
      {
!       gfc_error ("Can't assign to INTENT(IN) variable '%s' at %L",
  		 sym->name, &lvalue->where);
        return FAILURE;
      }
--- 2188,2212 ----
  gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
  {
    gfc_symbol *sym;
+   gfc_ref *ref;
+   int has_pointer;
  
    sym = lvalue->symtree->n.sym;
  
!   /* Check INTENT(IN), unless the object itself of higher up in the
!      hierarchy is a pointer.  */
!   has_pointer = sym->attr.pointer;
! 
!   for (ref = lvalue->ref; ref; ref = ref->next)
!     if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
!       {
! 	has_pointer = 1;
! 	break;
!       }
! 
!   if (!has_pointer && sym->attr.intent == INTENT_IN)
      {
!       gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
  		 sym->name, &lvalue->where);
        return FAILURE;
      }
*************** try
*** 2318,2324 ****
--- 2331,2339 ----
  gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
  {
    symbol_attribute attr;
+   gfc_ref *ref;
    int is_pure;
+   int pointer, check_intent_in;
  
    if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN)
      {
*************** gfc_check_pointer_assign (gfc_expr * lva
*** 2336,2343 ****
        return FAILURE;
      }
  
!   attr = gfc_variable_attr (lvalue, NULL);
!   if (!attr.pointer)
      {
        gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
        return FAILURE;
--- 2351,2379 ----
        return FAILURE;
      }
  
! 
!   /* Check INTENT(IN), unless the object itself of higher up in the
!      hierarchy is a pointer.  */
!   check_intent_in = 1;
!   pointer = lvalue->symtree->n.sym->attr.pointer;
! 
!   for (ref = lvalue->ref; ref; ref = ref->next)
!     {
!       if (pointer)
!         check_intent_in = 0;
! 
!       if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
!         pointer = 1;
!     }
! 
!   if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
!     {
!       gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
!                  lvalue->symtree->n.sym->name, &lvalue->where);
!       return FAILURE;
!     }
! 
!   if (!pointer)
      {
        gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
        return FAILURE;
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(Revision 119747)
--- gcc/fortran/resolve.c	(Arbeitskopie)
*************** derived_inaccessible (gfc_symbol *sym)
*** 3317,3365 ****
  static try
  resolve_deallocate_expr (gfc_expr * e)
  {
!   symbol_attribute attr;
!   int allocatable;
    gfc_ref *ref;
  
    if (gfc_resolve_expr (e) == FAILURE)
      return FAILURE;
  
-   attr = gfc_expr_attr (e);
-   if (attr.pointer)
-     return SUCCESS;
- 
    if (e->expr_type != EXPR_VARIABLE)
      goto bad;
  
    allocatable = e->symtree->n.sym->attr.allocatable;
    for (ref = e->ref; ref; ref = ref->next)
!     switch (ref->type)
!       {
!       case REF_ARRAY:
! 	if (ref->u.ar.type != AR_FULL)
! 	  allocatable = 0;
! 	break;
  
!       case REF_COMPONENT:
! 	allocatable = (ref->u.c.component->as != NULL
! 		       && ref->u.c.component->as->type == AS_DEFERRED);
! 	break;
  
!       case REF_SUBSTRING:
! 	allocatable = 0;
! 	break;
!       }
  
!   if (allocatable == 0)
      {
      bad:
        gfc_error ("Expression in DEALLOCATE statement at %L must be "
  		 "ALLOCATABLE or a POINTER", &e->where);
      }
  
!   if (e->symtree->n.sym->attr.intent == INTENT_IN)
      {
!       gfc_error ("Can't deallocate INTENT(IN) variable '%s' at %L",
                   e->symtree->n.sym->name, &e->where);
        return FAILURE;
      }
--- 3317,3372 ----
  static try
  resolve_deallocate_expr (gfc_expr * e)
  {
!   int allocatable, pointer, check_intent_in;
    gfc_ref *ref;
  
+   /* Check INTENT(IN), unless an object higher up in the
+      hierarchy is a pointer.  */
+   check_intent_in = 1;
+ 
    if (gfc_resolve_expr (e) == FAILURE)
      return FAILURE;
  
    if (e->expr_type != EXPR_VARIABLE)
      goto bad;
  
    allocatable = e->symtree->n.sym->attr.allocatable;
+   pointer = e->symtree->n.sym->attr.pointer;
    for (ref = e->ref; ref; ref = ref->next)
!     {
!       if (pointer)
!         check_intent_in = 0;
  
!       switch (ref->type)
!         {
!         case REF_ARRAY:
! 	  if (ref->u.ar.type != AR_FULL)
! 	    allocatable = 0;
! 	  break;
  
!         case REF_COMPONENT:
! 	  allocatable = (ref->u.c.component->as != NULL
! 		         && ref->u.c.component->as->type == AS_DEFERRED);
! 	  pointer = ref->u.c.component->pointer;
! 	  break;
  
!         case REF_SUBSTRING:
! 	  allocatable = 0;
! 	  break;
!         }
!     }
! 
!   if (allocatable == 0 && pointer == 0)
      {
      bad:
        gfc_error ("Expression in DEALLOCATE statement at %L must be "
  		 "ALLOCATABLE or a POINTER", &e->where);
      }
  
!   if (check_intent_in
!       && e->symtree->n.sym->attr.intent == INTENT_IN)
      {
!       gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
                   e->symtree->n.sym->name, &e->where);
        return FAILURE;
      }
*************** expr_to_initialize (gfc_expr * e)
*** 3481,3487 ****
  static try
  resolve_allocate_expr (gfc_expr * e, gfc_code * code)
  {
!   int i, pointer, allocatable, dimension;
    symbol_attribute attr;
    gfc_ref *ref, *ref2;
    gfc_array_ref *ar;
--- 3488,3494 ----
  static try
  resolve_allocate_expr (gfc_expr * e, gfc_code * code)
  {
!   int i, pointer, allocatable, dimension, check_intent_in;
    symbol_attribute attr;
    gfc_ref *ref, *ref2;
    gfc_array_ref *ar;
*************** resolve_allocate_expr (gfc_expr * e, gfc
*** 3490,3495 ****
--- 3497,3506 ----
    gfc_symbol *sym;
    gfc_alloc *a;
  
+   /* Check INTENT(IN), unless an object higher up in the
+      hierarchy is a pointer.  */
+   check_intent_in = 1;
+ 
    if (gfc_resolve_expr (e) == FAILURE)
      return FAILURE;
  
*************** resolve_allocate_expr (gfc_expr * e, gfc
*** 3527,3552 ****
  	}
  
        for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
! 	switch (ref->type)
! 	  {
! 	  case REF_ARRAY:
! 	    if (ref->next != NULL)
! 	      pointer = 0;
! 	    break;
! 
! 	  case REF_COMPONENT:
! 	    allocatable = (ref->u.c.component->as != NULL
! 			   && ref->u.c.component->as->type == AS_DEFERRED);
! 
! 	    pointer = ref->u.c.component->pointer;
! 	    dimension = ref->u.c.component->dimension;
! 	    break;
  
! 	  case REF_SUBSTRING:
! 	    allocatable = 0;
! 	    pointer = 0;
! 	    break;
! 	  }
      }
  
    if (allocatable == 0 && pointer == 0)
--- 3538,3568 ----
  	}
  
        for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
!         {
! 	  if (pointer)
! 	    check_intent_in = 0;
  
! 	  switch (ref->type)
! 	    {
!  	      case REF_ARRAY:
! 	        if (ref->next != NULL)
! 	          pointer = 0;
! 	        break;
! 
! 	      case REF_COMPONENT:
! 	        allocatable = (ref->u.c.component->as != NULL
! 			      && ref->u.c.component->as->type == AS_DEFERRED);
! 
! 	        pointer = ref->u.c.component->pointer;
! 	        dimension = ref->u.c.component->dimension;
! 	        break;
! 
! 	      case REF_SUBSTRING:
! 	        allocatable = 0;
! 	        pointer = 0;
! 	        break;
! 	    }
!        }
      }
  
    if (allocatable == 0 && pointer == 0)
*************** resolve_allocate_expr (gfc_expr * e, gfc
*** 3556,3564 ****
        return FAILURE;
      }
  
!   if (e->symtree->n.sym->attr.intent == INTENT_IN)
      {
!       gfc_error ("Can't allocate INTENT(IN) variable '%s' at %L",
                   e->symtree->n.sym->name, &e->where);
        return FAILURE;
      }
--- 3572,3581 ----
        return FAILURE;
      }
  
!   if (check_intent_in
!       && e->symtree->n.sym->attr.intent == INTENT_IN)
      {
!       gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
                   e->symtree->n.sym->name, &e->where);
        return FAILURE;
      }
Index: gcc/testsuite/gfortran.dg/protected_4.f90
===================================================================
*** gcc/testsuite/gfortran.dg/protected_4.f90	(Revision 119747)
--- gcc/testsuite/gfortran.dg/protected_4.f90	(Arbeitskopie)
*************** program main
*** 21,26 ****
--- 21,27 ----
    use protmod
    implicit none
    integer   :: j 
+   logical   :: asgnd
    protected :: j ! { dg-error "only allowed in specification part of a module" }
    a = 43       ! { dg-error "Assigning to PROTECTED variable" }
    ap => null() ! { dg-error "Assigning to PROTECTED variable" }
*************** program main
*** 30,35 ****
--- 31,38 ----
    allocate(ap) ! { dg-error "Assigning to PROTECTED variable" }
    ap = 73      ! { dg-error "Assigning to PROTECTED variable" }
    call increment(a,at) ! { dg-error "use-associated with PROTECTED attribute" }
+   call pointer_assignments(ap) ! { dg-error "is use-associated with PROTECTED attribute" }
+   asgnd = pointer_check(ap)
  contains
    subroutine increment(a1,a3)
      integer, intent(inout) :: a1, a3
*************** contains
*** 37,45 ****
      a3 = a3 + 1
    end subroutine increment
    subroutine pointer_assignments(p)
!     integer, pointer :: p ! with [pointer] intent(out)
!     p => null()           ! this is invalid
    end subroutine pointer_assignments
  end program main
  
  module test
--- 40,53 ----
      a3 = a3 + 1
    end subroutine increment
    subroutine pointer_assignments(p)
!     integer, pointer,intent(out) :: p
!     p => null()           
    end subroutine pointer_assignments
+   function pointer_check(p)
+     integer, pointer,intent(in) :: p
+     logical :: pointer_check
+     pointer_check = associated(p)
+   end function pointer_check
  end program main
  
  module test
Index: gcc/testsuite/gfortran.dg/protected_6.f90
===================================================================
*** gcc/testsuite/gfortran.dg/protected_6.f90	(Revision 119747)
--- gcc/testsuite/gfortran.dg/protected_6.f90	(Arbeitskopie)
*************** program main
*** 27,32 ****
--- 27,33 ----
    allocate(ap) ! { dg-error "Assigning to PROTECTED variable" }
    ap = 73      ! { dg-error "Assigning to PROTECTED variable" }
    call increment(a,at) ! { dg-error "use-associated with PROTECTED attribute" }
+   call pointer_assignments(ap) ! { dg-error "is use-associated with PROTECTED attribute" }
  contains
    subroutine increment(a1,a3)
      integer, intent(inout) :: a1, a3
*************** contains
*** 34,41 ****
      a3 = a3 + 1
    end subroutine increment
    subroutine pointer_assignments(p)
!     integer, pointer :: p ! with [pointer] intent(out)
!     p => null()           ! this is invalid
    end subroutine pointer_assignments
  end program main
  
--- 35,42 ----
      a3 = a3 + 1
    end subroutine increment
    subroutine pointer_assignments(p)
!     integer, pointer,intent (inout) :: p
!     p => null()
    end subroutine pointer_assignments
  end program main
  
Index: gcc/testsuite/gfortran.dg/allocatable_dummy_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/allocatable_dummy_2.f90	(Revision 119747)
--- gcc/testsuite/gfortran.dg/allocatable_dummy_2.f90	(Arbeitskopie)
*************** contains
*** 16,28 ****
      subroutine init2(x)
          integer, allocatable, intent(in) :: x(:)
  
!         allocate(x(3)) ! { dg-error "Can't allocate" }
      end subroutine init2
  
      subroutine kill(x)
          integer, allocatable, intent(in) :: x(:)
          
!         deallocate(x) ! { dg-error "Can't deallocate" }
      end subroutine kill
  
  end program alloc_dummy
--- 16,28 ----
      subroutine init2(x)
          integer, allocatable, intent(in) :: x(:)
  
!         allocate(x(3)) ! { dg-error "Cannot allocate" }
      end subroutine init2
  
      subroutine kill(x)
          integer, allocatable, intent(in) :: x(:)
          
!         deallocate(x) ! { dg-error "Cannot deallocate" }
      end subroutine kill
  
  end program alloc_dummy
Index: gcc/testsuite/gfortran.dg/pointer_intent_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pointer_intent_1.f90	(Revision 0)
--- gcc/testsuite/gfortran.dg/pointer_intent_1.f90	(Revision 0)
***************
*** 0 ****
--- 1,71 ----
+ ! { dg-run }
+ ! { dg-options "-std=f2003 -fall-intrinsics" }
+ ! Pointer intent test
+ ! PR fortran/29624
+ !
+ ! Valid program
+ program test
+  implicit none
+  type myT
+    integer          :: x
+    integer, pointer :: point
+  end type myT
+  integer, pointer :: p
+  type(myT), pointer :: t
+  type(myT) :: t2
+  allocate(p,t)
+  allocate(t%point)
+  t%point = 55
+  p = 33
+  call a(p,t)
+  deallocate(p)
+  nullify(p)
+  call a(p,t)
+  call nonpointer(t2)
+ contains
+   subroutine a(p,t)
+     integer, pointer,intent(in)    :: p
+     type(myT), pointer, intent(in) :: t
+     integer, pointer :: tmp
+     if(.not.associated(p)) return
+     if(p /= 33) call abort()
+     p = 7
+     if (associated(t)) then
+       ! allocating is valid as we don't change the status
+       ! of the pointer "t", only of it's target
+       t%x = -15
+       if(.not.associated(t%point)) call abort()
+       if(t%point /= 55) call abort()
+       nullify(t%point)
+       allocate(tmp)
+       t%point => tmp
+       deallocate(t%point)
+       t%point => null(t%point)
+       tmp => null(tmp)
+       allocate(t%point)
+       t%point = 27
+       if(t%point /= 27) call abort()
+       if(t%x     /= -15) call abort()
+       call foo(t)
+       if(t%x     /=  32) call abort()
+       if(t%point /= -98) call abort()
+     end if
+     call b(p)
+     if(p /= 5) call abort()
+   end subroutine
+   subroutine b(v)
+     integer, intent(out) :: v
+     v = 5
+   end subroutine b
+   subroutine foo(comp)
+     type(myT), intent(inout) :: comp
+     if(comp%x     /= -15) call abort()
+     !if(comp%point /=  27) call abort()
+     comp%x     = 32
+     comp%point = -98
+   end subroutine foo
+   subroutine nonpointer(t)
+      type(myT), intent(in) :: t
+      t%point = 7
+   end subroutine nonpointer
+ end program
Index: gcc/testsuite/gfortran.dg/pointer_intent_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pointer_intent_2.f90	(Revision 0)
--- gcc/testsuite/gfortran.dg/pointer_intent_2.f90	(Revision 0)
***************
*** 0 ****
--- 1,19 ----
+ ! { dg-compile }
+ ! { dg-options "-std=f95" }
+ ! { dg-shouldfail "Fortran 2003 feature with -std=f95" }
+ !
+ ! Pointer intent test
+ ! PR fortran/29624
+ !
+ ! Fortran 2003 features in Fortran 95
+ program test
+  implicit none
+  integer, pointer :: p
+  allocate(p)
+  p = 33
+  call a(p) ! { dg-error "Type/rank mismatch in argument" }
+ contains
+   subroutine a(p)! { dg-error "has no IMPLICIT type" }
+     integer, pointer,intent(in) :: p ! { dg-error "POINTER attribute with INTENT attribute" }
+   end subroutine
+ end program
Index: gcc/testsuite/gfortran.dg/pointer_intent_3.f90
===================================================================
*** gcc/testsuite/gfortran.dg/pointer_intent_3.f90	(Revision 0)
--- gcc/testsuite/gfortran.dg/pointer_intent_3.f90	(Revision 0)
***************
*** 0 ****
--- 1,41 ----
+ ! { dg-compile }
+ ! { dg-options "-std=f2003 -fall-intrinsics" }
+ ! { dg-shouldfail "Invalid code" }
+ !
+ ! Pointer intent test
+ ! PR fortran/29624
+ !
+ ! Valid program
+ program test
+  implicit none
+  type myT
+     integer :: j = 5
+     integer, pointer :: jp => null()
+  end type myT
+  integer, pointer :: p
+  type(myT) :: t
+  call a(p)
+  call b(t)
+ contains
+   subroutine a(p)
+     integer, pointer,intent(in) :: p
+     p => null(p)! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
+     nullify(p)  ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
+     allocate(p) ! { dg-error "Cannot allocate INTENT\\(IN\\) variable" }
+     call c(p)   ! { dg-error "is INTENT\\(IN\\) while interface specifies INTENT\\(INOUT\\)" }
+     deallocate(p) ! { dg-error "Cannot deallocate INTENT\\(IN\\) variable" }
+   end subroutine
+   subroutine c(p)
+     integer, pointer, intent(inout) :: p
+     nullify(p)
+   end subroutine c
+   subroutine b(t)
+     type(myT),intent(in) :: t
+     t%jp = 5
+     t%jp => null(t%jp)  ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
+     nullify(t%jp) ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
+     t%j = 7 ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
+     allocate(t%jp) ! { dg-error "Cannot allocate INTENT\\(IN\\) variable" }
+     deallocate(t%jp) ! { dg-error "Cannot deallocate INTENT\\(IN\\) variable" }
+   end subroutine b
+ end program

Re: [patches,fortran] Add POINTER INTENT(*) support (PR29624)

[Tobias Burnus]

[-- Attachment #1: Type: text/plain, Size: 1409 bytes --]

Hi,

modified patch; the change in resolve_deallocate_exp caused the
following regression:

  deallocate(pointerToArray(0))

was accepted, which provoked later an ICE. With the following change
(interdiff) this it detected. I added also a check to the test suite to
make sure this does not happen again.

Regression tested on x86_64-unknown-linux-gnu.

Tobias


INTERDIFF:

diff -u gcc/fortran/resolve.c gcc/fortran/resolve.c
--- gcc/fortran/resolve.c       (Arbeitskopie)
+++ gcc/fortran/resolve.c       (Arbeitskopie)
@@ -3317,6 +3317,7 @@
 static try
 resolve_deallocate_expr (gfc_expr * e)
 {
+  symbol_attribute attr;
   int allocatable, pointer, check_intent_in;
   gfc_ref *ref;

@@ -3356,7 +3357,9 @@
         }
     }

-  if (allocatable == 0 && pointer == 0)
+  attr = gfc_expr_attr (e);
+
+  if (allocatable == 0 && attr.pointer == 0)
     {
     bad:
       gfc_error ("Expression in DEALLOCATE statement at %L must be "
only in patch2:
unchanged:
--- gcc/testsuite/gfortran.dg/alloc_alloc_expr_1.f90    (Revision 119989)
+++ gcc/testsuite/gfortran.dg/alloc_alloc_expr_1.f90    (Arbeitskopie)
@@ -24,6 +24,8 @@

   ALLOCATE(PTR,ALLOCS(PTR)) ! { dg-error "same ALLOCATE statement" }

-  print *, 'This program has three errors', PTR, ALLOC(1)
+  deallocate(ALLOCS(1)) ! { dg-error "must be ALLOCATABLE or a POINTER" }
+
+  print *, 'This program has four errors', PTR, ALLOC(1)

 end program fc011

[-- Attachment #2: pointer-intent2.diff --]
[-- Type: text/x-patch, Size: 18574 bytes --]

fortran/
2006-12-12  Tobias Burnus  <burnus@net-b.de>

	PR fortran/29624
	* interface.c (compare_parameter_intent): New function.
	  (check_intents): Support pointer intents.
	* symbol.c (check_conflict): Support pointer intents,
	  better conflict_std message.
	* expr.c (gfc_check_assign,gfc_check_pointer_assign):
	  Support pointer intents.
	* resolve.c (resolve_deallocate_expr,resolve_allocate_expr):
	  Support pointer intents.

testsuite/
2006-12-12  Tobias Burnus  <burnus@net-b.de>

	PR fortran/29624
	* gfortran.dg/alloc_alloc_expr_1.f90: Add check for
	  invalid deallocate.
	* gfortran.dg/allocatable_dummy_2.f90: Update dg-error.
	* gfortran.dg/protected_4.f90: Add pointer intent check.
	* gfortran.dg/protected_6.f90: Add pointer intent check.
	* gfortran.dg/pointer_intent_1.f90: New test.
	* gfortran.dg/pointer_intent_2.f90: New test.
	* gfortran.dg/pointer_intent_3.f90: New test.

Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(Revision 119993)
+++ gcc/fortran/interface.c	(Arbeitskopie)
@@ -1648,6 +1648,28 @@
 }
 
 
+/* Given a symbol of a formal argument list and an expression, see if
+   their intents are compatible.  Returns nonzero if compatible,
+   zero if not compatible.  */
+
+static int
+compare_parameter_intent (gfc_symbol * formal, gfc_expr * actual)
+{
+  if (actual->symtree->n.sym->attr.pointer
+      && !formal->attr.pointer)
+    return 1;
+
+  if (actual->symtree->n.sym->attr.intent != INTENT_IN)
+    return 1;
+
+  if (formal->attr.intent == INTENT_INOUT
+      || formal->attr.intent == INTENT_OUT)
+    return 0;
+
+  return 1;
+}
+
+
 /* Given formal and actual argument lists that correspond to one
    another, check that they are compatible in the sense that intents
    are not mismatched.  */
@@ -1655,7 +1677,7 @@
 static try
 check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
 {
-  sym_intent a_intent, f_intent;
+  sym_intent f_intent;
 
   for (;; f = f->next, a = a->next)
     {
@@ -1667,12 +1689,9 @@
       if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
 	continue;
 
-      a_intent = a->expr->symtree->n.sym->attr.intent;
       f_intent = f->sym->attr.intent;
 
-      if (a_intent == INTENT_IN
-	  && (f_intent == INTENT_INOUT
-	      || f_intent == INTENT_OUT))
+      if (!compare_parameter_intent(f->sym, a->expr))
 	{
 
 	  gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(Revision 119993)
+++ gcc/fortran/symbol.c	(Arbeitskopie)
@@ -288,7 +288,8 @@
     {
       a1 = pointer;
       a2 = intent;
-      goto conflict;
+      standard = GFC_STD_F2003;
+      goto conflict_std;
     }
 
   /* Check for attributes not allowed in a BLOCK DATA.  */
@@ -571,14 +572,18 @@
 conflict_std:
   if (name == NULL)
     {
-      return gfc_notify_std (standard, "In the selected standard, %s attribute "
-                             "conflicts with %s attribute at %L", a1, a2,
-                             where);
+      return gfc_notify_std (standard, "%s: %s attribute with %s attribute "
+                             "at %L",
+                             (standard == GFC_STD_F2003)
+                               ? "Fortran 2003" : "Not in the selected standard",
+                             a1, a2, where);
     }
   else
     {
-      return gfc_notify_std (standard, "In the selected standard, %s attribute "
-                             "conflicts with %s attribute in '%s' at %L",
+      return gfc_notify_std (standard, "%s: %s attribute with %s attribute "
+                             "in '%s' at %L",
+                             (standard == GFC_STD_F2003)
+                               ? "Fortran 2003" : "Not in the selected standard",
                              a1, a2, name, where);
     }
 }
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(Revision 119993)
+++ gcc/fortran/expr.c	(Arbeitskopie)
@@ -2188,12 +2188,25 @@
 gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
 {
   gfc_symbol *sym;
+  gfc_ref *ref;
+  int has_pointer;
 
   sym = lvalue->symtree->n.sym;
 
-  if (sym->attr.intent == INTENT_IN)
+  /* Check INTENT(IN), unless the object itself of higher up in the
+     hierarchy is a pointer.  */
+  has_pointer = sym->attr.pointer;
+
+  for (ref = lvalue->ref; ref; ref = ref->next)
+    if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
+      {
+	has_pointer = 1;
+	break;
+      }
+
+  if (!has_pointer && sym->attr.intent == INTENT_IN)
     {
-      gfc_error ("Can't assign to INTENT(IN) variable '%s' at %L",
+      gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
 		 sym->name, &lvalue->where);
       return FAILURE;
     }
@@ -2318,7 +2331,9 @@
 gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
 {
   symbol_attribute attr;
+  gfc_ref *ref;
   int is_pure;
+  int pointer, check_intent_in;
 
   if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN)
     {
@@ -2336,8 +2351,29 @@
       return FAILURE;
     }
 
-  attr = gfc_variable_attr (lvalue, NULL);
-  if (!attr.pointer)
+
+  /* Check INTENT(IN), unless the object itself of higher up in the
+     hierarchy is a pointer.  */
+  check_intent_in = 1;
+  pointer = lvalue->symtree->n.sym->attr.pointer;
+
+  for (ref = lvalue->ref; ref; ref = ref->next)
+    {
+      if (pointer)
+        check_intent_in = 0;
+
+      if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
+        pointer = 1;
+    }
+
+  if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
+    {
+      gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
+                 lvalue->symtree->n.sym->name, &lvalue->where);
+      return FAILURE;
+    }
+
+  if (!pointer)
     {
       gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
       return FAILURE;
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(Revision 119993)
+++ gcc/fortran/resolve.c	(Arbeitskopie)
@@ -3318,48 +3318,58 @@
 resolve_deallocate_expr (gfc_expr * e)
 {
   symbol_attribute attr;
-  int allocatable;
+  int allocatable, pointer, check_intent_in;
   gfc_ref *ref;
 
+  /* Check INTENT(IN), unless an object higher up in the
+     hierarchy is a pointer.  */
+  check_intent_in = 1;
+
   if (gfc_resolve_expr (e) == FAILURE)
     return FAILURE;
 
-  attr = gfc_expr_attr (e);
-  if (attr.pointer)
-    return SUCCESS;
-
   if (e->expr_type != EXPR_VARIABLE)
     goto bad;
 
   allocatable = e->symtree->n.sym->attr.allocatable;
+  pointer = e->symtree->n.sym->attr.pointer;
   for (ref = e->ref; ref; ref = ref->next)
-    switch (ref->type)
-      {
-      case REF_ARRAY:
-	if (ref->u.ar.type != AR_FULL)
-	  allocatable = 0;
-	break;
+    {
+      if (pointer)
+        check_intent_in = 0;
 
-      case REF_COMPONENT:
-	allocatable = (ref->u.c.component->as != NULL
-		       && ref->u.c.component->as->type == AS_DEFERRED);
-	break;
+      switch (ref->type)
+        {
+        case REF_ARRAY:
+	  if (ref->u.ar.type != AR_FULL)
+	    allocatable = 0;
+	  break;
 
-      case REF_SUBSTRING:
-	allocatable = 0;
-	break;
-      }
+        case REF_COMPONENT:
+	  allocatable = (ref->u.c.component->as != NULL
+		         && ref->u.c.component->as->type == AS_DEFERRED);
+	  pointer = ref->u.c.component->pointer;
+	  break;
+
+        case REF_SUBSTRING:
+	  allocatable = 0;
+	  break;
+        }
+    }
 
-  if (allocatable == 0)
+  attr = gfc_expr_attr (e);
+
+  if (allocatable == 0 && attr.pointer == 0)
     {
     bad:
       gfc_error ("Expression in DEALLOCATE statement at %L must be "
 		 "ALLOCATABLE or a POINTER", &e->where);
     }
 
-  if (e->symtree->n.sym->attr.intent == INTENT_IN)
+  if (check_intent_in
+      && e->symtree->n.sym->attr.intent == INTENT_IN)
     {
-      gfc_error ("Can't deallocate INTENT(IN) variable '%s' at %L",
+      gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
                  e->symtree->n.sym->name, &e->where);
       return FAILURE;
     }
@@ -3481,7 +3491,7 @@
 static try
 resolve_allocate_expr (gfc_expr * e, gfc_code * code)
 {
-  int i, pointer, allocatable, dimension;
+  int i, pointer, allocatable, dimension, check_intent_in;
   symbol_attribute attr;
   gfc_ref *ref, *ref2;
   gfc_array_ref *ar;
@@ -3490,6 +3500,10 @@
   gfc_symbol *sym;
   gfc_alloc *a;
 
+  /* Check INTENT(IN), unless an object higher up in the
+     hierarchy is a pointer.  */
+  check_intent_in = 1;
+
   if (gfc_resolve_expr (e) == FAILURE)
     return FAILURE;
 
@@ -3527,26 +3541,31 @@
 	}
 
       for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
-	switch (ref->type)
-	  {
-	  case REF_ARRAY:
-	    if (ref->next != NULL)
-	      pointer = 0;
-	    break;
-
-	  case REF_COMPONENT:
-	    allocatable = (ref->u.c.component->as != NULL
-			   && ref->u.c.component->as->type == AS_DEFERRED);
-
-	    pointer = ref->u.c.component->pointer;
-	    dimension = ref->u.c.component->dimension;
-	    break;
+        {
+	  if (pointer)
+	    check_intent_in = 0;
 
-	  case REF_SUBSTRING:
-	    allocatable = 0;
-	    pointer = 0;
-	    break;
-	  }
+	  switch (ref->type)
+	    {
+ 	      case REF_ARRAY:
+	        if (ref->next != NULL)
+	          pointer = 0;
+	        break;
+
+	      case REF_COMPONENT:
+	        allocatable = (ref->u.c.component->as != NULL
+			      && ref->u.c.component->as->type == AS_DEFERRED);
+
+	        pointer = ref->u.c.component->pointer;
+	        dimension = ref->u.c.component->dimension;
+	        break;
+
+	      case REF_SUBSTRING:
+	        allocatable = 0;
+	        pointer = 0;
+	        break;
+	    }
+       }
     }
 
   if (allocatable == 0 && pointer == 0)
@@ -3556,9 +3575,10 @@
       return FAILURE;
     }
 
-  if (e->symtree->n.sym->attr.intent == INTENT_IN)
+  if (check_intent_in
+      && e->symtree->n.sym->attr.intent == INTENT_IN)
     {
-      gfc_error ("Can't allocate INTENT(IN) variable '%s' at %L",
+      gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
                  e->symtree->n.sym->name, &e->where);
       return FAILURE;
     }
Index: gcc/testsuite/gfortran.dg/protected_4.f90
===================================================================
--- gcc/testsuite/gfortran.dg/protected_4.f90	(Revision 119989)
+++ gcc/testsuite/gfortran.dg/protected_4.f90	(Arbeitskopie)
@@ -21,6 +21,7 @@
   use protmod
   implicit none
   integer   :: j 
+  logical   :: asgnd
   protected :: j ! { dg-error "only allowed in specification part of a module" }
   a = 43       ! { dg-error "Assigning to PROTECTED variable" }
   ap => null() ! { dg-error "Assigning to PROTECTED variable" }
@@ -30,6 +31,8 @@
   allocate(ap) ! { dg-error "Assigning to PROTECTED variable" }
   ap = 73      ! { dg-error "Assigning to PROTECTED variable" }
   call increment(a,at) ! { dg-error "use-associated with PROTECTED attribute" }
+  call pointer_assignments(ap) ! { dg-error "is use-associated with PROTECTED attribute" }
+  asgnd = pointer_check(ap)
 contains
   subroutine increment(a1,a3)
     integer, intent(inout) :: a1, a3
@@ -37,9 +40,14 @@
     a3 = a3 + 1
   end subroutine increment
   subroutine pointer_assignments(p)
-    integer, pointer :: p ! with [pointer] intent(out)
-    p => null()           ! this is invalid
+    integer, pointer,intent(out) :: p
+    p => null()           
   end subroutine pointer_assignments
+  function pointer_check(p)
+    integer, pointer,intent(in) :: p
+    logical :: pointer_check
+    pointer_check = associated(p)
+  end function pointer_check
 end program main
 
 module test
Index: gcc/testsuite/gfortran.dg/protected_6.f90
===================================================================
--- gcc/testsuite/gfortran.dg/protected_6.f90	(Revision 119989)
+++ gcc/testsuite/gfortran.dg/protected_6.f90	(Arbeitskopie)
@@ -27,6 +27,7 @@
   allocate(ap) ! { dg-error "Assigning to PROTECTED variable" }
   ap = 73      ! { dg-error "Assigning to PROTECTED variable" }
   call increment(a,at) ! { dg-error "use-associated with PROTECTED attribute" }
+  call pointer_assignments(ap) ! { dg-error "is use-associated with PROTECTED attribute" }
 contains
   subroutine increment(a1,a3)
     integer, intent(inout) :: a1, a3
@@ -34,8 +35,8 @@
     a3 = a3 + 1
   end subroutine increment
   subroutine pointer_assignments(p)
-    integer, pointer :: p ! with [pointer] intent(out)
-    p => null()           ! this is invalid
+    integer, pointer,intent (inout) :: p
+    p => null()
   end subroutine pointer_assignments
 end program main
 
Index: gcc/testsuite/gfortran.dg/alloc_alloc_expr_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/alloc_alloc_expr_1.f90	(Revision 119989)
+++ gcc/testsuite/gfortran.dg/alloc_alloc_expr_1.f90	(Arbeitskopie)
@@ -24,6 +24,8 @@
 
   ALLOCATE(PTR,ALLOCS(PTR)) ! { dg-error "same ALLOCATE statement" }
 
-  print *, 'This program has three errors', PTR, ALLOC(1)
+  deallocate(ALLOCS(1)) ! { dg-error "must be ALLOCATABLE or a POINTER" }
+
+  print *, 'This program has four errors', PTR, ALLOC(1)
 
 end program fc011
Index: gcc/testsuite/gfortran.dg/allocatable_dummy_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/allocatable_dummy_2.f90	(Revision 119989)
+++ gcc/testsuite/gfortran.dg/allocatable_dummy_2.f90	(Arbeitskopie)
@@ -16,13 +16,13 @@
     subroutine init2(x)
         integer, allocatable, intent(in) :: x(:)
 
-        allocate(x(3)) ! { dg-error "Can't allocate" }
+        allocate(x(3)) ! { dg-error "Cannot allocate" }
     end subroutine init2
 
     subroutine kill(x)
         integer, allocatable, intent(in) :: x(:)
         
-        deallocate(x) ! { dg-error "Can't deallocate" }
+        deallocate(x) ! { dg-error "Cannot deallocate" }
     end subroutine kill
 
 end program alloc_dummy
Index: gcc/testsuite/gfortran.dg/pointer_intent_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pointer_intent_1.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/pointer_intent_1.f90	(Revision 0)
@@ -0,0 +1,71 @@
+! { dg-run }
+! { dg-options "-std=f2003 -fall-intrinsics" }
+! Pointer intent test
+! PR fortran/29624
+!
+! Valid program
+program test
+ implicit none
+ type myT
+   integer          :: x
+   integer, pointer :: point
+ end type myT
+ integer, pointer :: p
+ type(myT), pointer :: t
+ type(myT) :: t2
+ allocate(p,t)
+ allocate(t%point)
+ t%point = 55
+ p = 33
+ call a(p,t)
+ deallocate(p)
+ nullify(p)
+ call a(p,t)
+ call nonpointer(t2)
+contains
+  subroutine a(p,t)
+    integer, pointer,intent(in)    :: p
+    type(myT), pointer, intent(in) :: t
+    integer, pointer :: tmp
+    if(.not.associated(p)) return
+    if(p /= 33) call abort()
+    p = 7
+    if (associated(t)) then
+      ! allocating is valid as we don't change the status
+      ! of the pointer "t", only of it's target
+      t%x = -15
+      if(.not.associated(t%point)) call abort()
+      if(t%point /= 55) call abort()
+      nullify(t%point)
+      allocate(tmp)
+      t%point => tmp
+      deallocate(t%point)
+      t%point => null(t%point)
+      tmp => null(tmp)
+      allocate(t%point)
+      t%point = 27
+      if(t%point /= 27) call abort()
+      if(t%x     /= -15) call abort()
+      call foo(t)
+      if(t%x     /=  32) call abort()
+      if(t%point /= -98) call abort()
+    end if
+    call b(p)
+    if(p /= 5) call abort()
+  end subroutine
+  subroutine b(v)
+    integer, intent(out) :: v
+    v = 5
+  end subroutine b
+  subroutine foo(comp)
+    type(myT), intent(inout) :: comp
+    if(comp%x     /= -15) call abort()
+    !if(comp%point /=  27) call abort()
+    comp%x     = 32
+    comp%point = -98
+  end subroutine foo
+  subroutine nonpointer(t)
+     type(myT), intent(in) :: t
+     t%point = 7
+  end subroutine nonpointer
+end program
Index: gcc/testsuite/gfortran.dg/pointer_intent_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pointer_intent_2.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/pointer_intent_2.f90	(Revision 0)
@@ -0,0 +1,19 @@
+! { dg-compile }
+! { dg-options "-std=f95" }
+! { dg-shouldfail "Fortran 2003 feature with -std=f95" }
+!
+! Pointer intent test
+! PR fortran/29624
+!
+! Fortran 2003 features in Fortran 95
+program test
+ implicit none
+ integer, pointer :: p
+ allocate(p)
+ p = 33
+ call a(p) ! { dg-error "Type/rank mismatch in argument" }
+contains
+  subroutine a(p)! { dg-error "has no IMPLICIT type" }
+    integer, pointer,intent(in) :: p ! { dg-error "POINTER attribute with INTENT attribute" }
+  end subroutine
+end program
Index: gcc/testsuite/gfortran.dg/pointer_intent_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pointer_intent_3.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/pointer_intent_3.f90	(Revision 0)
@@ -0,0 +1,41 @@
+! { dg-compile }
+! { dg-options "-std=f2003 -fall-intrinsics" }
+! { dg-shouldfail "Invalid code" }
+!
+! Pointer intent test
+! PR fortran/29624
+!
+! Valid program
+program test
+ implicit none
+ type myT
+    integer :: j = 5
+    integer, pointer :: jp => null()
+ end type myT
+ integer, pointer :: p
+ type(myT) :: t
+ call a(p)
+ call b(t)
+contains
+  subroutine a(p)
+    integer, pointer,intent(in) :: p
+    p => null(p)! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
+    nullify(p)  ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
+    allocate(p) ! { dg-error "Cannot allocate INTENT\\(IN\\) variable" }
+    call c(p)   ! { dg-error "is INTENT\\(IN\\) while interface specifies INTENT\\(INOUT\\)" }
+    deallocate(p) ! { dg-error "Cannot deallocate INTENT\\(IN\\) variable" }
+  end subroutine
+  subroutine c(p)
+    integer, pointer, intent(inout) :: p
+    nullify(p)
+  end subroutine c
+  subroutine b(t)
+    type(myT),intent(in) :: t
+    t%jp = 5
+    t%jp => null(t%jp)  ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
+    nullify(t%jp) ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
+    t%j = 7 ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
+    allocate(t%jp) ! { dg-error "Cannot allocate INTENT\\(IN\\) variable" }
+    deallocate(t%jp) ! { dg-error "Cannot deallocate INTENT\\(IN\\) variable" }
+  end subroutine b
+end program

Re: [patches,fortran] Add POINTER INTENT(*) support (PR29624)

[Tobias Burnus]

[-- Attachment #1: Type: text/plain, Size: 1405 bytes --]

* PING *

Tobias

PS: Somewhat late I wish Merry Christmas and - still in time - a happy
New Year to all!


Tobias Burnus wrote:
>> The standard can be found at
>> http://gcc.gnu.org/bugzilla/show_bug.cgi?id=29624#c0
>>
>> In a nutshell: With intent(in) the pointer dummy argument's association
>> shall not be changed, the target may.
>>
>> Thanks to Tobias S. for pointing out that I was looking at the wrong
>> thing in terms of attributes.
>>
>> Quick remark to compound structures:
>> - If the last subobject is a pointer & its association is changed, I
>> check whether somewhere higher up in the hierarchy is already a pointer,
>> because then the subobject is a target of that one. => Modification allowed.
>> - If the last subobject is a pointer & its value target value is changed
>> => Modification always allowed
>> - If the last subobject is a nonpointer: Check whether somewhere higher
>> up in the hierarchy is already a pointer, because then the subobject is
>> a target of that one. => Modification allowed.
>
> modified patch; the change in resolve_deallocate_exp caused the following regression:
>
>   deallocate(pointerToArray(0))
>
> was accepted, which provoked later an ICE. With the following change
> (interdiff) this it detected. I added also a check to the test suite to
> make sure this does not happen again.
>
> Regression tested on x86_64-unknown-linux-gnu.
>
> Tobias
>   

[-- Attachment #2: pointer-intent2.diff --]
[-- Type: text/x-patch, Size: 18574 bytes --]

fortran/
2006-12-12  Tobias Burnus  <burnus@net-b.de>

	PR fortran/29624
	* interface.c (compare_parameter_intent): New function.
	  (check_intents): Support pointer intents.
	* symbol.c (check_conflict): Support pointer intents,
	  better conflict_std message.
	* expr.c (gfc_check_assign,gfc_check_pointer_assign):
	  Support pointer intents.
	* resolve.c (resolve_deallocate_expr,resolve_allocate_expr):
	  Support pointer intents.

testsuite/
2006-12-12  Tobias Burnus  <burnus@net-b.de>

	PR fortran/29624
	* gfortran.dg/alloc_alloc_expr_1.f90: Add check for
	  invalid deallocate.
	* gfortran.dg/allocatable_dummy_2.f90: Update dg-error.
	* gfortran.dg/protected_4.f90: Add pointer intent check.
	* gfortran.dg/protected_6.f90: Add pointer intent check.
	* gfortran.dg/pointer_intent_1.f90: New test.
	* gfortran.dg/pointer_intent_2.f90: New test.
	* gfortran.dg/pointer_intent_3.f90: New test.

Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(Revision 119993)
+++ gcc/fortran/interface.c	(Arbeitskopie)
@@ -1648,6 +1648,28 @@
 }
 
 
+/* Given a symbol of a formal argument list and an expression, see if
+   their intents are compatible.  Returns nonzero if compatible,
+   zero if not compatible.  */
+
+static int
+compare_parameter_intent (gfc_symbol * formal, gfc_expr * actual)
+{
+  if (actual->symtree->n.sym->attr.pointer
+      && !formal->attr.pointer)
+    return 1;
+
+  if (actual->symtree->n.sym->attr.intent != INTENT_IN)
+    return 1;
+
+  if (formal->attr.intent == INTENT_INOUT
+      || formal->attr.intent == INTENT_OUT)
+    return 0;
+
+  return 1;
+}
+
+
 /* Given formal and actual argument lists that correspond to one
    another, check that they are compatible in the sense that intents
    are not mismatched.  */
@@ -1655,7 +1677,7 @@
 static try
 check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
 {
-  sym_intent a_intent, f_intent;
+  sym_intent f_intent;
 
   for (;; f = f->next, a = a->next)
     {
@@ -1667,12 +1689,9 @@
       if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
 	continue;
 
-      a_intent = a->expr->symtree->n.sym->attr.intent;
       f_intent = f->sym->attr.intent;
 
-      if (a_intent == INTENT_IN
-	  && (f_intent == INTENT_INOUT
-	      || f_intent == INTENT_OUT))
+      if (!compare_parameter_intent(f->sym, a->expr))
 	{
 
 	  gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(Revision 119993)
+++ gcc/fortran/symbol.c	(Arbeitskopie)
@@ -288,7 +288,8 @@
     {
       a1 = pointer;
       a2 = intent;
-      goto conflict;
+      standard = GFC_STD_F2003;
+      goto conflict_std;
     }
 
   /* Check for attributes not allowed in a BLOCK DATA.  */
@@ -571,14 +572,18 @@
 conflict_std:
   if (name == NULL)
     {
-      return gfc_notify_std (standard, "In the selected standard, %s attribute "
-                             "conflicts with %s attribute at %L", a1, a2,
-                             where);
+      return gfc_notify_std (standard, "%s: %s attribute with %s attribute "
+                             "at %L",
+                             (standard == GFC_STD_F2003)
+                               ? "Fortran 2003" : "Not in the selected standard",
+                             a1, a2, where);
     }
   else
     {
-      return gfc_notify_std (standard, "In the selected standard, %s attribute "
-                             "conflicts with %s attribute in '%s' at %L",
+      return gfc_notify_std (standard, "%s: %s attribute with %s attribute "
+                             "in '%s' at %L",
+                             (standard == GFC_STD_F2003)
+                               ? "Fortran 2003" : "Not in the selected standard",
                              a1, a2, name, where);
     }
 }
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(Revision 119993)
+++ gcc/fortran/expr.c	(Arbeitskopie)
@@ -2188,12 +2188,25 @@
 gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
 {
   gfc_symbol *sym;
+  gfc_ref *ref;
+  int has_pointer;
 
   sym = lvalue->symtree->n.sym;
 
-  if (sym->attr.intent == INTENT_IN)
+  /* Check INTENT(IN), unless the object itself of higher up in the
+     hierarchy is a pointer.  */
+  has_pointer = sym->attr.pointer;
+
+  for (ref = lvalue->ref; ref; ref = ref->next)
+    if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
+      {
+	has_pointer = 1;
+	break;
+      }
+
+  if (!has_pointer && sym->attr.intent == INTENT_IN)
     {
-      gfc_error ("Can't assign to INTENT(IN) variable '%s' at %L",
+      gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
 		 sym->name, &lvalue->where);
       return FAILURE;
     }
@@ -2318,7 +2331,9 @@
 gfc_check_pointer_assign (gfc_expr * lvalue, gfc_expr * rvalue)
 {
   symbol_attribute attr;
+  gfc_ref *ref;
   int is_pure;
+  int pointer, check_intent_in;
 
   if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN)
     {
@@ -2336,8 +2351,29 @@
       return FAILURE;
     }
 
-  attr = gfc_variable_attr (lvalue, NULL);
-  if (!attr.pointer)
+
+  /* Check INTENT(IN), unless the object itself of higher up in the
+     hierarchy is a pointer.  */
+  check_intent_in = 1;
+  pointer = lvalue->symtree->n.sym->attr.pointer;
+
+  for (ref = lvalue->ref; ref; ref = ref->next)
+    {
+      if (pointer)
+        check_intent_in = 0;
+
+      if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
+        pointer = 1;
+    }
+
+  if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
+    {
+      gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
+                 lvalue->symtree->n.sym->name, &lvalue->where);
+      return FAILURE;
+    }
+
+  if (!pointer)
     {
       gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
       return FAILURE;
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(Revision 119993)
+++ gcc/fortran/resolve.c	(Arbeitskopie)
@@ -3318,48 +3318,58 @@
 resolve_deallocate_expr (gfc_expr * e)
 {
   symbol_attribute attr;
-  int allocatable;
+  int allocatable, pointer, check_intent_in;
   gfc_ref *ref;
 
+  /* Check INTENT(IN), unless an object higher up in the
+     hierarchy is a pointer.  */
+  check_intent_in = 1;
+
   if (gfc_resolve_expr (e) == FAILURE)
     return FAILURE;
 
-  attr = gfc_expr_attr (e);
-  if (attr.pointer)
-    return SUCCESS;
-
   if (e->expr_type != EXPR_VARIABLE)
     goto bad;
 
   allocatable = e->symtree->n.sym->attr.allocatable;
+  pointer = e->symtree->n.sym->attr.pointer;
   for (ref = e->ref; ref; ref = ref->next)
-    switch (ref->type)
-      {
-      case REF_ARRAY:
-	if (ref->u.ar.type != AR_FULL)
-	  allocatable = 0;
-	break;
+    {
+      if (pointer)
+        check_intent_in = 0;
 
-      case REF_COMPONENT:
-	allocatable = (ref->u.c.component->as != NULL
-		       && ref->u.c.component->as->type == AS_DEFERRED);
-	break;
+      switch (ref->type)
+        {
+        case REF_ARRAY:
+	  if (ref->u.ar.type != AR_FULL)
+	    allocatable = 0;
+	  break;
 
-      case REF_SUBSTRING:
-	allocatable = 0;
-	break;
-      }
+        case REF_COMPONENT:
+	  allocatable = (ref->u.c.component->as != NULL
+		         && ref->u.c.component->as->type == AS_DEFERRED);
+	  pointer = ref->u.c.component->pointer;
+	  break;
+
+        case REF_SUBSTRING:
+	  allocatable = 0;
+	  break;
+        }
+    }
 
-  if (allocatable == 0)
+  attr = gfc_expr_attr (e);
+
+  if (allocatable == 0 && attr.pointer == 0)
     {
     bad:
       gfc_error ("Expression in DEALLOCATE statement at %L must be "
 		 "ALLOCATABLE or a POINTER", &e->where);
     }
 
-  if (e->symtree->n.sym->attr.intent == INTENT_IN)
+  if (check_intent_in
+      && e->symtree->n.sym->attr.intent == INTENT_IN)
     {
-      gfc_error ("Can't deallocate INTENT(IN) variable '%s' at %L",
+      gfc_error ("Cannot deallocate INTENT(IN) variable '%s' at %L",
                  e->symtree->n.sym->name, &e->where);
       return FAILURE;
     }
@@ -3481,7 +3491,7 @@
 static try
 resolve_allocate_expr (gfc_expr * e, gfc_code * code)
 {
-  int i, pointer, allocatable, dimension;
+  int i, pointer, allocatable, dimension, check_intent_in;
   symbol_attribute attr;
   gfc_ref *ref, *ref2;
   gfc_array_ref *ar;
@@ -3490,6 +3500,10 @@
   gfc_symbol *sym;
   gfc_alloc *a;
 
+  /* Check INTENT(IN), unless an object higher up in the
+     hierarchy is a pointer.  */
+  check_intent_in = 1;
+
   if (gfc_resolve_expr (e) == FAILURE)
     return FAILURE;
 
@@ -3527,26 +3541,31 @@
 	}
 
       for (ref = e->ref; ref; ref2 = ref, ref = ref->next)
-	switch (ref->type)
-	  {
-	  case REF_ARRAY:
-	    if (ref->next != NULL)
-	      pointer = 0;
-	    break;
-
-	  case REF_COMPONENT:
-	    allocatable = (ref->u.c.component->as != NULL
-			   && ref->u.c.component->as->type == AS_DEFERRED);
-
-	    pointer = ref->u.c.component->pointer;
-	    dimension = ref->u.c.component->dimension;
-	    break;
+        {
+	  if (pointer)
+	    check_intent_in = 0;
 
-	  case REF_SUBSTRING:
-	    allocatable = 0;
-	    pointer = 0;
-	    break;
-	  }
+	  switch (ref->type)
+	    {
+ 	      case REF_ARRAY:
+	        if (ref->next != NULL)
+	          pointer = 0;
+	        break;
+
+	      case REF_COMPONENT:
+	        allocatable = (ref->u.c.component->as != NULL
+			      && ref->u.c.component->as->type == AS_DEFERRED);
+
+	        pointer = ref->u.c.component->pointer;
+	        dimension = ref->u.c.component->dimension;
+	        break;
+
+	      case REF_SUBSTRING:
+	        allocatable = 0;
+	        pointer = 0;
+	        break;
+	    }
+       }
     }
 
   if (allocatable == 0 && pointer == 0)
@@ -3556,9 +3575,10 @@
       return FAILURE;
     }
 
-  if (e->symtree->n.sym->attr.intent == INTENT_IN)
+  if (check_intent_in
+      && e->symtree->n.sym->attr.intent == INTENT_IN)
     {
-      gfc_error ("Can't allocate INTENT(IN) variable '%s' at %L",
+      gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L",
                  e->symtree->n.sym->name, &e->where);
       return FAILURE;
     }
Index: gcc/testsuite/gfortran.dg/protected_4.f90
===================================================================
--- gcc/testsuite/gfortran.dg/protected_4.f90	(Revision 119989)
+++ gcc/testsuite/gfortran.dg/protected_4.f90	(Arbeitskopie)
@@ -21,6 +21,7 @@
   use protmod
   implicit none
   integer   :: j 
+  logical   :: asgnd
   protected :: j ! { dg-error "only allowed in specification part of a module" }
   a = 43       ! { dg-error "Assigning to PROTECTED variable" }
   ap => null() ! { dg-error "Assigning to PROTECTED variable" }
@@ -30,6 +31,8 @@
   allocate(ap) ! { dg-error "Assigning to PROTECTED variable" }
   ap = 73      ! { dg-error "Assigning to PROTECTED variable" }
   call increment(a,at) ! { dg-error "use-associated with PROTECTED attribute" }
+  call pointer_assignments(ap) ! { dg-error "is use-associated with PROTECTED attribute" }
+  asgnd = pointer_check(ap)
 contains
   subroutine increment(a1,a3)
     integer, intent(inout) :: a1, a3
@@ -37,9 +40,14 @@
     a3 = a3 + 1
   end subroutine increment
   subroutine pointer_assignments(p)
-    integer, pointer :: p ! with [pointer] intent(out)
-    p => null()           ! this is invalid
+    integer, pointer,intent(out) :: p
+    p => null()           
   end subroutine pointer_assignments
+  function pointer_check(p)
+    integer, pointer,intent(in) :: p
+    logical :: pointer_check
+    pointer_check = associated(p)
+  end function pointer_check
 end program main
 
 module test
Index: gcc/testsuite/gfortran.dg/protected_6.f90
===================================================================
--- gcc/testsuite/gfortran.dg/protected_6.f90	(Revision 119989)
+++ gcc/testsuite/gfortran.dg/protected_6.f90	(Arbeitskopie)
@@ -27,6 +27,7 @@
   allocate(ap) ! { dg-error "Assigning to PROTECTED variable" }
   ap = 73      ! { dg-error "Assigning to PROTECTED variable" }
   call increment(a,at) ! { dg-error "use-associated with PROTECTED attribute" }
+  call pointer_assignments(ap) ! { dg-error "is use-associated with PROTECTED attribute" }
 contains
   subroutine increment(a1,a3)
     integer, intent(inout) :: a1, a3
@@ -34,8 +35,8 @@
     a3 = a3 + 1
   end subroutine increment
   subroutine pointer_assignments(p)
-    integer, pointer :: p ! with [pointer] intent(out)
-    p => null()           ! this is invalid
+    integer, pointer,intent (inout) :: p
+    p => null()
   end subroutine pointer_assignments
 end program main
 
Index: gcc/testsuite/gfortran.dg/alloc_alloc_expr_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/alloc_alloc_expr_1.f90	(Revision 119989)
+++ gcc/testsuite/gfortran.dg/alloc_alloc_expr_1.f90	(Arbeitskopie)
@@ -24,6 +24,8 @@
 
   ALLOCATE(PTR,ALLOCS(PTR)) ! { dg-error "same ALLOCATE statement" }
 
-  print *, 'This program has three errors', PTR, ALLOC(1)
+  deallocate(ALLOCS(1)) ! { dg-error "must be ALLOCATABLE or a POINTER" }
+
+  print *, 'This program has four errors', PTR, ALLOC(1)
 
 end program fc011
Index: gcc/testsuite/gfortran.dg/allocatable_dummy_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/allocatable_dummy_2.f90	(Revision 119989)
+++ gcc/testsuite/gfortran.dg/allocatable_dummy_2.f90	(Arbeitskopie)
@@ -16,13 +16,13 @@
     subroutine init2(x)
         integer, allocatable, intent(in) :: x(:)
 
-        allocate(x(3)) ! { dg-error "Can't allocate" }
+        allocate(x(3)) ! { dg-error "Cannot allocate" }
     end subroutine init2
 
     subroutine kill(x)
         integer, allocatable, intent(in) :: x(:)
         
-        deallocate(x) ! { dg-error "Can't deallocate" }
+        deallocate(x) ! { dg-error "Cannot deallocate" }
     end subroutine kill
 
 end program alloc_dummy
Index: gcc/testsuite/gfortran.dg/pointer_intent_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pointer_intent_1.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/pointer_intent_1.f90	(Revision 0)
@@ -0,0 +1,71 @@
+! { dg-run }
+! { dg-options "-std=f2003 -fall-intrinsics" }
+! Pointer intent test
+! PR fortran/29624
+!
+! Valid program
+program test
+ implicit none
+ type myT
+   integer          :: x
+   integer, pointer :: point
+ end type myT
+ integer, pointer :: p
+ type(myT), pointer :: t
+ type(myT) :: t2
+ allocate(p,t)
+ allocate(t%point)
+ t%point = 55
+ p = 33
+ call a(p,t)
+ deallocate(p)
+ nullify(p)
+ call a(p,t)
+ call nonpointer(t2)
+contains
+  subroutine a(p,t)
+    integer, pointer,intent(in)    :: p
+    type(myT), pointer, intent(in) :: t
+    integer, pointer :: tmp
+    if(.not.associated(p)) return
+    if(p /= 33) call abort()
+    p = 7
+    if (associated(t)) then
+      ! allocating is valid as we don't change the status
+      ! of the pointer "t", only of it's target
+      t%x = -15
+      if(.not.associated(t%point)) call abort()
+      if(t%point /= 55) call abort()
+      nullify(t%point)
+      allocate(tmp)
+      t%point => tmp
+      deallocate(t%point)
+      t%point => null(t%point)
+      tmp => null(tmp)
+      allocate(t%point)
+      t%point = 27
+      if(t%point /= 27) call abort()
+      if(t%x     /= -15) call abort()
+      call foo(t)
+      if(t%x     /=  32) call abort()
+      if(t%point /= -98) call abort()
+    end if
+    call b(p)
+    if(p /= 5) call abort()
+  end subroutine
+  subroutine b(v)
+    integer, intent(out) :: v
+    v = 5
+  end subroutine b
+  subroutine foo(comp)
+    type(myT), intent(inout) :: comp
+    if(comp%x     /= -15) call abort()
+    !if(comp%point /=  27) call abort()
+    comp%x     = 32
+    comp%point = -98
+  end subroutine foo
+  subroutine nonpointer(t)
+     type(myT), intent(in) :: t
+     t%point = 7
+  end subroutine nonpointer
+end program
Index: gcc/testsuite/gfortran.dg/pointer_intent_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pointer_intent_2.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/pointer_intent_2.f90	(Revision 0)
@@ -0,0 +1,19 @@
+! { dg-compile }
+! { dg-options "-std=f95" }
+! { dg-shouldfail "Fortran 2003 feature with -std=f95" }
+!
+! Pointer intent test
+! PR fortran/29624
+!
+! Fortran 2003 features in Fortran 95
+program test
+ implicit none
+ integer, pointer :: p
+ allocate(p)
+ p = 33
+ call a(p) ! { dg-error "Type/rank mismatch in argument" }
+contains
+  subroutine a(p)! { dg-error "has no IMPLICIT type" }
+    integer, pointer,intent(in) :: p ! { dg-error "POINTER attribute with INTENT attribute" }
+  end subroutine
+end program
Index: gcc/testsuite/gfortran.dg/pointer_intent_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pointer_intent_3.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/pointer_intent_3.f90	(Revision 0)
@@ -0,0 +1,41 @@
+! { dg-compile }
+! { dg-options "-std=f2003 -fall-intrinsics" }
+! { dg-shouldfail "Invalid code" }
+!
+! Pointer intent test
+! PR fortran/29624
+!
+! Valid program
+program test
+ implicit none
+ type myT
+    integer :: j = 5
+    integer, pointer :: jp => null()
+ end type myT
+ integer, pointer :: p
+ type(myT) :: t
+ call a(p)
+ call b(t)
+contains
+  subroutine a(p)
+    integer, pointer,intent(in) :: p
+    p => null(p)! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
+    nullify(p)  ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
+    allocate(p) ! { dg-error "Cannot allocate INTENT\\(IN\\) variable" }
+    call c(p)   ! { dg-error "is INTENT\\(IN\\) while interface specifies INTENT\\(INOUT\\)" }
+    deallocate(p) ! { dg-error "Cannot deallocate INTENT\\(IN\\) variable" }
+  end subroutine
+  subroutine c(p)
+    integer, pointer, intent(inout) :: p
+    nullify(p)
+  end subroutine c
+  subroutine b(t)
+    type(myT),intent(in) :: t
+    t%jp = 5
+    t%jp => null(t%jp)  ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
+    nullify(t%jp) ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
+    t%j = 7 ! { dg-error "Cannot assign to INTENT\\(IN\\) variable" }
+    allocate(t%jp) ! { dg-error "Cannot allocate INTENT\\(IN\\) variable" }
+    deallocate(t%jp) ! { dg-error "Cannot deallocate INTENT\\(IN\\) variable" }
+  end subroutine b
+end program

Re: [patches,fortran] Add POINTER INTENT(*) support (PR29624)

[Paul Thomas]

Tobias,
>> Regression tested on x86_64-unknown-linux-gnu.
>>     
OK with a couple of questions/niggles....
>>  
>> +/* Given a symbol of a formal argument list and an expression, see if
>> +   their intents are compatible.  Returns nonzero if compatible,
>> +   zero if not compatible.  */
>> +
>>     
"Given a symbol of a formal argument list and an expression, return 
non-zero if their intents are compatible, zero otherwise." is a bit more 
concise.
>> -      return gfc_notify_std (standard, "In the selected standard, %s attribute "
>> -                             "conflicts with %s attribute at %L", a1, a2,
>> -                             where);
>> +      return gfc_notify_std (standard, "%s: %s attribute with %s attribute "
>> +                             "at %L",
>> +                             (standard == GFC_STD_F2003)
>> +                               ? "Fortran 2003" : "Not in the selected standard",
>> +                             a1, a2, where);
>>  
Is the language support OK with this? I seem to recall that we had some 
problems with computed messages.
>> +  /* Check INTENT(IN), unless the object itself of higher up in the
>> +     hierarchy is a pointer.  */
>>     
Not only is the symtax a bit odd but I think that , "unless the object 
itself is the component or sub-component of a pointer." is clearer.
>> +
>> +  /* Check INTENT(IN), unless the object itself of higher up in the
>> +     hierarchy is a pointer.  */
>>     
ditto
>>  
>> +  /* Check INTENT(IN), unless an object higher up in the
>> +     hierarchy is a pointer.  */
>>     
ditto**2

Thanks!

Paul

Re: [patches,fortran] Add POINTER INTENT(*) support (PR29624)

[Tobias Burnus]

Hi,

Paul Thomas wrote:
> OK with a couple of questions/niggles....

>>> +      return gfc_notify_std (standard, "%s: %s attribute with %s
>>> attribute "
>>> +                             "at %L",
>>> +                             (standard == GFC_STD_F2003)
>>> +                               ? "Fortran 2003" : "Not in the
>>> selected standard",
>>> +                             a1, a2, where); 
> Is the language support OK with this? I seem to recall that we had
> some problems with computed messages.

I don't know. As (standard == GFC_STD_F2003) is currently always true
and the translation of "Fortran 2003" does not depend on the context, it
should be ok, except that the translator does not know what the first
"%s:" means.
Due to the colon, it should be also ok for "Not in the selected
standard", which makes it effectively two sentences.

But I'm not a specialist for l18n/i10n.
(Really problematic are strings like
  "There are %s items missing", (x?"one" : "two")
as the translation of "one" is context dependent, e.g. French
"un"/"une", German "ein"/"eine"/"eins")

I'll submit it tomorrow as above, unless someone objects or has a better
suggestion.


>>> +  /* Check INTENT(IN), unless the object itself of higher up in the
>>> +     hierarchy is a pointer.  */
>>>     
> Not only is the symtax a bit odd but I think that , "unless the object
> itself is the component or sub-component of a pointer." is clearer.
(I should have re-read the comments, the syntax is odd indeed; even with
"or" it is barely decipherable.)

> Thanks!
Thanks for reviewing the patch!

Tobias

Re: [patches,fortran] Add POINTER INTENT(*) support (PR29624)

[Brooks Moses]

Tobias Burnus wrote:
>>>> +      return gfc_notify_std (standard, "%s: %s attribute with %s
>>>> attribute "
>>>> +                             "at %L",
>>>> +                             (standard == GFC_STD_F2003)
>>>> +                               ? "Fortran 2003" : "Not in the
>>>> selected standard",
>>>> +                             a1, a2, where); 
>> Is the language support OK with this? I seem to recall that we had
>> some problems with computed messages.
> 
> I don't know. As (standard == GFC_STD_F2003) is currently always true
> and the translation of "Fortran 2003" does not depend on the context, it
> should be ok, except that the translator does not know what the first
> "%s:" means.
> Due to the colon, it should be also ok for "Not in the selected
> standard", which makes it effectively two sentences.
[...]
> I'll submit it tomorrow as above, unless someone objects or has a better
> suggestion.

I would almost suggest it would be clearer to do something like:

--------------------------------------------------------------------
if (standard == GFC_STD_F2003) {
   return gfc_notify_std (standard, "Fortran 2003: %s attribute with %s "
                          "attribute at %L",
                          a1, a2, where);
} else {
   return gfc_notify_std (standard, "Not in the selected standard: %s "
                          "attribute with %s attribute at %L",
                          a1, a2, where);
}
--------------------------------------------------------------------

However, I think a much more appropriate thing to do is to modify 
gfc_notify_std to handle this sort of thing correctly automatically, so 
that we could just do this:

return gfc_notify_std (standard,
                        "%s attribute with %s attribute at %L",
                        a1, a2, where);

For now, though, I would think that just using the "Fortran 2003:" 
version in all cases should be sufficient -- if something gets flagged 
in an error message as "Fortran 2003", it should be sufficiently clear 
that it's not in the Fortran 95 standard.

- Brooks

Re: [patches,fortran] Add POINTER INTENT(*) support (PR29624)

[Tobias Burnus]

Brooks Moses wrote:
> However, I think a much more appropriate thing to do is to modify
> gfc_notify_std to handle this sort of thing correctly automatically
Good idea!

> For now, though, I would think that just using the "Fortran 2003:"
> version in all cases should be sufficient -- if something gets flagged
> in an error message as "Fortran 2003", it should be sufficiently clear
> that it's not in the Fortran 95 standard.
I use now the "Fortran 2003: %s ..." alternative. (Checked in as r120472.)

Thanks,

Tobias