Re: ABSTRACT interfaces + PROCEDURE declarations

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

... and here is the updated procedure declaration patch. I did some
minor changes to the comments (as you suggested), but most importantly
I introduced a new interface field.
I decided to put it in gfc_symbol and not in gfc_typespec, since this
avoids some problems (e.g. if it were in gfc_typespec, the declaration
of the function or subroutine would set the typespec of the procedure
and hereby overwrite/delete the interface field). I should remark that
g95 puts this field in gfc_typespec, and while I don't know their
reasons for it, I hope there is no drawback in putting it into
gfc_symbol.
This change also enabled me to implement some simple tests, checking
if the declaration of the function/subroutine matches the PROCEDURE
declaration. I put this in resolve.c (resolve_symbol), and hope this
is the right place for it. I noticed that the error messages I got
from these checks appeared twice every time, but don't know why.
Still the patch only implements a part of the PROCEDURE syntax, but
I'm working on further extensions. It should still be able to handle
the example code I posted earlier, but if you find any cases that it
can't handle please let me know.
Cheers,
Janus

Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 127553)
+++ 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,65 @@ 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 = src->formal;
+  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;
+
+  while (curr_arg != NULL)
+    {
+      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.  */
+      formal_arg->next = NULL;
+      if (formal_prev != NULL)
+        formal_prev->next = formal_arg;
+      formal_prev = formal_arg;
+
+      /* Add arg to list of formal args.  */
+      add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
+
+      /* Will reuse for any additional arg(s).  */
+      formal_arg = NULL;
+
+      /* Go to the next arg, if any.  */
+      curr_arg = curr_arg->next;
+    }
+
+  /* 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 127553)
+++ 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,145 @@ 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_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 (" , 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 typespec.  */
+      if (current_ts.type != BT_UNKNOWN && proc_if == NULL)
+	sym->ts = current_ts;
+
+      if (proc_if != NULL)
+	sym->interface=proc_if;
+
+      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 127553)
+++ 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 127553)
+++ 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)
@@ -7214,6 +7217,62 @@ resolve_symbol (gfc_symbol *sym)
 	}
     }
 
+  /* Check if function/subroutine declaration matches
+    preceding PROCEDURE declaration.  */
+  if (sym->attr.procedure) 
+    {
+      /* 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 && 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.  */
+      gfc_formal_arglist *curr_arg1 = sym->formal;
+      gfc_formal_arglist *curr_arg2 = sym->interface->formal;
+      int i=0;
+      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 127553)
+++ 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 127553)
+++ gcc/fortran/parse.c	(working copy)
@@ -256,6 +256,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;
@@ -717,7 +718,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().  */
@@ -1076,6 +1078,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;