This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[Patch, Fortran, 4.5] Procedure Pointer Components


Hi all,

in August/September of last year I started working on a patch for
procedure pointer components, which has suffered some bitrotting since
then. I just updated it, so that it applies cleanly to the current
trunk. Although it's not quite finished yet, I'm posting it here for
reference, so that it doesn't get lost and can serve as a baseline for
further investigations.

In it's current form, it fails on the attached testcase with the
following backtrace:

#0  get_frame_type (info=0x0) at /home/jweil/gcc44/trunk/gcc/tree-nested.c:202
#1  0x0840aadf in get_chain_decl (info=0x8a739a8) at
/home/jweil/gcc44/trunk/gcc/tree-nested.c:308
#2  0x0840bd62 in get_nonlocal_debug_decl (info=0x8a739a8,
decl=0xb7d37108) at /home/jweil/gcc44/trunk/gcc/tree-nested.c:804
#3  0x0840f343 in convert_nonlocal_reference_op (tp=0xb7ca35d4,
walk_subtrees=0xbfffe828, data=0xbfffe994) at
/home/jweil/gcc44/trunk/gcc/tree-nested.c:872
#4  0x085522eb in walk_tree_1 (tp=0xb7ca35d4, func=0x840f290
<convert_nonlocal_reference_op>, data=0xbfffe994, pset=0x0, lh=0) at
/home/jweil/gcc44/trunk/gcc/tree.c:8630
#5  0x0829eb88 in walk_gimple_op (stmt=0xb7ca35a0,
callback_op=0x840f290 <convert_nonlocal_reference_op>, wi=0xbfffe994)
at /home/jweil/gcc44/trunk/gcc/gimple.c:1404
#6  0x0829f575 in walk_gimple_stmt (gsi=0xbfffe8e0,
callback_stmt=0x8410320 <convert_nonlocal_reference_stmt>,
callback_op=0x840f290 <convert_nonlocal_reference_op>, wi=0xbfffe994)
at /home/jweil/gcc44/trunk/gcc/gimple.c:1679
#7  0x0829f76c in walk_gimple_seq (seq=0xb7d263e4,
callback_stmt=0x8410320 <convert_nonlocal_reference_stmt>,
callback_op=0x840f290 <convert_nonlocal_reference_op>, wi=0xbfffe994)
at /home/jweil/gcc44/trunk/gcc/gimple.c:1276
#8  0x0829f6d9 in walk_gimple_stmt (gsi=0xbfffe960,
callback_stmt=0x8410320 <convert_nonlocal_reference_stmt>,
callback_op=0x840f290 <convert_nonlocal_reference_op>, wi=0xbfffe994)
at /home/jweil/gcc44/trunk/gcc/gimple.c:1688
#9  0x0829f76c in walk_gimple_seq (seq=0xb7d2645c,
callback_stmt=0x8410320 <convert_nonlocal_reference_stmt>,
callback_op=0x840f290 <convert_nonlocal_reference_op>, wi=0xbfffe994)
at /home/jweil/gcc44/trunk/gcc/gimple.c:1276
#10 0x0840a3c0 in walk_body (callback_stmt=0x8410320
<convert_nonlocal_reference_stmt>, callback_op=0, info=0xb7d37108,
seq=0xb7d2645c) at /home/jweil/gcc44/trunk/gcc/tree-nested.c:550
#11 0x0840c339 in walk_all_functions (callback_stmt=0x8410320
<convert_nonlocal_reference_stmt>, callback_op=0x840f290
<convert_nonlocal_reference_op>, root=0x8a739a8) at
/home/jweil/gcc44/trunk/gcc/tree-nested.c:560
#12 0x0840d885 in lower_nested_functions (fndecl=0xb7d2ef00) at
/home/jweil/gcc44/trunk/gcc/tree-nested.c:2165
#13 0x085aafe8 in cgraph_finalize_function (decl=0xb7d2ef00, nested=0
'\0') at /home/jweil/gcc44/trunk/gcc/cgraphunit.c:515
#14 0x080f7198 in gfc_generate_function_code (ns=0x8aa8a98) at
/home/jweil/gcc44/trunk/gcc/fortran/trans-decl.c:3977
#15 0x080a8d1d in gfc_parse_file () at
/home/jweil/gcc44/trunk/gcc/fortran/parse.c:3856
#16 0x080d878d in gfc_be_parse_file (set_yydebug=0) at
/home/jweil/gcc44/trunk/gcc/fortran/f95-lang.c:236
#17 0x083bf68e in toplev_main (argc=2, argv=0xbfffedc4) at
/home/jweil/gcc44/trunk/gcc/toplev.c:970
#18 0x08124952 in main (argc=2097184, argv=0x0) at
/home/jweil/gcc44/trunk/gcc/main.c:35

triggered by the PPC assignment in line 10 of the testcase. Anyone who
is willing to help me in finding the cause of this ICE is highly
welcome.

In addition to this, I have two more procptr patches in the pipeline
for 4.5, which I would like to commit before the PPC patch (in this
order):

(1) Procedure pointer assignment checking (PR38290), see
http://gcc.gnu.org/ml/fortran/2008-12/msg00191.html

(2) Proc-pointer function results (PR36704), see
http://gcc.gnu.org/ml/fortran/2009-01/msg00248.html

While the first one is pretty complete and just needs to be approved,
the second one still has some minor issues, but may (?) be committed
in its current form, leaving the remaining issues for a follow-up
patch. May the reviewers decide.

