Re: PROCEDURE declarations

["Janus Weil" <jaydub66 at googlemail dot com>]

> And the following is a module with a generic specification
> ("operator(...)" or "assignment(=)"), but gfortran rejects it:
>
> module X
> interface
>   function foo(a)
>     integer,intent(in) :: a
>     integer :: foo
>   end function foo
> end interface
> interface operator(.bar.)
>   procedure foo
> end interface
> end module X
> end

I already realized myself that my previous checking for C1204 was a
bit simple-minded. Fixed now (new patch is attached).


> The following is valid but one gets a bogus error message:
> Error: Symbol at (1) is not a DUMMY variable
>
> subroutine bar(a,b)
> implicit none
> interface
>   subroutine a()
>   end subroutine a
> end interface
> optional ::  a
> procedure(a), optional :: b
> end subroutine bar
>
> The binding name is wrong in the following as a is a DUMMY.
>
> subroutine foo(a)
>   abstract interface
>     subroutine b() bind(C)
>     end subroutine b
>   end interface
>   procedure(b), bind(c,name="hjj") :: a
> end subroutine foo

This I had also noticed before. There was a bug with dummy procedures
which is fixed now. So dummy procedures should work. I've also
completed my checking for C1217, which catches the error in the second
piece of code.


> Some more bugs. The following is invalid as one imports a symbol twice;
> nonetheless gfortran accepts it:
>
> interface
>   subroutine foo()
>   end subroutine foo
> end interface
> ! NAG f95:  ERROR: Duplicate subprogram name FOO
> procedure(foo) :: foo
> end
>
> The following is invalid, but not rejected:
>
> subroutine bar(a)
> implicit none
> interface
>   subroutine a()
>   end subroutine a
> end interface
> interface nn
>   procedure a, a
>   procedure a
> end interface
> end subroutine bar
>
> Using "module procedure a, a" one already gets the error message:
>
> Error: Entity 'a' at (1) is already present in the interface

With my recent patch I do get at least some error message for these two:

procedure(foo) :: foo
                    1
Error: PROCEDURE attribute of 'foo' conflicts with PROCEDURE attribute at (1)

and

 procedure a, a
              1
Error: PROCEDURE attribute of 'a' conflicts with PROCEDURE attribute at (1)

But the message is rather confusing. I'll investigate this a little more ...


> The following is invalid as there is no *explicit* interface for foo,
> but it is accepted by gfortran
>
> module X
> external foo
> interface nn
>   procedure foo
> end interface
> end module X
> end
>
> NAG f95: FOO does not have an explicit interface

I haven't tried to fix this, but will do.


> I would suggest that you reject "PROCEDURE(func)" where "func" is an
> intrinsic procedure; I think one can not quickly fix it and currently it
> does not work at all or wrongly. I filled PR 33162 to track this. (There
> are other problems with error checking as well.)

Ok. What would be the best way to do this? Should I introduce some
"gfc_is_intrinsic_procedure" analogous to the
"gfc_is_intrinsic_typename" from the abstract interface patch? Or does
something like this exist already? Or is there a better way?


> Otherwise, I have the feeling, PROCEDUREs (w/o procedure in TYPE,
> procedure pointers and the mess mentioned below) are almost ready :-)

Yeah, I hope we can get this finished until next week or so. And maybe
we can even get procedure pointers or type-bound procedures into 4.3.
I think for pointers there is really not a lot left to do, because
basically all the syntax is already there. In principle only the
pointer assignment is missing. For type-bound procedures there is some
more syntax to implement, e.g. "CONTAINS" in types, the PASS/NOPASS
attributes etc. So probably it's still a bit of work.
Cheers,
Janus

Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 127742)
+++ gcc/fortran/symbol.c	(working copy)
@@ -3532,6 +3532,61 @@ add_proc_interface (gfc_symbol *sym, ifs
   sym->attr.if_source = source;
 }
 
