procedure declaration
Paul Thomas
paulthomas2@wanadoo.fr
Sun Jun 24 19:45:00 GMT 2007
Janus,
/I do not know why you are having the trouble that you are; this part
of the patch should be OK.
I have very little time right now, being between trips and not having
time to do the job that pays for the groceries. So what I have done,
is to enclose a patch the predates the previous one but which should
have the same front end. Look to see what is missing in the version
that you have.
I am sorry that something has gone pear-shaped - I'll try to be back to
help properly asap.
Paul
/
> Hi all,
> I modified Paul's patch on the PROCEDURE machinery to include some of
> Christopher's work and to handle formal argument lists right (patch is
> attached). I hope this works now, at least I get no more ICE's.
> But when trying to compile the attached simple test program, I now get
> the following error:
>
> simple.f90:17.18:
>
> integer function a (x)
> 1
> simple.f90:11.19:
>
> procedure(w) :: a
> 2
> Error: Procedure 'a' at (1) has an explicit interface and must not
> have attributes declared at (2)
>
> This error comes from decl.c(get_proc_name):
>
> /* Trap declarations of attributes in encompassing scope. The
> signature for this is that ts.kind is set. Legitimate
> references only set ts.type. */
> if (sym->ts.kind != 0
> && !sym->attr.implicit_type
> && sym->attr.proc == 0
> && gfc_current_ns->parent != NULL
> && sym->attr.access == 0
> && !module_fcn_entry)
> gfc_error_now ("Procedure '%s' at %C has an explicit interface "
> "and must not have attributes declared at %L",
> name, &sym->declared_at);
> }
>
> What am I doing wrong? Or what would be the best way to get rid of
> this error?
> Should I include (sym->attr.procedure==0) in the above if statement?
> Or should I rather modify sym->attr.proc in gfc_match_procedure?
> (Maybe sym->attr.proc=PROC_INTERNAL in this case?)
> Any other suggestions?
>
> Cheers,
> Janus
> ------------------------------------------------------------------------
>
> program simple
>
> implicit none
>
> abstract interface
> integer function w (x)
> real x
> end function w
> END INTERFACE
>
> procedure(w) :: a
>
> print *, a (2.0)
>
> contains
>
> 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 125971)
> +++ 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 125971)
> +++ 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 125971)
> +++ gcc/fortran/symbol.c (working copy)
> @@ -2059,7 +2059,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);
> }
> @@ -2869,3 +2870,111 @@
>
> return s;
> }
> +
> +
> +/* Add a formal argument, gfc_formal_arglist, to the
> + end of the given list of arguments. Set the reference to the
> + provided symbol, param_sym, in the argument. */
> +
> +static void
> +add_formal_arg (gfc_formal_arglist **head,
> + gfc_formal_arglist **tail,
> + gfc_formal_arglist *formal_arg,
> + gfc_symbol *param_sym)
> +{
> + /* Put in list, either as first arg or at the tail (curr arg). */
> + if (*head == NULL)
> + *head = *tail = formal_arg;
> + else
> + {
> + (*tail)->next = formal_arg;
> + (*tail) = formal_arg;
> + }
> +
> + (*tail)->sym = param_sym;
> + (*tail)->next = NULL;
> +
> + return;
> +}
> +
> +
> +/* Add a procedure interface to the given symbol (i.e., store a
> + reference to the list of formal arguments). */
> +
> +static void
> +add_proc_interface (gfc_symbol *sym, ifsrc source,
> + gfc_formal_arglist *formal)
> +{
> +
> + sym->formal = formal;
> + 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;
> + gfc_namespace *parent_ns = NULL;
> +
> + /* Save current namespace so we can change it for formal args. */
> + 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;
> +
> + curr_arg = src->formal;
> + formal_prev = NULL;
> + while (curr_arg != NULL)
> + {
> + /* Allocate a new struct for the formal arg. */
> + formal_arg = gfc_get_formal_arglist ();
> +
> + /* Create symbol for the arg. */
> + 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;
> +}
> Index: gcc/fortran/decl.c
> ===================================================================
> --- gcc/fortran/decl.c (revision 125971)
> +++ gcc/fortran/decl.c (working copy)
> @@ -2839,6 +2839,169 @@
> }
>
>
> +/* Match a procedure declaration. */
> +
> +match
> +gfc_match_procedure (void)
> +{
> + gfc_symbol *sym, *s = NULL;
> + locus old_loc, entry_loc;
> + match m;
> + char *src_attr,*dest_attr;
> + int i=0;
> +
> + 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 (¤t_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 (¤t_ts, 0);
> + if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_char() == ')'))
> + goto got_ts;
> +
> + gfc_current_locus = old_loc;
> +
> + // get name of procedure or abstract interface to inherit interface from
> + 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;
> + }
> +
> + // get attributes: pointer, private
> + gfc_clear_attr (¤t_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;
> +
> + // 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 && s == NULL)
> + sym->ts = current_ts;
> +
> + if (s != NULL)
> + {
> + // copy typespec & formal args from inherited procedure/interface
> + sym->ts = s->ts;
> + copy_formal_args(sym,s);
> + /* Copy the attributes. These are an or of what the
> + user lists, and what is defined for the interface proc. */
> + sym->attr = s->attr;
> + 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++;
> + }
> +
> + if (s->attr.subroutine == 1)
> + gfc_add_subroutine (&(sym->attr), sym->name,&gfc_current_locus);
> + else if (s->attr.function == 1)
> + gfc_add_function (&(sym->attr), sym->name,&gfc_current_locus);
> + else
> + {
> + gfc_error ("Symbol '%s' at %C must be either a subroutine or function", sym->name);
> + return MATCH_ERROR;
> + }
> + }
> +
> + //sym->attr.flavor = FL_PROCEDURE;
> + sym->attr.procedure = 1;
> + //sym->attr.proc=...;
> +
> + 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
> @@ -3857,6 +4020,7 @@
> switch (type)
> {
> case INTERFACE_NAMELESS:
> + case INTERFACE_ABSTRACT:
> goto syntax;
>
> case INTERFACE_GENERIC:
> Index: gcc/fortran/gfortran.h
> ===================================================================
> --- gcc/fortran/gfortran.h (revision 125971)
> +++ 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. */
> @@ -2040,6 +2041,8 @@
> 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/module.c
> ===================================================================
> --- gcc/fortran/module.c (revision 125971)
> +++ 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 125971)
> +++ 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
> @@ -5169,11 +5179,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)
> {
> @@ -5303,6 +5318,10 @@
> break;
>
> case EXEC_POINTER_ASSIGN:
> +
> + if (code->expr->symtree->n.sym->attr.procedure)
> + break;
> +
> if (t == FAILURE)
> break;
>
> @@ -6265,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;
>
> @@ -7475,9 +7505,8 @@
> gfc_namespace *old_ns;
>
> old_ns = gfc_current_ns;
> -
> resolve_types (ns);
> resolve_codes (ns);
> -
> +
> gfc_current_ns = old_ns;
> }
> Index: gcc/fortran/match.c
> ===================================================================
> --- gcc/fortran/match.c (revision 125971)
> +++ 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 125971)
> +++ 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 125971)
> +++ 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 125971)
> +++ 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 = "PROCEDURE";
> + 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 125971)
> +++ 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:
>
-------------- next part --------------
A non-text attachment was scrubbed...
Name: proc300307.diff
Type: text/x-patch
Size: 15620 bytes
Desc: not available
URL: <http://gcc.gnu.org/pipermail/fortran/attachments/20070624/264317c6/attachment.bin>
More information about the Fortran
mailing list