PROCEDURE declarations

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

Hi all,
first of all I wanted to thanks both Tobias Burnus and Tobias Schlüter
for their great support and the quick approval of my abstract
interface patch. Since this one's out the door now, I will move on
with PROCEDURE declarations.
Attached you find the latest version of the patch. This one should
work with most of Tobias B.'s code samples, in particular it should
handle implicit interfaces, the PUBLIC attribute and procedures in
modules.
Please note that it still doesn't handle lots of attributes (e.g.
BIND(C) and others). I'm thinking about the best way to support all
attributes. Do you think I should use "match_attr_spec" for parsing
and check afterwards which ones are actually allowed in a PROCEDURE
context, or implement the parsing myself (as I do now)? I think the
former would be better, but I am not sure.
Tobias S. told me that my indenting in gfc_match_procedure was
"consistently non-gnuish", which I don't really understand. I thought
I got the indenting right by now. Can you please clarify? Also I
didn't quite get your comment about "missing vertical whitespace" in
the resolve_symbol hunk ...
I haven't managed to look at all of Tobias B.'s comments yet (which
are always very helpful and numerous ;), e.g. on C1212 and intrinsic
procedures, but will do that soon.
Cheers,
Janus

Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 127614)
+++ gcc/fortran/symbol.c	(working copy)
@@ -1370,7 +1370,8 @@ gfc_add_explicit_interface (gfc_symbol *
     where = &gfc_current_locus;
 
   if (sym->attr.if_source != IFSRC_UNKNOWN
-      && sym->attr.if_source != IFSRC_DECL)
+      && sym->attr.if_source != IFSRC_DECL
+      && sym->attr.procedure==0)
     {
       gfc_error ("Symbol '%s' at %L already has an explicit interface",
 		 sym->name, where);
@@ -3514,6 +3515,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 127614)
+++ gcc/fortran/decl.c	(working copy)
@@ -738,6 +738,7 @@ get_proc_name (const char *name, gfc_sym
       if (sym->ts.kind != 0
 	  && !sym->attr.implicit_type
 	  && sym->attr.proc == 0
+	  && sym->attr.procedure == 0
 	  && gfc_current_ns->parent != NULL
 	  && sym->attr.access == 0
 	  && !module_fcn_entry)
@@ -3628,6 +3629,156 @@ 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;
+
+  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;
+
+  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;
+  }
+
+  /* Get attributes: pointer, private.
+  TODO: intent, optional, save  */
+  gfc_clear_attr (&current_attr);
+  for (;;)
+  {
+    m = gfc_match (" , pointer");
+    if (m == MATCH_ERROR)
+      goto syntax;
+    if (m == MATCH_YES)
+    {
+      /*current_attr.pointer = 1;
+      continue;*/
+      gfc_error ("PROCEDURE pointers are not yet implemented!");
+      return MATCH_ERROR;
+    }
+    m = gfc_match (" , public");
+    if (m == MATCH_ERROR)
+      goto syntax;
+    if (m == MATCH_YES)
+    {
+      current_attr.access = ACCESS_PUBLIC;
+      continue;
+    }
+    m = gfc_match (" , private");
+    if (m == MATCH_ERROR)
+      goto syntax;
+    if (m == MATCH_YES)
+    {
+      current_attr.access = ACCESS_PRIVATE;
+      continue;
+    }
+    m = gfc_match (" ::");
+    if (m == MATCH_ERROR)
+      goto syntax;
+    if (m == MATCH_YES)
+      break;
+    if (gfc_match_eos () == MATCH_YES)
+      goto syntax;
+    goto syntax;
+  }
+
+  if (gfc_match_eos () == MATCH_YES)
+    goto syntax;
+
+  /* Get procedure symbols.  */
+  for(;;)
+  {
+    m = gfc_match_symbol (&sym, 0);
+    switch (m)
+    {
+    case MATCH_YES:
+
+      /*if (!current_attr.pointer)
+	sym->attr.external = 1;*/
+      sym->attr.pointer = current_attr.pointer;
+
+      /* 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->attr.flavor = FL_PROCEDURE;
+      sym->attr.procedure = 1;
+
+      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 127614)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -249,7 +249,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;
@@ -644,7 +644,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.  */
 
@@ -791,7 +792,7 @@ gfc_charlen;
 
 #define gfc_get_charlen() gfc_getmem(sizeof(gfc_charlen))
 
-/* Type specification structure.  FIXME: derived and cl could be union???  */
+/* Type specification structure.  FIXME: derived, interface and cl could be union???  */
 typedef struct
 {
   bt type;
@@ -1016,6 +1017,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;
 
@@ -2166,6 +2169,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 127614)
+++ 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)
@@ -7221,6 +7224,62 @@ resolve_symbol (gfc_symbol *sym)
 	}
     }
 
+  /* Check if function/subroutine declaration matches
+    preceding PROCEDURE declaration.  */
+  if (sym->attr.procedure && sym->interface)
+    {
+      gfc_formal_arglist *curr_arg1 = sym->formal;
+      gfc_formal_arglist *curr_arg2 = sym->interface->formal;
+      int i=0;
+      /* First: Check function/subroutine flags.  */
+      if (sym->attr.function && sym->interface->attr.subroutine)
+	{
+	  gfc_error ("Function %s was previously declared as subroutine",
+		    sym->name);
+	  return;
+	}
+      if (sym->attr.subroutine && sym->interface->attr.function)
+	{
+	  gfc_error ("Subroutine %s was previously declared as function",
+		    sym->name);
+	  return;
+	}
+      /* Check return type.  */
+      if (sym->interface->ts.type != BT_UNKNOWN
+	  && sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type
+	  && sym->interface->ts.type != sym->ts.type)
+	{
+	  gfc_error ("Function '%s' of type %s was previously declared as %s",
+		    sym->name, gfc_basic_typename (sym->interface->ts.type),
+		    gfc_basic_typename (sym->ts.type));
+	  return;
+	}
+      /* Check if formal args match.  */
+      while (curr_arg1 && curr_arg2)
+	{
+	  i++;
+	  if (curr_arg1->sym->ts.type != BT_UNKNOWN
+	      && curr_arg2->sym->ts.type != BT_UNKNOWN
+	      && curr_arg1->sym->ts.type != curr_arg2->sym->ts.type)
+	    {
+	      gfc_error ("Procedure '%s': argument #%i of type %s was "
+			"previously declared as %s",sym->name,i,
+			gfc_basic_typename (curr_arg1->sym->ts.type),
+			gfc_basic_typename (curr_arg2->sym->ts.type));
+	      return;
+	    }
+	  curr_arg1 = curr_arg1->next;
+	  curr_arg2 = curr_arg2->next;
+	}
+      if (curr_arg1 || curr_arg2)
+	{
+	  gfc_error ("Procedure '%s': number of arguments does not match",
+		    sym->name);
+	  return;
+	}
+      /* TODO: check intent etc.  */
+    }
+
   if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
     return;
 
Index: gcc/fortran/match.h
===================================================================
--- gcc/fortran/match.h	(revision 127614)
+++ 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 127614)
+++ gcc/fortran/parse.c	(working copy)
@@ -257,6 +257,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;
@@ -718,7 +719,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().  */
@@ -1077,6 +1079,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;