+/* Copy the formal args from an existing symbol, src, into a new
+   symbol, dest.  New formal args are created, and the description of
+   each arg is set according to the existing ones.  This function is
+   used when creating procedure declaration variables from a procedure
+   declaration statement (see match_proc_decl()) to create the formal
+   args based on the args of a given named interface.  */
+
+void copy_formal_args (gfc_symbol *dest, gfc_symbol *src)
+{
+  gfc_formal_arglist *head = NULL;
+  gfc_formal_arglist *tail = NULL;
+  gfc_formal_arglist *formal_arg = NULL;
+  gfc_formal_arglist *curr_arg = NULL;
+  gfc_formal_arglist *formal_prev = NULL;
+  /* Save current namespace so we can change it for formal args.  */
+  gfc_namespace *parent_ns = gfc_current_ns;
+
+  /* Create a new namespace, which will be the formal ns (namespace
+     of the formal args).  */
+  gfc_current_ns = gfc_get_namespace (parent_ns, 0);
+  gfc_current_ns->proc_name = dest;
+
+  for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
+    {
+      formal_arg = gfc_get_formal_arglist ();
+      gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym));
+
+      /* May need to copy more info for the symbol.  */
+      formal_arg->sym->attr = curr_arg->sym->attr;
+      formal_arg->sym->ts = curr_arg->sym->ts;
+
+      /* If this isn't the first arg, set up the next ptr.  For the
+        last arg built, the formal_arg->next will never get set to
+        anything other than NULL.  */
+      if (formal_prev != NULL)
+	formal_prev->next = formal_arg;
+      else
+	formal_arg->next = NULL;
+
+      formal_prev = formal_arg;
+
+      /* Add arg to list of formal args.  */
+      add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
+    }
+
+  /* Add the interface to the symbol.  */
+  add_proc_interface (dest, IFSRC_DECL, head);
+
+  /* Store the formal namespace information.  */
+  if (dest->formal != NULL)
+    /* The current ns should be that for the dest proc.  */
+    dest->formal_ns = gfc_current_ns;
+  /* Restore the current namespace to what it was on entry.  */
+  gfc_current_ns = parent_ns;
+}
 
 /* Builds the parameter list for the iso_c_binding procedure
    c_f_pointer or c_f_procpointer.  The old_sym typically refers to a
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 127742)
+++ gcc/fortran/decl.c	(working copy)
@@ -3631,6 +3631,203 @@ gfc_match_suffix (gfc_symbol *sym, gfc_s
 }
 
 
+/* Match a procedure declaration.  */
+
+match
+gfc_match_procedure (void)
+{
+  gfc_symbol *sym, *proc_if = NULL;
+  locus old_loc, entry_loc;
+  match m;
+  int i,num;
+  char *src_attr,*dest_attr;
+
+  old_loc = entry_loc = gfc_current_locus;
+
+  if (gfc_current_state () != COMP_NONE
+    && gfc_current_state () != COMP_PROGRAM
+    && gfc_current_state () != COMP_MODULE
+    && gfc_current_state () != COMP_SUBROUTINE
+    && gfc_current_state () != COMP_FUNCTION
+    && gfc_current_state () != COMP_INTERFACE
+    && gfc_current_state () != COMP_DERIVED)
+    return MATCH_NO;
+
+  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROCEDURE statement at %C")
+      == FAILURE)
+    return MATCH_ERROR;
+
+  if (gfc_current_state () == COMP_INTERFACE)
+    {
+      if (current_interface.type == INTERFACE_NAMELESS
+	  || current_interface.type == INTERFACE_ABSTRACT)
+	{
+	  gfc_error ("PROCEDURE at %C must be in a generic interface");
+	  return MATCH_ERROR;
+	}
+      goto got_attr;
+    }
+
+  gfc_clear_ts (&current_ts);
+
+  if (gfc_match (" (") != MATCH_YES)
+    {
+      gfc_current_locus = entry_loc;
+      return MATCH_NO;
+    }
+
+  /* Get the type spec. for the procedure interface.  */
+  old_loc = gfc_current_locus;
+  m = match_type_spec (&current_ts, 0);
+  if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_char () == ')'))
+    goto got_ts;
+
+  gfc_current_locus = old_loc;
+
+  /* Get the name of the procedure or abstract interface to inherit interface from.  */
+  m = gfc_match_symbol (&proc_if, 1);
+
+  if (m == MATCH_ERROR)
+    goto syntax;
+
+got_ts:
+
+  if (gfc_match (" )") != MATCH_YES)
+    {
+      gfc_current_locus = entry_loc;
+      return MATCH_NO;
+    }
+
+  /* Parse attributes.  */
+  m = match_attr_spec();
+  if (m == MATCH_ERROR)
+    return MATCH_ERROR;
+  /* Check for R1213.  */
+  if (current_attr.allocatable || current_attr.dimension
+      || current_attr.external || current_attr.intrinsic
+      || current_attr.protected|| current_attr.target
+      || current_attr.value || current_attr.volatile_)
+    {
+      gfc_error ("Illegal attributes at %C");
+      return MATCH_ERROR;
+    }
+  /* Check for C1214.  */
+  if (current_attr.intent && !current_attr.pointer)
+    {
+      gfc_error ("INTENT at %C requires POINTER attribute");
+      return MATCH_ERROR;
+    }
+  if (current_attr.save && !current_attr.pointer)
+    {
+      gfc_error ("SAVE at %C requires POINTER attribute");
+      return MATCH_ERROR;
+    }
+  /* Check for C1218.  */
+  if (current_attr.is_bind_c && (!proc_if || !proc_if->attr.is_bind_c))
+    {
+      gfc_error ("BIND(C) attribute requires an interface with BIND(C) at %C");
+      return MATCH_ERROR;
+    }
+  /* Check for C449.  */
+  if (gfc_current_state () == COMP_DERIVED && !current_attr.pointer)
+    {
+      gfc_error ("Procedure component must have POINTER attribute at %C");
+      return MATCH_ERROR;
+    }
+  /* TODO: Implement procedure pointers.  */
+  if (current_attr.pointer)
+    {
+      gfc_error ("Procedure pointers used at %C are not yet implemented");
+      return MATCH_ERROR;
+    }
+
+got_attr:
+
+  /* Get procedure symbols.  */
+  for(num=1;;num++)
+    {
+      m = gfc_match_symbol (&sym, 0);
+      
+      switch (m)
+	{
+	case MATCH_YES:
+
+	  /* Add current_attr to the symbol attributes.  */
+	  src_attr = (char *) (&(current_attr));
+	  dest_attr = (char *) (&(sym->attr));
+	  for (i = 0; i < (int) sizeof (sym->attr); i++)
+	    {
+	      *dest_attr = (*dest_attr) | (*src_attr);
+	      dest_attr++;
+	      src_attr++;
+	    }
+
+	  if (!sym->attr.pointer)
+	    sym->attr.external = 1;
+	  sym->attr.procedure = 1;
+
+	  if (sym->attr.is_bind_c)
+	    {
+	      /* Check for C1217.  */
+	      if (curr_binding_label[0] != '\0' && sym->attr.pointer)
+		{
+		  gfc_error ("BIND(C) procedure with NAME may not have"
+			    "POINTER attribute at %C");
+		  return MATCH_ERROR;
+		}
+	      if (curr_binding_label[0] != '\0' && sym->attr.dummy)
+		{
+		  gfc_error ("Dummy procedure at %C may not have"
+			    "BIND(C) attribute with NAME");
+		  return MATCH_ERROR;
+		}
+	      /* Set binding label for BIND(C).  */
+	      if (set_binding_label (sym->binding_label, sym->name, num) != SUCCESS)
+		return MATCH_ERROR;
+	    }
+
+	  /* Set interface.  */
+	  if (proc_if != NULL)
+	    sym->interface = proc_if;
+	  else if (current_ts.type != BT_UNKNOWN)
+	    {
+	      sym->interface = gfc_new_symbol ("",gfc_current_ns);
+	      sym->interface->ts = current_ts;
+	      sym->interface->attr.function = 1;
+	    }
+
+	  if (gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE)
+	    return MATCH_ERROR;
+
+	  goto next_item;
+
+	case MATCH_NO:
+	  break;
+
+	case MATCH_ERROR:
+	  return MATCH_ERROR;
+	}
+
+      next_item:
+	if (gfc_match_eos () == MATCH_YES)
+	  break;
+	if (gfc_match_char (',') != MATCH_YES)
+	  goto syntax;
+    }
+
+  return MATCH_YES;
+
+syntax:
+  gfc_error ("Syntax error in PROCEDURE statement at %C");
+  return MATCH_ERROR;
+#if 0
+cleanup:
+  gfc_current_locus = old_loc;
+  return m;
+#endif
+}
+
+
 /* Match a function declaration.  */
 
 match
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 127742)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -245,7 +245,7 @@ typedef enum
   ST_OMP_END_WORKSHARE, ST_OMP_DO, ST_OMP_FLUSH, ST_OMP_MASTER, ST_OMP_ORDERED,
   ST_OMP_PARALLEL, ST_OMP_PARALLEL_DO, ST_OMP_PARALLEL_SECTIONS,
   ST_OMP_PARALLEL_WORKSHARE, ST_OMP_SECTIONS, ST_OMP_SECTION, ST_OMP_SINGLE,
