PROCEDURE pointers

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

Hi all,
since my patch for PROCEDURE declarations is reasonably stable now
(hopefully), we could try to get procedure pointers working as well.
But I think I will need some help with this, if it should be included
in 4.3.
So if anyone cares to take a look at it: Attached is my procedure
declaration patch, which should provide the basis for the PROCEDURE
syntax, plus an early version of a procedure pointer patch, which is
just the pointer bits extracted from Paul's first attempt to implement
procedure statements (mainly dealing with pointer assignment).
Paul already told me that this is not really working yet, but probably
it's not a lot of work to get procedure pointers working for someone
with a better knowledge of the middle-end mechanisms than me. It would
be great if someone could look into it.
To try out the procedure pointer implementation, you just need to
apply both patches, and in addition remove the following lines in
decl.c (gfc_match_procedure):

  if (current_attr.pointer)
    {
      gfc_error ("Procedure pointers used at %C are not yet implemented");
      return MATCH_ERROR;
    }

As said before it's not fully working yet, but hopefully not far from
it. The syntax bits should be ok, only the pointer assignments seem to
be broken.
I also attached two files with example code. For the first one I get
the following error:

ppt1a.f90:13: internal compiler error: in gimplify_expr, at gimplify.c:6203

For the second one I get this:

ppt1b.f90:(.text+0x23): undefined reference to `p.1025'
ppt1b.f90:(.text+0x5e): undefined reference to `p.1025'
ppt1b.f90:(.text+0x92): undefined reference to `p.1025'
ppt1b.f90:(.text+0xcd): undefined reference to `p.1025'
collect2: ld returned 1 exit status

Cheers,
Janus

Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 127848)
+++ gcc/fortran/symbol.c	(working copy)
@@ -438,7 +438,7 @@ check_conflict (symbol_attribute *attr, 
 
   conf (external, intrinsic);
 
-  if (attr->if_source || attr->contained)
+  if ((attr->if_source || attr->contained) && !attr->procedure)
     {
       conf (external, subroutine);
       conf (external, function);
@@ -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 127848)
+++ gcc/fortran/decl.c	(working copy)
@@ -3632,6 +3632,255 @@ 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;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+
+  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_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;
+    }
+
+  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;
+
+  if (proc_if)
+    {
+      /* Interface must be abstract.  */
+      if (proc_if->generic)
+	{
+	  gfc_error ("Interface %s at %C may not be generic", proc_if->name);
+	  return MATCH_ERROR;
+	}
+      /* Handle intrinsic procedures.  */
+      if (gfc_intrinsic_name (proc_if->name, 0)
+	  || gfc_intrinsic_name (proc_if->name, 1))
+	proc_if->attr.intrinsic = 1;
+      if (proc_if->attr.intrinsic)
+	{
+	  gfc_error ("Intrinsic procedure %s not supported "
+		    "in PROCEDURE statement at %C", proc_if->name);
+	  return MATCH_ERROR;
+	}
+      /* TODO: Allow those intrinsinc procedures which are
+      legal here according to C1212.  */
+    }
+
+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 at %C requires an interface with BIND(C)");
+      return MATCH_ERROR;
+    }
+  /* Check for C449.  */
+  if (gfc_current_state () == COMP_DERIVED && !current_attr.pointer)
+    {
+      gfc_error ("Procedure component at %C must have POINTER attribute");
+      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++)
+    {
+
+      if (gfc_current_state () == COMP_INTERFACE)
+	{
+	  m = gfc_match_name (name);
+	  if (m == MATCH_NO)
+	    goto syntax;
+	  if (m != MATCH_YES)
+	    return MATCH_ERROR;
+	  if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
+	    return MATCH_ERROR;
+	}
+      else
+	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++;
+	    }
+
+	  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;
+	    }
+
+	  if (gfc_current_state () == COMP_INTERFACE)
+	    {
+	      if (gfc_add_interface (sym) == FAILURE)
+		return MATCH_ERROR;
+	    }
+	  else
+	    {
+	      if (!sym->attr.pointer)
+		sym->attr.external = 1;
+	      if (gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE)
+		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 (sym->interface && sym->interface->attr.if_source)
+	    {
+	      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);
+	    }
+
+	  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 127848)
+++ 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;
@@ -642,7 +642,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.  */
 
@@ -1014,6 +1015,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;
 
@@ -2163,6 +2166,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 127848)
+++ gcc/fortran/resolve.c	(working copy)
@@ -1440,6 +1440,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)
@@ -7218,6 +7221,16 @@ resolve_symbol (gfc_symbol *sym)
 	}
     }
 
