[Patch, fortran] PR27122 - requirements for defined operators -redux

[Paul Thomas <paulthomas2 at wanadoo dot fr>]

Tobi has very kindly, given his present commitments, taken a look at 
this patch and has given me plenty of feedback, off-list.

Most significantly, he questioned the principle of a separate test for 
defined operators, given the working mechanism for handling intrinsic 
operators.  I was greatly surprised by this too but it turns out that 
this is required, if only because these different kinds of operator hang 
onto different fields of gfc_namespace (uop_root and operators[], 
respectively).  I stand by my statement that defined operators are not 
checked in gfortran, at present.

Beyond the basic principle, Tobi alighted upon typos and stylistic 
"inexactitudes" that require me to resubmit.  To this end, please find 
attached the revised patch and testcase.  The ChangeLog entries remain 
the same.

Regtested on FC5/Athlon.

If I do not hear anything in the next 24 hours, I will submit to trunk.  
There will then follow a two week hiatus before I can submit to 4.1.

Thanks, Tobi!

Paul

2006-04-20 Paul Thomas <pault@gcc.gnu.org>

	PR fortran/27122
	* resolve.c (resolve_function): Remove general restriction on auto
	character length function interfaces.
	(gfc_resolve_uops): Check restrictions on defined operator
	procedures.
	(resolve_types): Call the check for defined operators.

2006-04-20 Paul Thomas <pault@gcc.gnu.org>

	PR fortran/27122
	* gfortran.dg/defined_operators_1.f90: New test.
	* gfortran.dg/assumed_charlen_function_1.f90: Add new error and
	remove old ones associated, incorrectly with Note 5.46.


Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 113122)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_function (gfc_expr * expr)
*** 1237,1264 ****
    need_full_assumed_size--;
  
    if (sym && sym->ts.type == BT_CHARACTER
! 	  && sym->ts.cl && sym->ts.cl->length == NULL)
      {
-       if (sym->attr.if_source == IFSRC_IFBODY)
- 	{
- 	  /* This follows from a slightly odd requirement at 5.1.1.5 in the
- 	     standard that allows assumed character length functions to be
- 	     declared in interfaces but not used.  Picking up the symbol here,
- 	     rather than resolve_symbol, accomplishes that.  */
- 	  gfc_error ("Function '%s' can be declared in an interface to "
- 		     "return CHARACTER(*) but cannot be used at %L",
- 		     sym->name, &expr->where);
- 	  return FAILURE;
- 	}
- 
        /* Internal procedures are taken care of in resolve_contained_fntype.  */
!       if (!sym->attr.dummy && !sym->attr.contained)
! 	{
! 	  gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
! 		     "be used at %L since it is not a dummy argument",
! 		     sym->name, &expr->where);
! 	  return FAILURE;
! 	}
      }
  
  /* See if function is already resolved.  */
--- 1237,1252 ----
    need_full_assumed_size--;
  
    if (sym && sym->ts.type == BT_CHARACTER
! 	&& sym->ts.cl
! 	&& sym->ts.cl->length == NULL
! 	&& !sym->attr.dummy
! 	&& !sym->attr.contained)
      {
        /* Internal procedures are taken care of in resolve_contained_fntype.  */
!       gfc_error ("Function '%s' is declared CHARACTER(*) and cannot "
! 		 "be used at %L since it is not a dummy argument",
! 		 sym->name, &expr->where);
!       return FAILURE;
      }
  
  /* See if function is already resolved.  */
*************** resolve_fntype (gfc_namespace * ns)
*** 6105,6110 ****
--- 6093,6160 ----
        }
  }
  