-  ST_OMP_THREADPRIVATE, ST_OMP_WORKSHARE,
+  ST_OMP_THREADPRIVATE, ST_OMP_WORKSHARE, ST_PROCEDURE,
   ST_NONE
 }
 gfc_statement;
@@ -640,7 +640,8 @@ typedef struct
     imported:1;			/* Symbol has been associated by IMPORT.  */
 
   unsigned in_namelist:1, in_common:1, in_equivalence:1;
-  unsigned function:1, subroutine:1, generic:1, generic_copy:1;
+  unsigned function:1, subroutine:1, procedure:1;
+  unsigned generic:1, generic_copy:1;
   unsigned implicit_type:1;	/* Type defined via implicit rules.  */
   unsigned untyped:1;           /* No implicit type could be found.  */
 
@@ -1012,6 +1013,8 @@ typedef struct gfc_symbol
   struct gfc_symbol *result;	/* function result symbol */
   gfc_component *components;	/* Derived type components */
 
+  struct gfc_symbol *interface;	/* For PROCEDURE declarations.  */
+
   /* Defined only for Cray pointees; points to their pointer.  */
   struct gfc_symbol *cp_pointer;
 
@@ -2160,6 +2163,8 @@ void gfc_symbol_state (void);
 gfc_gsymbol *gfc_get_gsymbol (const char *);
 gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
 