+  if (sym->attr.procedure && sym->interface
+      && sym->attr.if_source != IFSRC_DECL)
+    {
+      /* 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);
+    }
+
   if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
     return;
 
Index: gcc/fortran/match.h
===================================================================
--- gcc/fortran/match.h	(revision 127848)
+++ 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 127848)
+++ 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);

Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(revision 127848)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -3474,6 +3474,23 @@ gfc_trans_pointer_assignment (gfc_expr *
 
   gfc_start_block (&block);
 
+  if (expr1->symtree->n.sym->attr.procedure)
+    {
+      tree lhs, rhs;
+      gcc_assert (expr1->symtree->n.sym->attr.pointer);
+      if (!expr1->symtree->n.sym->backend_decl)
+	expr1->symtree->n.sym->backend_decl
+		= gfc_get_extern_function_decl (expr1->symtree->n.sym);
+      lhs = expr1->symtree->n.sym->backend_decl;
+      if (!expr2->symtree->n.sym->backend_decl)
+	expr2->symtree->n.sym->backend_decl
+		= gfc_get_symbol_decl (expr2->symtree->n.sym);
+      rhs = expr2->symtree->n.sym->backend_decl;
+      gfc_add_modify_expr (&block, lhs,
+			   fold_convert (TREE_TYPE (lhs), build_fold_addr_expr (rhs)));
+      return gfc_finish_block (&block);
+    }
+
   gfc_init_se (&lse, NULL);
 
   lss = gfc_walk_expr (expr1);
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 127848)
+++ gcc/fortran/symbol.c	(working copy)
@@ -588,7 +588,8 @@ check_conflict (symbol_attribute *attr, 
 
       if (attr->subroutine)
 	{
-	  conf2 (pointer);
+	  /* this was commented out to allow procedure pointers */
+	  /*conf2 (pointer);*/
 	  conf2 (target);
 	  conf2 (allocatable);
 	  conf2 (result);
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 127848)
+++ gcc/fortran/resolve.c	(working copy)
@@ -5794,11 +5794,16 @@ resolve_code (gfc_code *code, gfc_namesp
 	    omp_workshare_flag = omp_workshare_save;
 	}
 
+    if (code->op != EXEC_POINTER_ASSIGN)
+    {
       t = gfc_resolve_expr (code->expr);
       forall_flag = forall_save;
 
       if (gfc_resolve_expr (code->expr2) == FAILURE)
 	t = FAILURE;
+    }
+    else
+      t = SUCCESS;
 
       switch (code->op)
 	{
@@ -5940,6 +5945,10 @@ resolve_code (gfc_code *code, gfc_namesp
 	  break;
 
 	case EXEC_POINTER_ASSIGN:
+
+	  if (code->expr->symtree->n.sym->attr.procedure)
+	    break;
+
 	  if (t == FAILURE)
 	    break;
 
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(revision 127848)
+++ gcc/fortran/trans-decl.c	(working copy)
@@ -1143,6 +1143,16 @@ gfc_get_extern_function_decl (gfc_symbol
   type = gfc_get_function_type (sym);
   fndecl = build_decl (FUNCTION_DECL, name, type);
 
+  if (sym->attr.procedure && sym->attr.pointer)
+  {
+    type = build_pointer_type (type);
+    sym->backend_decl = build_decl (VAR_DECL, name, type);
+    DECL_CONTEXT (sym->backend_decl) = sym->ns->proc_name->backend_decl;
+    TREE_STATIC (sym->backend_decl) = 1;
+    DECL_ARTIFICIAL (sym->backend_decl) = 1;
+    return sym->backend_decl;
+  }
+
   SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
   /* If the return type is a pointer, avoid alias issues by setting
      DECL_IS_MALLOC to nonzero. This means that the function should be
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c	(revision 127848)
+++ gcc/fortran/match.c	(working copy)
@@ -1323,6 +1323,30 @@ gfc_match_pointer_assignment (void)
       goto cleanup;
     }
 
+  /* procedure pointer assignment */
+  if (lvalue->symtree->n.sym->attr.procedure)
+    {
+      gfc_symtree *st;
+      gfc_symbol *sym;
+
+      m = gfc_match_sym_tree (&st, 1);
+
+      if (m != MATCH_YES)
+	goto cleanup;
+
+      sym = st->n.sym;
+      gfc_set_sym_referenced (sym);
+
+      rvalue = gfc_get_expr ();
+
+      rvalue->expr_type = EXPR_FUNCTION;
+      rvalue->symtree = st;
+      rvalue->ts = sym->ts;
+      rvalue->where = gfc_current_locus;
+      goto done;
+    }
+
+
   m = gfc_match (" %e%t", &rvalue);
   if (m != MATCH_YES)
     goto cleanup;
@@ -1335,6 +1359,7 @@ gfc_match_pointer_assignment (void)
       goto cleanup;
     }
 
+done:
   new_st.op = EXEC_POINTER_ASSIGN;
   new_st.expr = lvalue;
   new_st.expr2 = rvalue;
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(revision 127848)
+++ gcc/fortran/primary.c	(working copy)
@@ -2510,6 +2510,18 @@ match_variable (gfc_expr **result, int e
 	  break;
 	}
 
+     if (sym->attr.procedure && sym->attr.pointer)
+	{
+	  expr = gfc_get_expr ();
+
+	  expr->expr_type = EXPR_FUNCTION;
+	  expr->symtree = st;
+	  expr->ts = sym->ts;
+	  expr->where = where;
+	  *result = expr;
+	  return MATCH_YES;
+	}
+
       /* Fall through to error */
 
     default:

program ppt1

implicit none

abstract interface
  subroutine abssub()
  end subroutine abssub
end interface

procedure(abssub), pointer:: p

p=>p1
call p

p=>p2
call p

return

contains

  subroutine p1
    write(*,*) "procedure #1 called"
  end subroutine

  subroutine p2
    write(*,*) "procedure #2 called"
  end subroutine

end program 

program ppt1

implicit none

abstract interface
  real function absfun()
  end function absfun
end interface

procedure(absfun), pointer:: p

p=>p1
print *,p()

p=>p2
print *,p()

return

contains

  real function p1()
    write(*,*) "function #1 called"
    p1=1.1
  end function

  real function p2()
    write(*,*) "procedure #2 called"
    p2=2.2
  end function

end program