I'd appreciate very much a review of any of these three patches.
Cheers,
Janus
Index: gcc/testsuite/gfortran.dg/proc_decl_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/proc_decl_1.f90	(revision 143732)
+++ gcc/testsuite/gfortran.dg/proc_decl_1.f90	(working copy)
@@ -41,7 +41,7 @@ program prog
   procedure(amax0) :: my2  ! { dg-error "not allowed in PROCEDURE statement" }
 
   type t
-    procedure(),pointer:: p  ! { dg-error "not yet implemented" }
+    procedure(),pointer,nopass:: ppc
   end type
 
   real f, x
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(revision 143732)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -476,7 +476,8 @@ gfc_conv_component_ref (gfc_se * se, gfc
       se->string_length = tmp;
     }
 
-  if (c->attr.pointer && c->attr.dimension == 0 && c->ts.type != BT_CHARACTER)
+  if ((c->attr.pointer || c->attr.proc_pointer) && c->attr.dimension == 0
+      && c->ts.type != BT_CHARACTER)
     se->expr = build_fold_indirect_ref (se->expr);
 }
 
@@ -2125,6 +2126,7 @@ gfc_apply_interface_mapping_to_expr (gfc
       break;
 
     case EXPR_COMPCALL:
+    case EXPR_PPC:
       gcc_unreachable ();
       break;
     }
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 143732)
+++ gcc/fortran/symbol.c	(working copy)
@@ -4312,7 +4312,7 @@ gfc_find_typebound_proc (gfc_symbol* der
   /* Try to find it in the current type's namespace.  */
   gcc_assert (derived->f2k_derived);
   res = gfc_find_symtree (derived->f2k_derived->sym_root, name);
-  if (res && res->typebound)
+  if (res && res->typebound && !res->typebound->ppc)
     {
       /* We found one.  */
       if (t)
@@ -4339,5 +4339,51 @@ gfc_find_typebound_proc (gfc_symbol* der
     }
 
   /* Nothing found.  */
+  return NULL;
+}
+
+
+/* Find a procedure pointer component by name for a derived-type (looking
+   recursively through the super-types).  */
+
+gfc_symtree*
+gfc_find_ppc (gfc_symbol* derived, gfc_try* t,const char* name, bool noaccess)
+{
+  gfc_symtree* res;
+
+  /* Set default to failure.  */
+  if (t)
+    *t = FAILURE;
+
+  /* Try to find it in the current type's namespace.  */
+  gcc_assert (derived->f2k_derived);
+  res = gfc_find_symtree (derived->f2k_derived->sym_root, name);
+  if (res && res->typebound && res->typebound->ppc)
+    {
+      /* We found one.  */
+      if (t)
+	*t = SUCCESS;
+
+      if (!noaccess && derived->attr.use_assoc
+	  && res->typebound->access == ACCESS_PRIVATE)
+	{
+	  gfc_error ("'%s' of '%s' is PRIVATE at %C", name, derived->name);
+	  if (t)
+	    *t = FAILURE;
+	}
+
+      return res;
+    }
+
+  /* Otherwise, recurse on parent type if derived is an extension.  */
+  if (derived->attr.extension)
+    {
+      gfc_symbol* super_type;
+      super_type = gfc_get_derived_super_type (derived);
+      gcc_assert (super_type);
+      return gfc_find_ppc (super_type, t, name, noaccess);
+    }
+
+  /* Nothing found.  */
   return NULL;
 }
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 143732)
+++ gcc/fortran/decl.c	(working copy)
@@ -1415,8 +1415,9 @@ build_struct (const char *name, gfc_char
 
   /* Should this ever get more complicated, combine with similar section
      in add_init_expr_to_sym into a separate function.  */
-  if (c->ts.type == BT_CHARACTER && !c->attr.pointer && c->initializer && c->ts.cl
-      && c->ts.cl->length && c->ts.cl->length->expr_type == EXPR_CONSTANT)
+  if (c->ts.type == BT_CHARACTER && !c->attr.pointer && !c->attr.proc_pointer
+      && c->initializer && c->ts.cl && c->ts.cl->length
+      && c->ts.cl->length->expr_type == EXPR_CONSTANT)
     {
       int len;
 
@@ -1435,7 +1436,7 @@ build_struct (const char *name, gfc_char
 	  gfc_constructor *ctor = c->initializer->value.constructor;
 
 	  bool first = true;
-	  int first_len;
+	  int first_len = -1;
 
 	  has_ts = (c->initializer->ts.cl
 		    && c->initializer->ts.cl->length_from_typespec);
@@ -4069,6 +4070,9 @@ gfc_match_suffix (gfc_symbol *sym, gfc_s
 }
 
 
+static match
+match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc);
+
 /* Match a PROCEDURE declaration (R1211).  */
 
 static match
@@ -4076,9 +4080,14 @@ match_procedure_decl (void)
 {
   match m;
   locus old_loc, entry_loc;
-  gfc_symbol *sym, *proc_if = NULL;
+  gfc_symbol *sym, *block, *proc_if = NULL;
+  gfc_typespec ts;
   int num;
   gfc_expr *initializer = NULL;
+  gfc_typebound_proc* tb;
+  gfc_namespace* ns = NULL;
+  gfc_symtree* stree;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
 
   old_loc = entry_loc = gfc_current_locus;
 
@@ -4155,18 +4164,59 @@ got_ts:
     }
 
   /* Parse attributes.  */
-  m = match_attr_spec();
-  if (m == MATCH_ERROR)
-    return MATCH_ERROR;
+  if (gfc_current_state () != COMP_DERIVED)
+    {
+      m = match_attr_spec();
+      if (m == MATCH_ERROR)
+	return MATCH_ERROR;
+    }
+  else
+    {
+      tb = XCNEW (gfc_typebound_proc);
+      tb->where = gfc_current_locus;
+      m = match_binding_attributes (tb, false, true);
+      if (m == MATCH_ERROR)
+	return m;
+
+      gfc_clear_attr (&current_attr);
+      current_attr.proc_pointer = 1;
+      current_attr.access = tb->access;
+
+      /* Get the namespace to insert the symbols into.  */
+      block = gfc_state_stack->sym;
+      ns = block->f2k_derived;
+      gcc_assert (ns);
+
+      /* Match the colons.  */
+      m = gfc_match (" ::");
+      if (m == MATCH_ERROR)
+	return m;
+      if (m != MATCH_YES)
+	{
+	  gfc_error ("Expected '::' after binding-attributes at %C");
+	  return MATCH_ERROR;
+	}
+
+      /* Check for C450.  */
+      if (!tb->nopass && proc_if == NULL)
+	{
+	  gfc_error("Procedure with NOPASS or with explicit interface required at %C");
+	  return MATCH_ERROR;
+	}
+   }
 
   /* Get procedure symbols.  */
+  ts = current_ts;
   for(num=1;;num++)
     {
-      m = gfc_match_symbol (&sym, 0);
+      m = gfc_match_name (name);
       if (m == MATCH_NO)
 	goto syntax;
       else if (m == MATCH_ERROR)
 	return m;
+      if (gfc_get_sym_tree (name, ns, &stree))
+	return MATCH_ERROR;
+      sym = stree->n.sym;
 
       /* Add current_attr to the symbol attributes.  */
       if (gfc_copy_attr (&sym->attr, &current_attr, NULL) == FAILURE)
@@ -4210,18 +4260,18 @@ got_ts:
 	  sym->ts.interface = proc_if;
 	  sym->attr.untyped = 1;
 	}
-      else if (current_ts.type != BT_UNKNOWN)
+      else if (ts.type != BT_UNKNOWN)
 	{
-	  sym->ts = current_ts;
+	  sym->ts = ts;
 	  sym->ts.interface = gfc_new_symbol ("", gfc_current_ns);
-	  sym->ts.interface->ts = current_ts;
+	  sym->ts.interface->ts = ts;
 	  sym->ts.interface->attr.function = 1;
 	  sym->attr.function = sym->ts.interface->attr.function;
 	}
 
       if (gfc_match (" =>") == MATCH_YES)
 	{
-	  if (!current_attr.pointer)
+	  if (!current_attr.pointer && !current_attr.proc_pointer)
 	    {
 	      gfc_error ("Initialization at %C isn't for a pointer variable");
 	      m = MATCH_ERROR;
@@ -4245,14 +4295,24 @@ got_ts:
 	  if (m != MATCH_YES)
 	    goto cleanup;
 
-	  if (add_init_expr_to_sym (sym->name, &initializer, &gfc_current_locus)
-	      != SUCCESS)
+	  if (gfc_current_state () != COMP_DERIVED
+	      && add_init_expr_to_sym (sym->name, &initializer,
+				       &gfc_current_locus)
+		 != SUCCESS)
 	    goto cleanup;
-
 	}
 
       gfc_set_sym_referenced (sym);
 
+      if (gfc_current_state () == COMP_DERIVED)
+	{
+	  current_ts = sym->ts;
+	  if (build_struct (sym->name, sym->ts.cl, &initializer, &sym->as)
+	      != SUCCESS)
+	    goto cleanup;
+	  stree->typebound = tb;
+	}
+
       if (gfc_match_eos () == MATCH_YES)
 	return MATCH_YES;
       if (gfc_match_char (',') != MATCH_YES)
@@ -4329,15 +4389,12 @@ gfc_match_procedure (void)
     case COMP_MODULE:
     case COMP_SUBROUTINE:
     case COMP_FUNCTION:
+    case COMP_DERIVED:
       m = match_procedure_decl ();
       break;
     case COMP_INTERFACE:
       m = match_procedure_in_interface ();
       break;
-    case COMP_DERIVED:
-      gfc_error ("Fortran 2003: Procedure components at %C are not yet"
-		 " implemented in gfortran");
-      return MATCH_ERROR;
     case COMP_DERIVED_CONTAINS:
       m = match_procedure_in_type ();
       break;
@@ -6720,9 +6777,10 @@ cleanup:
 /* Match binding attributes.  */
 
 static match
-match_binding_attributes (gfc_typebound_proc* ba, bool generic)
+match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc)
 {
   bool found_passing = false;
+  bool seen_ptr = false;
   match m;
 
   /* Intialize to defaults.  Do so even before the MATCH_NO check so that in
@@ -6796,33 +6854,6 @@ match_binding_attributes (gfc_typebound_
 	      continue;
 	    }
 
-	  /* NON_OVERRIDABLE flag.  */
-	  m = gfc_match (" non_overridable");
-	  if (m == MATCH_ERROR)
-	    goto error;
-	  if (m == MATCH_YES)
-	    {
-	      if (ba->non_overridable)
-		{
-		  gfc_error ("Duplicate NON_OVERRIDABLE at %C");
-		  goto error;
-		}
-
-	      ba->non_overridable = 1;
-	      continue;
-	    }
-
-	  /* DEFERRED flag.  */
-	  /* TODO: Handle really once implemented.  */
-	  m = gfc_match (" deferred");
-	  if (m == MATCH_ERROR)
-	    goto error;
-	  if (m == MATCH_YES)
-	    {
-	      gfc_error ("DEFERRED not yet implemented at %C");
-	      goto error;
-	    }
-
 	  /* PASS possibly including argument.  */
 	  m = gfc_match (" pass");
 	  if (m == MATCH_ERROR)
@@ -6850,6 +6881,55 @@ match_binding_attributes (gfc_typebound_
 	      continue;
 	    }
 
+	  if (ppc)
+	    {
+	      /* POINTER flag.  */
+	      m = gfc_match (" pointer");
+	      if (m == MATCH_ERROR)
+		goto error;
+	      if (m == MATCH_YES)
+		{
+		  if (seen_ptr)
+		    {
+		      gfc_error ("Duplicate POINTER attribute at %C");
+		      goto error;
+		    }
+
+		  seen_ptr = true;
+		  ba->ppc = 1;
+        	  continue;
+		}
+	    }
+	  else
+	    {
+	      /* NON_OVERRIDABLE flag.  */
+	      m = gfc_match (" non_overridable");
+	      if (m == MATCH_ERROR)
+		goto error;
+	      if (m == MATCH_YES)
+		{
+		  if (ba->non_overridable)
+		    {
+		      gfc_error ("Duplicate NON_OVERRIDABLE at %C");
+		      goto error;
+		    }
+
+		  ba->non_overridable = 1;
+		  continue;
+		}
+
+	      /* DEFERRED flag.  */
+	      /* TODO: Handle really once implemented.  */
+	      m = gfc_match (" deferred");
+	      if (m == MATCH_ERROR)
+		goto error;
+	      if (m == MATCH_YES)
+		{
+		  gfc_error ("DEFERRED not yet implemented at %C");
+		  goto error;
+		}
+	    }
+
 	}
 
       /* Nothing matching found.  */
@@ -6864,6 +6944,13 @@ match_binding_attributes (gfc_typebound_
   if (ba->access == ACCESS_UNKNOWN)
     ba->access = gfc_typebound_default_access;
 
+  if (ppc && !seen_ptr)
+    {
+      gfc_error ("POINTER attribute is required for procedure pointer component"
+                 " at %C");
+      goto error;
+    }
+
   return MATCH_YES;
 
 error:
@@ -6906,7 +6993,7 @@ match_procedure_in_type (void)
   tb->is_generic = 0;
 
   /* Match binding attributes.  */
-  m = match_binding_attributes (tb, false);
+  m = match_binding_attributes (tb, false, false);
   if (m == MATCH_ERROR)
     return m;
   seen_attrs = (m == MATCH_YES);
@@ -7024,7 +7111,7 @@ gfc_match_generic (void)
   gcc_assert (block && ns);
 
   /* See if we get an access-specifier.  */
-  m = match_binding_attributes (&tbattr, true);
+  m = match_binding_attributes (&tbattr, true, false);
   if (m == MATCH_ERROR)
     goto error;
 
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 143732)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -151,7 +151,7 @@ bt;
 /* Expression node types.  */
 typedef enum
 { EXPR_OP = 1, EXPR_FUNCTION, EXPR_CONSTANT, EXPR_VARIABLE,
-  EXPR_SUBSTRING, EXPR_STRUCTURE, EXPR_ARRAY, EXPR_NULL, EXPR_COMPCALL
+  EXPR_SUBSTRING, EXPR_STRUCTURE, EXPR_ARRAY, EXPR_NULL, EXPR_COMPCALL, EXPR_PPC
 }
 expr_t;
 
@@ -846,6 +846,8 @@ typedef struct gfc_component
   locus loc;
   struct gfc_expr *initializer;
   struct gfc_component *next;
+
+  struct gfc_formal_arglist *formal;
 }
 gfc_component;
 
@@ -1041,6 +1043,7 @@ typedef struct gfc_typebound_proc
   unsigned is_generic:1;
   unsigned function:1, subroutine:1;
   unsigned error:1; /* Ignore it, when an error occurred during resolution.  */
+  unsigned ppc:1; /* Procedure Pointer Component.  */
 }
 gfc_typebound_proc;
 