+void copy_formal_args (gfc_symbol *dest, gfc_symbol *src);
+
 /* intrinsic.c */
 extern int gfc_init_expr;
 
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 127742)
+++ gcc/fortran/resolve.c	(working copy)
@@ -1431,6 +1431,9 @@ resolve_specific_f0 (gfc_symbol *sym, gf
 {
   match m;
 
+  if (sym->attr.procedure)
+    goto found;
+
   if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
     {
       if (sym->attr.dummy)
@@ -7209,6 +7212,16 @@ resolve_symbol (gfc_symbol *sym)
 	}
     }
 
+  if (sym->attr.procedure && sym->interface)
+    {
+      /* Get the attributes from the interface (now resolved).  */
+      sym->ts = sym->interface->ts;
+      sym->attr.function = sym->interface->attr.function;
+      sym->attr.subroutine = sym->interface->attr.subroutine;
+      copy_formal_args (sym, sym->interface);
+      sym->attr.if_source = IFSRC_DECL;
+    }
+
   if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
     return;
 
Index: gcc/fortran/match.h
===================================================================
--- gcc/fortran/match.h	(revision 127742)
+++ gcc/fortran/match.h	(working copy)
@@ -134,6 +134,7 @@ match gfc_match_old_kind_spec (gfc_types
 match gfc_match_end (gfc_statement *);
 match gfc_match_data_decl (void);
 match gfc_match_formal_arglist (gfc_symbol *, int, int);
+match gfc_match_procedure (void);
 match gfc_match_function_decl (void);
 match gfc_match_entry (void);
 match gfc_match_subroutine (void);
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c	(revision 127742)
+++ gcc/fortran/parse.c	(working copy)
@@ -258,6 +258,7 @@ decode_statement (void)
       match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
       if (gfc_match_private (&st) == MATCH_YES)
 	return st;
+      match ("procedure", gfc_match_procedure, ST_PROCEDURE);
       match ("program", gfc_match_program, ST_PROGRAM);
       if (gfc_match_public (&st) == MATCH_YES)
 	return st;
@@ -719,7 +720,8 @@ next_statement (void)
 
 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
   case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
-  case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE
+  case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
+  case ST_PROCEDURE
 
 /* Block end statements.  Errors associated with interchanging these
    are detected in gfc_match_end().  */
@@ -1078,6 +1080,9 @@ gfc_ascii_statement (gfc_statement st)
     case ST_PROGRAM:
       p = "PROGRAM";
       break;
+    case ST_PROCEDURE:
+      p = "PROCEDURE";
+      break;
     case ST_READ:
       p = "READ";
       break;
@@ -1749,6 +1754,7 @@ loop:
 				  gfc_new_block->formal, NULL);
       break;
 
+    case ST_PROCEDURE:
     case ST_MODULE_PROC:	/* The module procedure matcher makes
 				   sure the context is correct.  */
       accept_statement (st);