SoC fortran procedure pointers

Paul Thomas paulthomas2@wanadoo.fr
Wed Jun 20 05:51:00 GMT 2007


Janus,

No I did not.  I'll have to investigate a bit later on.  Are you sure 
that the patch applied cleanly?  That error message comes from 
symbol.c(check_conflict) (I think that I have the function name right :-) ).

I'll come back to you tonight.

Cheers

Paul
> Hi Paul,
> I've been looking through your patch for procedure pointers and have
> been playing around with it a little. You said it already works for
> procedure declarations and abstract interfaces. But when I try to
> compile your test program, I get the following error:
>
> test_procedure.f90:27.22:
>
> integer function a (x)
>                     1
> Error: EXTERNAL attribute conflicts with FUNCTION attribute in 'a' at (1)
>
>
> Did you also get similar errors or can you tell me what this error means?
> I attached the patch I used, which is basically yours patched against
> trunk revision 125790, and the test program.
> Cheers,
> Janus
> ------------------------------------------------------------------------
>
> program test_procedure
>
> implicit none
>
>   abstract interface
>     integer function w (x)
>       real x
>     end function w
>   END INTERFACE
>
>   procedure(w) :: a
>   procedure (a), pointer :: b ! accepted but segfaults at run-time
>
>   b => a
>
>   print *, a (2.0)
>   print *, b(3.0)
>   print *, z(a)
>
> contains
>
>   integer function z(i)
>     procedure(w) :: i
>     z = i(5.0)
>   end function z
>
> integer function a (x)
>   real x
>   a = 2* int(x)
> end function a
>
> end program
> ------------------------------------------------------------------------
>
> Index: gcc/fortran/interface.c
> ===================================================================
> --- gcc/fortran/interface.c	(revision 125790)
> +++ gcc/fortran/interface.c	(working copy)
> @@ -176,7 +176,8 @@
>  }
>  
>  
> -/* Match one of the five forms of an interface statement.  */
> +/* Match one of the five F95 forms of an interface statement.  The
> +   matcher for the abstract interface follows.  */
>  
>  match
>  gfc_match_interface (void)
> @@ -233,6 +234,7 @@
>        break;
>  
>      case INTERFACE_NAMELESS:
> +    case INTERFACE_ABSTRACT:
>        break;
>      }
>  
> @@ -240,6 +242,33 @@
>  }
>  
>  
> +
> +/* Match an F2003 abstract interface.  */
> +
> +match
> +gfc_match_abstract_interface (void)
> +{
> +  match m;
> +
> +  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ABSTRACT INTERFACE at %C")
> +		      == FAILURE)
> +    return MATCH_ERROR;
> +
> +  m = gfc_match_eos ();
> +
> +  if (m != MATCH_YES)
> +    {
> +      gfc_error ("Syntax error: Garbage in ABSTRACT INTERFACE statement "
> +		 "at %C");
> +      return MATCH_ERROR;
> +    }
> +
> +  current_interface.type = INTERFACE_ABSTRACT;
> +
> +  return m;
> +}
> +
> +
>  /* Match the different sort of generic-specs that can be present after
>     the END INTERFACE itself.  */
>  
> @@ -271,7 +300,8 @@
>    switch (current_interface.type)
>      {
>      case INTERFACE_NAMELESS:
> -      if (type != current_interface.type)
> +    case INTERFACE_ABSTRACT:
> +      if (type != INTERFACE_NAMELESS)
>  	{
>  	  gfc_error ("Expected a nameless interface at %C");
>  	  m = MATCH_ERROR;
> @@ -2128,6 +2158,7 @@
>    switch (current_interface.type)
>      {
>      case INTERFACE_NAMELESS:
> +    case INTERFACE_ABSTRACT:
>        return SUCCESS;
>  
>      case INTERFACE_INTRINSIC_OP:
> Index: gcc/fortran/trans-expr.c
> ===================================================================
> --- gcc/fortran/trans-expr.c	(revision 125790)
> +++ gcc/fortran/trans-expr.c	(working copy)
> @@ -3306,6 +3306,23 @@
>  
>    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 125790)
> +++ gcc/fortran/symbol.c	(working copy)
> @@ -2062,7 +2062,8 @@
>    if (!sym->attr.generic_copy)
>      gfc_free_interface (sym->generic);
>  
> -  gfc_free_formal_arglist (sym->formal);
> +  if (!sym->attr.procedure)
> +    gfc_free_formal_arglist (sym->formal);
>  
>    gfc_free (sym);
>  }
> Index: gcc/fortran/decl.c
> ===================================================================
> --- gcc/fortran/decl.c	(revision 125790)
> +++ gcc/fortran/decl.c	(working copy)
> @@ -2831,6 +2831,152 @@
>  }
>  
>  
> +/* Match a procedure declaration.  */
> +
> +match
> +gfc_match_procedure (void)
> +{
> +/*  char name[GFC_MAX_SYMBOL_LEN + 1];*/
> +  gfc_symbol *sym, *s = 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)
> +    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;
> +    }
> +
> +  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;
> +
> +  m = gfc_match_symbol (&s, 1);
> +
> +  if (m == MATCH_ERROR)
> +        goto syntax;
> +
> +got_ts:
> +
> +  if (gfc_match (" )") != MATCH_YES)
> +    {
> +      gfc_current_locus =entry_loc;
> +      return MATCH_NO;
> +    }
> +
> +  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;
> +	}
> +      
> +      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;
> +
> +  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;
> +
> +	  if (current_ts.type != BT_UNKNOWN && s == NULL)
> +            sym->ts = current_ts;
> +
> +	  if (s != NULL && !(s->attr.procedure && s->formal == NULL))
> +	    {
> +	      sym->formal = gfc_get_formal_arglist ();
> +	      if (s->attr.procedure)
> +	        sym->formal->sym = s->formal->sym;
> +	      else
> +		sym->formal->sym = s;
> +	    }
> +
> +	  if (s != NULL && s->attr.procedure && s->formal == NULL)
> +	    sym->ts = s->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
> @@ -3849,6 +3995,7 @@
>        switch (type)
>  	{
>  	case INTERFACE_NAMELESS:
> +	case INTERFACE_ABSTRACT:
>  	  goto syntax;
>  
>  	case INTERFACE_GENERIC:
> Index: gcc/fortran/gfortran.h
> ===================================================================
> --- gcc/fortran/gfortran.h	(revision 125790)
> +++ gcc/fortran/gfortran.h	(working copy)
> @@ -241,7 +241,7 @@
>    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;
> @@ -252,7 +252,7 @@
>  typedef enum
>  {
>    INTERFACE_NAMELESS = 1, INTERFACE_GENERIC,
> -  INTERFACE_INTRINSIC_OP, INTERFACE_USER_OP
> +  INTERFACE_INTRINSIC_OP, INTERFACE_USER_OP, INTERFACE_ABSTRACT
>  }
>  interface_type;
>  
> @@ -568,13 +568,14 @@
>      use_only:1;			/* Symbol has been use-associated, with ONLY.  */
>  
>    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.  */
>  
>    /* Function/subroutine attributes */
>    unsigned sequence:1, elemental:1, pure:1, recursive:1;
> -  unsigned unmaskable:1, masked:1, contained:1, mod_proc:1;
> +  unsigned unmaskable:1, masked:1, contained:1, mod_proc:1, abstract:1;
>  
>    /* This is set if the subroutine doesn't return.  Currently, this
>       is only possible for intrinsic subroutines.  */
> Index: gcc/fortran/module.c
> ===================================================================
> --- gcc/fortran/module.c	(revision 125790)
> +++ gcc/fortran/module.c	(working copy)
> @@ -590,6 +590,7 @@
>        switch (type)
>  	{
>  	case INTERFACE_NAMELESS:
> +	case INTERFACE_ABSTRACT:
>  	  gfc_error ("Missing generic specification in USE statement at %C");
>  	  goto cleanup;
>  
> @@ -1503,7 +1504,7 @@
>    AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE,
>    AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
>    AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
> -  AB_VALUE, AB_VOLATILE, AB_PROTECTED
> +  AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_ABSTRACT
>  }
>  ab_attribute;
>  
> @@ -1537,6 +1538,7 @@
>      minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
>      minit ("ALLOC_COMP", AB_ALLOC_COMP),
>      minit ("PROTECTED", AB_PROTECTED),
> +    minit ("ABSTRACT", AB_ABSTRACT),
>      minit (NULL, -1)
>  };
>  
> @@ -1618,6 +1620,8 @@
>  	MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits);
>        if (attr->generic)
>  	MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits);
> +      if (attr->abstract)
> +	MIO_NAME (ab_attribute) (AB_ABSTRACT, attr_bits);
>  
>        if (attr->sequence)
>  	MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits);
> @@ -1711,6 +1715,9 @@
>  	    case AB_GENERIC:
>  	      attr->generic = 1;
>  	      break;
> +	    case AB_ABSTRACT:
> +	      attr->abstract = 1;
> +	      break;
>  	    case AB_SEQUENCE:
>  	      attr->sequence = 1;
>  	      break;
> Index: gcc/fortran/resolve.c
> ===================================================================
> --- gcc/fortran/resolve.c	(revision 125790)
> +++ gcc/fortran/resolve.c	(working copy)
> @@ -1365,6 +1365,9 @@
>  {
>    match m;
>  
> +  if (sym->attr.procedure)
> +    goto found;
> +
>    if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY)
>      {
>        if (sym->attr.dummy)
> @@ -1565,6 +1568,13 @@
>        return FAILURE;
>      }
>  
> +  if (sym && sym->attr.abstract)
> +    {
> +      gfc_error ("ABSTRACT INTERFACE '%s' must not be referenced at %L",
> +		 sym->name, &expr->where);
> +      return FAILURE;
> +    }
> +
>    /* If the procedure is not internal, a statement function or a module
>       procedure,it must be external and should be checked for usage.  */
>    if (sym && !sym->attr.dummy && !sym->attr.contained
> @@ -2936,7 +2946,16 @@
>  
>        case REF_SUBSTRING:
>  	resolve_substring (ref);
> -	break;
> +	
> +        expr->ts.cl = gfc_get_charlen ();
> +	expr->ts.cl->next = gfc_current_ns->cl_list;
> +	gfc_current_ns->cl_list = expr->ts.cl;
> +	expr->ts.cl->length = gfc_subtract (gfc_copy_expr (ref->u.ss.end),
> +					    gfc_copy_expr (ref->u.ss.start));
> +	expr->ts.cl->length = gfc_add (expr->ts.cl->length, gfc_int_expr (1));
> +	gfc_simplify_expr (expr->ts.cl->length, 0);
> +	expr->ts.cl->length->where = expr->where;
> +        break;
>        }
>  
>    /* Check constraints on part references.  */
> @@ -5163,11 +5182,16 @@
>  	    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)
>  	{
> @@ -5294,6 +5318,10 @@
>  	  break;
>  
>  	case EXEC_POINTER_ASSIGN:
> +
> +	  if (code->expr->symtree->n.sym->attr.procedure)
> +	    break;
> +
>  	  if (t == FAILURE)
>  	    break;
>  
> @@ -6256,6 +6284,17 @@
>  	}
>      }
>  
> +  if (sym->attr.procedure && sym->formal != NULL)
> +    {
> +      gfc_formal_arglist *f = sym->formal;
> +      sym->ts = f->sym->ts;
> +      sym->attr.function = f->sym->attr.function;
> +      sym->attr.subroutine = f->sym->attr.subroutine;
> +      sym->formal = f->sym->formal;
> +      sym->attr.if_source = IFSRC_DECL;
> +      gfc_free_formal_arglist (f);
> +    }
> +
>    if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
>      return;
>  
> @@ -7451,9 +7490,8 @@
>    gfc_namespace *old_ns;
>  
>    old_ns = gfc_current_ns;
> -
>    resolve_types (ns);
>    resolve_codes (ns);
> -
> + 
>    gfc_current_ns = old_ns;
>  }
> Index: gcc/fortran/iresolve.c
> ===================================================================
> --- gcc/fortran/iresolve.c	(revision 125790)
> +++ gcc/fortran/iresolve.c	(working copy)
> @@ -33,6 +33,7 @@
>  #include "coretypes.h"
>  #include "tree.h"
>  #include "gfortran.h"
> +#include "arith.h"
>  #include "intrinsic.h"
>  
>  /* Given printf-like arguments, return a stable version of the result string. 
> @@ -1721,7 +1722,29 @@
>  			     ? PREFIX ("reshape_char") : PREFIX ("reshape"));
>        break;
>      }
> +    
> +  if (source->ts.type == BT_CHARACTER
> +      && source->ref != NULL)
> +    {
> +      gfc_ref *ref;
> +      for (ref = source->ref; ref; ref = ref->next)
> +      if (ref->next == NULL && ref->type == REF_SUBSTRING)
> +        break;
> +      if (ref != NULL)
> +      {
> +        f->ts.type = BT_CHARACTER;
> +        f->ts.kind = gfc_default_character_kind;
> +        f->ts.cl = gfc_get_charlen ();
> +        f->ts.cl->next = gfc_current_ns->cl_list;
> +        gfc_current_ns->cl_list = f->ts.cl;
> +        f->ts.cl->length = gfc_subtract (gfc_copy_expr (ref->u.ss.start),
> +					 gfc_copy_expr (ref->u.ss.end));
> +        f->ts.cl->length = gfc_add (f->ts.cl->length, gfc_int_expr (1));
>  
> +        gfc_simplify_expr (f->ts.cl->length, 0);
> +      }
> +    }
> +
>    /* TODO: Make this work with a constant ORDER parameter.  */
>    if (shape->expr_type == EXPR_ARRAY
>        && gfc_is_constant_expr (shape)
> Index: gcc/fortran/match.c
> ===================================================================
> --- gcc/fortran/match.c	(revision 125790)
> +++ gcc/fortran/match.c	(working copy)
> @@ -949,6 +949,30 @@
>        goto cleanup;
>      }
>  
> +
> +  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;
> @@ -961,6 +985,7 @@
>        goto cleanup;
>      }
>  
> +done:
>    new_st.op = EXEC_POINTER_ASSIGN;
>    new_st.expr = lvalue;
>    new_st.expr2 = rvalue;
> Index: gcc/fortran/trans-decl.c
> ===================================================================
> --- gcc/fortran/trans-decl.c	(revision 125790)
> +++ gcc/fortran/trans-decl.c	(working copy)
> @@ -1098,6 +1098,16 @@
>    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.h
> ===================================================================
> --- gcc/fortran/match.h	(revision 125790)
> +++ gcc/fortran/match.h	(working copy)
> @@ -124,6 +124,7 @@
>  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);
> @@ -171,6 +172,7 @@
>  match gfc_match_array_constructor (gfc_expr **);
>  
>  /* interface.c.  */
> +match gfc_match_abstract_interface (void);
>  match gfc_match_generic_spec (interface_type *, char *, gfc_intrinsic_op *);
>  match gfc_match_interface (void);
>  match gfc_match_end_interface (void);
> Index: gcc/fortran/parse.c
> ===================================================================
> --- gcc/fortran/parse.c	(revision 125790)
> +++ gcc/fortran/parse.c	(working copy)
> @@ -173,6 +173,7 @@
>    switch (c)
>      {
>      case 'a':
> +      match ("abstract interface", gfc_match_abstract_interface, ST_INTERFACE);
>        match ("allocate", gfc_match_allocate, ST_ALLOCATE);
>        match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
>        match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT);
> @@ -256,6 +257,7 @@
>        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 +719,8 @@
>  
>  #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 +1079,9 @@
>      case ST_PROGRAM:
>        p = "PROGRAM";
>        break;
> +    case ST_PROCEDURE:
> +      p = "PROGRAM";
> +      break;
>      case ST_READ:
>        p = "READ";
>        break;
> @@ -1772,6 +1778,9 @@
>  	}
>      }
>  
> +  if (current_interface.type == INTERFACE_ABSTRACT)
> +    gfc_new_block->attr.abstract = 1;
> +
>    push_state (&s2, new_state, gfc_new_block);
>    accept_statement (st);
>    prog_unit = gfc_new_block;
> Index: gcc/fortran/primary.c
> ===================================================================
> --- gcc/fortran/primary.c	(revision 125790)
> +++ gcc/fortran/primary.c	(working copy)
> @@ -2440,6 +2440,18 @@
>  	  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:
>   




More information about the Fortran mailing list