@@ -1608,8 +1611,8 @@ typedef struct gfc_expr
     struct
     {
       gfc_actual_arglist* actual;
-      gfc_typebound_proc* tbp;
       const char* name;
+      gfc_typebound_proc* tbp;
     }
     compcall;
 
@@ -1862,7 +1865,7 @@ typedef enum
   EXEC_GOTO, EXEC_CALL, EXEC_COMPCALL, EXEC_ASSIGN_CALL, EXEC_RETURN,
   EXEC_ENTRY, EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, EXEC_INIT_ASSIGN,
   EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT,
-  EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT,
+  EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT, EXEC_CALL_PPC,
   EXEC_ALLOCATE, EXEC_DEALLOCATE,
   EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT,
   EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END,
@@ -2356,6 +2359,7 @@ gfc_gsymbol *gfc_find_gsymbol (gfc_gsymb
 
 gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
 gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*, const char*, bool);
+gfc_symtree* gfc_find_ppc (gfc_symbol*, gfc_try*,const char*, bool);
 
 void copy_formal_args (gfc_symbol *dest, gfc_symbol *src);
 
@@ -2457,6 +2461,8 @@ void gfc_expr_set_symbols_referenced (gf
 gfc_try gfc_expr_check_typed (gfc_expr*, gfc_namespace*, bool);
 void gfc_expr_replace_symbols (gfc_expr *, gfc_symbol *);
 
+bool is_proc_ptr_comp (gfc_expr *, const char **);
+
 /* st.c */
 extern gfc_code new_st;
 
@@ -2562,7 +2568,7 @@ void gfc_free_use_stmts (gfc_use_list *)
 symbol_attribute gfc_variable_attr (gfc_expr *, gfc_typespec *);
 symbol_attribute gfc_expr_attr (gfc_expr *);
 match gfc_match_rvalue (gfc_expr **);
-match gfc_match_varspec (gfc_expr*, int, bool);
+match gfc_match_varspec (gfc_expr*, int, bool, bool);
 int gfc_check_digit (char, int);
 
 /* trans.c */
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(revision 143732)
+++ gcc/fortran/expr.c	(working copy)
@@ -182,6 +182,7 @@ free_expr0 (gfc_expr *e)
       break;
 
     case EXPR_COMPCALL:
+    case EXPR_PPC:
       gfc_free_actual_arglist (e->value.compcall.actual);
       break;
 
@@ -507,6 +508,7 @@ gfc_copy_expr (gfc_expr *p)
       break;
 
     case EXPR_COMPCALL:
+    case EXPR_PPC:
       q->value.compcall.actual =
 	gfc_copy_actual_arglist (p->value.compcall.actual);
       q->value.compcall.tbp = p->value.compcall.tbp;
@@ -1723,6 +1725,7 @@ gfc_simplify_expr (gfc_expr *p, int type
       break;
 
     case EXPR_COMPCALL:
+    case EXPR_PPC:
       gcc_unreachable ();
       break;
     }
@@ -3032,7 +3035,7 @@ gfc_check_pointer_assign (gfc_expr *lval
   symbol_attribute attr;
   gfc_ref *ref;
   int is_pure;
-  int pointer, check_intent_in;
+  int pointer, check_intent_in, proc_pointer;
 
   if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
       && !lvalue->symtree->n.sym->attr.proc_pointer)
@@ -3056,16 +3059,18 @@ gfc_check_pointer_assign (gfc_expr *lval
   /* Check INTENT(IN), unless the object itself is the component or
      sub-component of a pointer.  */
   check_intent_in = 1;
-  pointer = lvalue->symtree->n.sym->attr.pointer
-	      | lvalue->symtree->n.sym->attr.proc_pointer;
+  pointer = lvalue->symtree->n.sym->attr.pointer;
+  proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
 
   for (ref = lvalue->ref; ref; ref = ref->next)
     {
-      if (pointer)
+      if (pointer || proc_pointer)
 	check_intent_in = 0;
 
       if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
 	pointer = 1;
+      else if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer)
+	proc_pointer = 1;
 
       if (ref->type == REF_ARRAY && ref->next == NULL)
 	{
@@ -3101,7 +3106,7 @@ gfc_check_pointer_assign (gfc_expr *lval
       return FAILURE;
     }
 
-  if (!pointer)
+  if (!pointer && !proc_pointer)
     {
       gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
       return FAILURE;
@@ -3123,7 +3128,7 @@ gfc_check_pointer_assign (gfc_expr *lval
     return SUCCESS;
 
   /* Checks on rvalue for procedure pointer assignments.  */
-  if (lvalue->symtree->n.sym->attr.proc_pointer)
+  if (proc_pointer)
     {
       attr = gfc_expr_attr (rvalue);
       if (!((rvalue->expr_type == EXPR_NULL)
@@ -3475,6 +3480,27 @@ gfc_expr_set_symbols_referenced (gfc_exp
   gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
 }
 
+bool
+is_proc_ptr_comp (gfc_expr *expr, const char **name)
+{
+  gfc_ref *r;
+  bool ppc = false;
+  for (r = expr->ref; r; r = r->next)
+    {
+      switch (r->type)
+	{
+	case REF_COMPONENT:
+	  ppc = r->u.c.component->attr.proc_pointer;
+          if (name) *name = r->u.c.component->name;
+	  break;
+	default:
+	  /* Do nothing.  */
+	  break;
+	}
+    }
+  return ppc;
+}
+
 
 /* Walk an expression tree and check each variable encountered for being typed.
    If strict is not set, a top-level variable is tolerated untyped in -std=gnu
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c	(revision 143732)
+++ gcc/fortran/module.c	(working copy)
@@ -3038,6 +3038,7 @@ mio_expr (gfc_expr **ep)
       break;
 
     case EXPR_COMPCALL:
+    case EXPR_PPC:
       gcc_unreachable ();
       break;
     }
Index: gcc/fortran/trans.c
===================================================================
--- gcc/fortran/trans.c	(revision 143732)
+++ gcc/fortran/trans.c	(working copy)
@@ -1113,6 +1113,10 @@ gfc_trans_code (gfc_code * code)
 	  }
 	  break;
 
+	case EXEC_CALL_PPC:
+	  res = gfc_trans_call (code, false);
+	  break;
+
 	case EXEC_ASSIGN_CALL:
 	  res = gfc_trans_call (code, true);
 	  break;
Index: gcc/fortran/trans-types.c
===================================================================
--- gcc/fortran/trans-types.c	(revision 143732)
+++ gcc/fortran/trans-types.c	(working copy)
@@ -1875,6 +1875,12 @@ gfc_get_derived_type (gfc_symbol * deriv
     {
       if (c->ts.type == BT_DERIVED)
         field_type = c->ts.derived->backend_decl;
+      else if (c->attr.proc_pointer)
+	{
+	  gfc_try t;
+	  gfc_symtree *stree = gfc_find_ppc (derived, &t, c->name, false);
+	  field_type = build_pointer_type (gfc_get_function_type (stree->n.sym));
+	}
       else
 	{
 	  if (c->ts.type == BT_CHARACTER)
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 143732)
+++ gcc/fortran/resolve.c	(working copy)
@@ -862,7 +862,8 @@ resolve_structure_cons (gfc_expr *expr)
 	}
 
       if (cons->expr->expr_type == EXPR_NULL
-	    && !(comp->attr.pointer || comp->attr.allocatable))
+	  && !(comp->attr.pointer || comp->attr.allocatable
+	       || comp->attr.proc_pointer))
 	{
 	  t = FAILURE;
 	  gfc_error ("The NULL in the derived type constructor at %L is "
@@ -4182,6 +4183,7 @@ static gfc_try
 resolve_variable (gfc_expr *e)
 {
   gfc_symbol *sym;
+  const char *name;
   gfc_try t;
 
   t = SUCCESS;
@@ -4193,6 +4195,16 @@ resolve_variable (gfc_expr *e)
     return FAILURE;
 
   sym = e->symtree->n.sym;
+
+  if (is_proc_ptr_comp (e, &name))
+    {
+      gfc_symtree *stree = gfc_find_ppc (sym->ts.derived, &t, name, false);
+      e->symtree = stree;
+      e->ref = NULL;
+      sym = stree->n.sym;
+      /*return resolve_expr (e);*/
+    }
+
   if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
     {
       e->ts.type = BT_PROCEDURE;
@@ -4729,6 +4741,50 @@ resolve_compcall (gfc_expr* e)
 }
 
 
+/* Resolve a CALL to a Procedure Pointer Component (Subroutine).  */
+
+static gfc_try
+resolve_ppc_call (gfc_code* c)
+{
+  gfc_try t;
+  gfc_symtree *stree = gfc_find_ppc (c->expr->symtree->n.sym->ts.derived, &t,
+					c->expr->value.compcall.name, false);
+  gcc_assert (stree);
+  c->resolved_sym = stree->n.sym;
+
+  gfc_procedure_use (stree->n.sym, &c->expr->value.compcall.actual,
+			&c->expr->where);
+
+  return SUCCESS;
+}
+
+
+/* Resolve a Function Call to a Procedure Pointer Component (Function).  */
+
+static gfc_try
+resolve_expr_ppc (gfc_expr* e)
+{
+  gfc_try t;
+  gfc_symtree *stree = gfc_find_ppc (e->symtree->n.sym->ts.derived, &t,
+					e->value.compcall.name, false);
+  gcc_assert (stree);
+
+  /* Convert to EXPR_FUNCTION.  */
+  e->expr_type = EXPR_FUNCTION;
+  e->value.function.actual = e->value.compcall.actual;
+  e->value.function.name = e->value.compcall.name;
+  e->value.function.isym = NULL;
+  e->value.function.esym = NULL;
+  e->symtree = stree;
+  e->ref = NULL;
+
+  gfc_procedure_use (stree->n.sym, &e->value.compcall.actual,
+			&e->where);
+
+  return gfc_resolve_expr (e);
+}
+
+
 /* Resolve an expression.  That is, make sure that types of operands agree
    with their operators, intrinsic operators are converted to function calls
    for overloaded types and unresolved function references are resolved.  */
@@ -4778,6 +4834,10 @@ gfc_resolve_expr (gfc_expr *e)
       t = SUCCESS;
       break;
 
+    case EXPR_PPC:
+      t = resolve_expr_ppc (e);
+      break;
+
     case EXPR_ARRAY:
       t = FAILURE;
       if (resolve_ref (e) == FAILURE)
@@ -6697,7 +6757,7 @@ resolve_code (gfc_code *code, gfc_namesp
 	}
 
       t = SUCCESS;
-      if (code->op != EXEC_COMPCALL)
+      if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
 	t = gfc_resolve_expr (code->expr);
       forall_flag = forall_save;
 
@@ -6808,6 +6868,10 @@ resolve_code (gfc_code *code, gfc_namesp
 	  resolve_typebound_call (code);
 	  break;
 
+	case EXEC_CALL_PPC:
+          resolve_ppc_call (code);
+	  break;
+
 	case EXEC_SELECT:
 	  /* Select is complicated. Also, a SELECT construct could be
 	     a transformed computed GOTO.  */
@@ -8473,7 +8537,7 @@ resolve_typebound_procedure (gfc_symtree
   gfc_component* comp;
 
   /* If this is no type-bound procedure, just return.  */
-  if (!stree->typebound)
+  if (!stree->typebound || stree->typebound->ppc)
     return;
 
   /* If this is a GENERIC binding, use that routine.  */
@@ -8679,6 +8743,40 @@ resolve_fl_derived (gfc_symbol *sym)
 
   for (c = sym->components; c != NULL; c = c->next)
     {
+      if (c->attr.proc_pointer && c->ts.interface
+	  /*&& c->attr.if_source != IFSRC_DECL*/)
+	{
+	  if (c->ts.interface->attr.procedure)
+	    gfc_error ("Interface '%s', used by procedure '%s' at %L, is "
+		       "declared in a later PROCEDURE statement",
+		       sym->ts.interface->name, sym->name,&sym->declared_at);
+
+	  /* Get the attributes from the interface (now resolved).  */
+	  if (c->ts.interface->attr.if_source || c->ts.interface->attr.intrinsic)
+	    {
+	      gfc_symbol *ifc = c->ts.interface;
+	      c->ts = ifc->ts;
+	      c->ts.interface = ifc;
+	      c->attr.function = ifc->attr.function;
+	      c->attr.subroutine = ifc->attr.subroutine;
+	      c->attr.allocatable = ifc->attr.allocatable;
+	      c->attr.pointer = ifc->attr.pointer;
+	      c->attr.pure = ifc->attr.pure;
+	      c->attr.elemental = ifc->attr.elemental;
+	      c->attr.dimension = ifc->attr.dimension;
+	      c->attr.recursive = ifc->attr.recursive;
+	      c->attr.always_explicit = ifc->attr.always_explicit;
+	      c->as = gfc_copy_array_spec (c->as);
+/*TODO:	  copy_formal_args (sym, ifc); */
+	    }
+	  else if (c->ts.interface->name[0] != '\0')
+	    {
+	      gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit",
+			c->ts.interface->name, c->name, &c->loc);
+	      return FAILURE;
+ 	    }
+	}
+
       /* Check type-spec if this is not the parent-type component.  */
       if ((!sym->attr.extension || c != sym->components)
 	  && resolve_typespec_used (&c->ts, &c->loc, c->name) == FAILURE)
@@ -9376,6 +9474,10 @@ resolve_symbol (gfc_symbol *sym)
   if (sym->formal_ns && sym->formal_ns != gfc_current_ns)
     gfc_resolve (sym->formal_ns);
 
+  /* Resolve f2k_derived namespace.  */
+  if (sym->f2k_derived)
+    gfc_resolve (sym->f2k_derived);
+
   /* Check threadprivate restrictions.  */
   if (sym->attr.threadprivate && !sym->attr.save && !sym->ns->save_all
       && (!sym->attr.in_common
Index: gcc/fortran/st.c
===================================================================
--- gcc/fortran/st.c	(revision 143732)
+++ gcc/fortran/st.c	(working copy)
@@ -109,6 +109,7 @@ gfc_free_statement (gfc_code *p)
       break;
 
     case EXEC_COMPCALL:
+    case EXEC_CALL_PPC:
     case EXEC_CALL:
     case EXEC_ASSIGN_CALL:
       gfc_free_actual_arglist (p->ext.actual);
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c	(revision 143732)
+++ gcc/fortran/match.c	(working copy)
@@ -1336,14 +1336,23 @@ gfc_match_pointer_assignment (void)
       goto cleanup;
     }
 
-  if (lvalue->symtree->n.sym->attr.proc_pointer)
+  if (lvalue->symtree->n.sym->attr.proc_pointer || is_proc_ptr_comp (lvalue, NULL))
     gfc_matching_procptr_assignment = 1;
 
   m = gfc_match (" %e%t", &rvalue);
-  gfc_matching_procptr_assignment = 0;
   if (m != MATCH_YES)
     goto cleanup;
 
+  if (gfc_matching_procptr_assignment && rvalue->expr_type != EXPR_VARIABLE
+      && rvalue->expr_type != EXPR_FUNCTION && rvalue->expr_type != EXPR_PPC)
+    {
+      gfc_error ("Invalid procedure pointer assignment at %C");
+      m = MATCH_ERROR;
+      goto cleanup;
+    }
+
+  gfc_matching_procptr_assignment = 0;
+
   new_st.op = EXEC_POINTER_ASSIGN;
   new_st.expr = lvalue;
   new_st.expr2 = rvalue;
@@ -1351,6 +1360,7 @@ gfc_match_pointer_assignment (void)
   return MATCH_YES;
 
 cleanup:
+  gfc_matching_procptr_assignment = 0;
   gfc_current_locus = old_loc;
   gfc_free_expr (lvalue);
   gfc_free_expr (rvalue);
@@ -2510,7 +2520,7 @@ match_typebound_call (gfc_symtree* varst
   base->where = gfc_current_locus;
   gfc_set_sym_referenced (varst->n.sym);
   
-  m = gfc_match_varspec (base, 0, true);
+  m = gfc_match_varspec (base, 0, true, true);
   if (m == MATCH_NO)
     gfc_error ("Expected component reference at %C");
   if (m != MATCH_YES)
@@ -2522,13 +2532,15 @@ match_typebound_call (gfc_symtree* varst
       return MATCH_ERROR;
     }
 
-  if (base->expr_type != EXPR_COMPCALL)
+  if (base->expr_type == EXPR_COMPCALL)
+    new_st.op = EXEC_COMPCALL;
+  else if (base->expr_type == EXPR_PPC)
+    new_st.op = EXEC_CALL_PPC;
+  else
     {
-      gfc_error ("Expected type-bound procedure reference at %C");
+      gfc_error ("Expected TBP or PPC at %C");
       return MATCH_ERROR;
     }
-
-  new_st.op = EXEC_COMPCALL;
   new_st.expr = base;
 
   return MATCH_YES;
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(revision 143732)
+++ gcc/fortran/trans-decl.c	(working copy)
@@ -949,7 +949,7 @@ gfc_get_symbol_decl (gfc_symbol * sym)
 		|| sym->attr.use_assoc
 		|| sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
 
-  if (sym->ns && sym->ns->proc_name->attr.function)
+  if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
     byref = gfc_return_by_reference (sym->ns->proc_name);
   else
     byref = 0;
@@ -1174,7 +1174,7 @@ get_proc_pointer_decl (gfc_symbol *sym)
       && sym->ns->proc_name->backend_decl == current_function_decl)
       || sym->attr.contained)
     gfc_add_decl_to_function (decl);
-  else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
+  else if (sym->ns->proc_name && sym->ns->proc_name->attr.flavor != FL_MODULE)
     gfc_add_decl_to_parent_function (decl);
 
   sym->backend_decl = decl;
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c	(revision 143732)
+++ gcc/fortran/parse.c	(working copy)
@@ -1870,15 +1870,11 @@ parse_derived (void)
 	  unexpected_eof ();
 
 	case ST_DATA_DECL:
+	case ST_PROCEDURE:
 	  accept_statement (st);
 	  seen_component = 1;
 	  break;
 
-	case ST_PROCEDURE:
-	  gfc_error ("PROCEDURE binding at %C must be inside CONTAINS");
-	  error_flag = 1;
-	  break;
-
 	case ST_FINAL:
 	  gfc_error ("FINAL declaration at %C must be inside CONTAINS");
 	  error_flag = 1;
@@ -1984,7 +1980,7 @@ endType:
 	}
 
       /* Look for pointer components.  */
-      if (c->attr.pointer
+      if (c->attr.pointer || c->attr.proc_pointer
 	  || (c->ts.type == BT_DERIVED && c->ts.derived->attr.pointer_comp))
 	{
 	  sym->attr.pointer_comp = 1;
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(revision 143732)
+++ gcc/fortran/primary.c	(working copy)
@@ -1704,7 +1704,7 @@ extend_ref (gfc_expr *primary, gfc_ref *
    to be a subroutine as part of CALL or a FUNCTION.  */
 
 match
-gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag)
+gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, bool ppc_arg)
 {
   char name[GFC_MAX_SYMBOL_LEN + 1];
   gfc_ref *substring, *tail;
@@ -1758,7 +1758,7 @@ gfc_match_varspec (gfc_expr *primary, in
   for (;;)
     {
       gfc_try t;
-      gfc_symtree *tbp;
+      gfc_symtree *tbp,*ppc;
 
       m = gfc_match_name (name);
       if (m == MATCH_NO)
@@ -1821,6 +1821,28 @@ gfc_match_varspec (gfc_expr *primary, in
 
       primary->ts = component->ts;
 
+      ppc = gfc_find_ppc (sym, &t, name, false);
+      if (ppc && ppc_arg && !gfc_matching_procptr_assignment)
+	{
+	  primary->expr_type = EXPR_PPC;
+	  primary->value.compcall.tbp = ppc->typebound;
+	  primary->value.compcall.name = ppc->name;
+	  m = gfc_match_actual_arglist(ppc->typebound->subroutine, &primary->value.compcall.actual);
+	  if (m == MATCH_ERROR)
+	    return MATCH_ERROR;
+	  if (m == MATCH_NO)
+	    {
+	      if (sub_flag)
+		primary->value.compcall.actual = NULL;
+	      else
+		{
+		  gfc_error ("Expected argument list at %C");
+		  return MATCH_ERROR;
+		}
+	    }
+          break;
+	}
+
       if (component->as != NULL)
 	{
 	  tail = extend_ref (primary, tail);
@@ -1920,7 +1942,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_t
   allocatable = attr.allocatable;
 
   target = attr.target;
-  if (pointer)
+  if (pointer || attr.proc_pointer)
     target = 1;
 
   if (ts != NULL && expr->ts.type == BT_UNKNOWN)
@@ -1966,7 +1988,7 @@ gfc_variable_attr (gfc_expr *expr, gfc_t
 
 	pointer = ref->u.c.component->attr.pointer;
 	allocatable = ref->u.c.component->attr.allocatable;
-	if (pointer)
+	if (pointer || attr.proc_pointer)
 	  target = 1;
 
 	break;
@@ -2447,7 +2469,7 @@ gfc_match_rvalue (gfc_expr **result)
       e->expr_type = EXPR_VARIABLE;
       e->symtree = symtree;
 
-      m = gfc_match_varspec (e, 0, false);
+      m = gfc_match_varspec (e, 0, false, true);
       break;
 
     case FL_PARAMETER:
@@ -2464,7 +2486,7 @@ gfc_match_rvalue (gfc_expr **result)
 	}
 
       e->symtree = symtree;
-      m = gfc_match_varspec (e, 0, false);
+      m = gfc_match_varspec (e, 0, false, true);
 
       if (sym->ts.is_c_interop || sym->ts.is_iso_c)
 	break;
@@ -2520,7 +2542,7 @@ gfc_match_rvalue (gfc_expr **result)
 	  e = gfc_get_expr ();
 	  e->expr_type = EXPR_VARIABLE;
 	  e->symtree = symtree;
-	  m = gfc_match_varspec (e, 0, false);
+	  m = gfc_match_varspec (e, 0, false, true);
 	  break;
 	}
 
@@ -2547,7 +2569,7 @@ gfc_match_rvalue (gfc_expr **result)
 	  e->symtree = symtree;
 	  e->expr_type = EXPR_VARIABLE;
 
-	  m = gfc_match_varspec (e, 0, false);
+	  m = gfc_match_varspec (e, 0, false, true);
 	  break;
 	}
 
@@ -2643,7 +2665,7 @@ gfc_match_rvalue (gfc_expr **result)
 	  e = gfc_get_expr ();
 	  e->symtree = symtree;
 	  e->expr_type = EXPR_VARIABLE;
-	  m = gfc_match_varspec (e, 0, false);
+	  m = gfc_match_varspec (e, 0, false, true);
 	  break;
 	}
 
@@ -2668,7 +2690,7 @@ gfc_match_rvalue (gfc_expr **result)
 
 	  /*FIXME:??? gfc_match_varspec does set this for us: */
 	  e->ts = sym->ts;
-	  m = gfc_match_varspec (e, 0, false);
+	  m = gfc_match_varspec (e, 0, false, true);
 	  break;
 	}
 
@@ -2757,7 +2779,7 @@ gfc_match_rvalue (gfc_expr **result)
       /* If our new function returns a character, array or structure
 	 type, it might have subsequent references.  */
 
-      m = gfc_match_varspec (e, 0, false);
+      m = gfc_match_varspec (e, 0, false, true);
       if (m == MATCH_NO)
 	m = MATCH_YES;
 
@@ -2941,7 +2963,7 @@ match_variable (gfc_expr **result, int e
   expr->where = where;
 
   /* Now see if we have to do more.  */
-  m = gfc_match_varspec (expr, equiv_flag, false);
+  m = gfc_match_varspec (expr, equiv_flag, false, false);
   if (m != MATCH_YES)
     {
       gfc_free_expr (expr);

Attachment: test1.f90
Description: Binary data


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]