+ /* 12.3.2.1.1 Defined operators.  */
+ 
+ static void
+ gfc_resolve_uops(gfc_symtree *symtree)
+ {
+   gfc_interface *itr;
+   gfc_symbol *sym;
+   gfc_formal_arglist *formal;
+ 
+   if (symtree == NULL) 
+     return; 
+  
+   gfc_resolve_uops (symtree->left);
+   gfc_resolve_uops (symtree->right);
+ 
+   for (itr = symtree->n.uop->operator; itr; itr = itr->next)
+     {
+       sym = itr->sym;
+       if (!sym->attr.function)
+ 	gfc_error("User operator procedure '%s' at %L must be a FUNCTION",
+ 		  sym->name, &sym->declared_at);
+ 
+       if (sym->ts.type == BT_CHARACTER
+ 	    && !(sym->ts.cl && sym->ts.cl->length)
+ 	    && !(sym->result && sym->result->ts.cl && sym->result->ts.cl->length))
+ 	gfc_error("User operator procedure '%s' at %L cannot be assumed character "
+ 		  "length", sym->name, &sym->declared_at);
+ 
+       formal = sym->formal;
+       if (!formal || !formal->sym)
+ 	{
+ 	  gfc_error("User operator procedure '%s' at %L must have at least "
+ 		    "one argument", sym->name, &sym->declared_at);
+ 	  continue;
+ 	}
+ 
+       if (formal->sym->attr.intent != INTENT_IN)
+ 	gfc_error ("First argument of operator interface at %L must be "
+ 		   "INTENT(IN)", &sym->declared_at);
+ 
+       if (formal->sym->attr.optional)
+ 	gfc_error ("First argument of operator interface at %L cannot be "
+ 		   "optional", &sym->declared_at);
+ 
+       formal = formal->next;
+       if (!formal || !formal->sym)
+ 	continue;
+ 
+       if (formal->sym->attr.intent != INTENT_IN)
+ 	gfc_error ("Second argument of operator interface at %L must be "
+ 		   "INTENT(IN)", &sym->declared_at);
+ 
+       if (formal->sym->attr.optional)
+ 	gfc_error ("Second argument of operator interface at %L cannot be "
+ 		   "optional", &sym->declared_at);
+ 
+       if (formal->next)
+ 	gfc_error ("Operator interface at %L must have, at most, two "
+ 		   "arguments", &sym->declared_at);
+     }
+ }
+ 
  
  /* Examine all of the expressions associated with a program unit,
     assign types to all intermediate expressions, make sure that all
*************** resolve_types (gfc_namespace * ns)
*** 6164,6169 ****
--- 6214,6222 ----
    /* Warn about unused labels.  */
    if (gfc_option.warn_unused_labels)
      warn_unused_label (ns->st_labels);
+ 
+   gfc_resolve_uops (ns->uop_root);
+     
  }
  
  

! { dg-do compile }
! { dg-options "-std=legacy" }
! Tests the fix for PR27122, in which the requirements of 12.3.2.1.1
! for defined operators were not enforced.
! 
! Based on PR test by Thomas Koenig  <tkoenig@gcc.gnu.org>
!
module mymod
  interface operator (.foo.)
     module procedure foo_0 ! { dg-error "must have at least one argument" }
     module procedure foo_1 ! { dg-error "must be INTENT" }
     module procedure foo_2 ! { dg-error "cannot be optional" }
     module procedure foo_3 ! { dg-error "must have, at most, two arguments" }
     module procedure foo_1_OK
     module procedure foo_2_OK
     function foo_chr (chr) ! { dg-error "cannot be assumed character length" }
      character(*) :: foo_chr
      character(*), intent(in) :: chr
     end function foo_chr
  end interface
contains
  function foo_0 ()
    integer :: foo_1
    foo_0 = 1
  end function foo_0
  function foo_1 (a)
    integer :: foo_1
    integer :: a
    foo_1 = 1
  end function foo_1
  function foo_1_OK (a)
    integer :: foo_1_OK
    integer, intent (in) :: a
    foo_1_OK = 1
  end function foo_1_OK
  function foo_2 (a, b)
    integer :: foo_2
    integer, intent(in) :: a
    integer, intent(in), optional :: b
    foo_2 = 2 * a + b
  end function foo_2
  function foo_2_OK (a, b)
    real :: foo_2_OK
    real, intent(in) :: a
    real, intent(in) :: b
    foo_2_OK = 2.0 * a + b
  end function foo_2_OK
  function foo_3 (a, b, c)
    integer :: foo_3
    integer, intent(in) :: a, b, c
    foo_3 = a + 3 * b - c
  end function foo_3
end module mymod