From 6977374226b230fe6e6d9b5ce2615bea094cb0f1 Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Tue, 4 Sep 2007 13:50:35 +0000 Subject: decl.c (match_procedure_decl,match_procedure_in_interface, [...]): Handle PROCEDURE statements. 2007-09-04 Janus Weil Paul Thomas * decl.c (match_procedure_decl,match_procedure_in_interface, gfc_match_procedure): Handle PROCEDURE statements. * gfortran.h (struct gfc_symbol): New member "gfc_symbol *interface". (enum gfc_statement): New element "ST_PROCEDURE". (strcut symbol_attribute): New member "unsigned procedure". * interface.c (check_interface0): Extended error checking. * match.h: Add gfc_match_procedure prototype. * parse.c (decode_statement,next_statement,gfc_ascii_statement, parse_derived,parse_interface): Implement PROCEDURE statements. * resolve.c (resolve_symbol): Ditto. * symbol.c (check_conflict): Ditto. (gfc_add_proc): New function for setting the procedure attribute. (copy_formal_args): New function for copying formal argument lists. 2007-09-04 Janus Weil Tobias Burnus * gfortran.dg/proc_decl_1.f90: New. * gfortran.dg/proc_decl_2.f90: New. * gfortran.dg/proc_decl_3.f90: New. * gfortran.dg/proc_decl_4.f90: New. Co-Authored-By: Paul Thomas Co-Authored-By: Tobias Burnus From-SVN: r128081 --- gcc/fortran/ChangeLog | 17 ++++ gcc/fortran/decl.c | 242 ++++++++++++++++++++++++++++++++++++++++++++++++ gcc/fortran/gfortran.h | 10 +- gcc/fortran/interface.c | 3 +- gcc/fortran/match.h | 1 + gcc/fortran/parse.c | 9 +- gcc/fortran/resolve.c | 19 ++++ gcc/fortran/symbol.c | 98 +++++++++++++++++++- 8 files changed, 393 insertions(+), 6 deletions(-) (limited to 'gcc/fortran') diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 5e0a0f5..6ac59b6 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,20 @@ +2007-09-04 Janus Weil + Paul Thomas + + * decl.c (match_procedure_decl,match_procedure_in_interface, + gfc_match_procedure): Handle PROCEDURE statements. + * gfortran.h (struct gfc_symbol): New member "gfc_symbol *interface". + (enum gfc_statement): New element "ST_PROCEDURE". + (strcut symbol_attribute): New member "unsigned procedure". + * interface.c (check_interface0): Extended error checking. + * match.h: Add gfc_match_procedure prototype. + * parse.c (decode_statement,next_statement,gfc_ascii_statement, + parse_derived,parse_interface): Implement PROCEDURE statements. + * resolve.c (resolve_symbol): Ditto. + * symbol.c (check_conflict): Ditto. + (gfc_add_proc): New function for setting the procedure attribute. + (copy_formal_args): New function for copying formal argument lists. + 2007-09-03 Daniel Jacobowitz * Make-lang.in (gfortranspec.o): Remove SHLIB_MULTILIB. diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index b1f4f35..470cbfa 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -3759,6 +3759,248 @@ gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result) } +/* Match a PROCEDURE declaration (R1211). */ + +static match +match_procedure_decl (void) +{ + match m; + locus old_loc, entry_loc; + gfc_symbol *sym, *proc_if = NULL; + int num; + + old_loc = entry_loc = gfc_current_locus; + + 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; + + if (m == MATCH_ERROR) + return m; + + gfc_current_locus = old_loc; + + /* Get the name of the procedure or abstract interface + to inherit the interface from. */ + m = gfc_match_symbol (&proc_if, 1); + + if (m == MATCH_NO) + goto syntax; + else if (m == MATCH_ERROR) + return m; + + /* Various interface checks. */ + if (proc_if) + { + if (proc_if->generic) + { + gfc_error ("Interface '%s' at %C may not be generic", proc_if->name); + return MATCH_ERROR; + } + if (proc_if->attr.proc == PROC_ST_FUNCTION) + { + gfc_error ("Interface '%s' at %C may not be a statement function", + 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_intrinsic_actual_ok (proc_if->name, 0)) + { + gfc_error ("Intrinsic procedure '%s' not allowed " + "in PROCEDURE statement at %C", proc_if->name); + return MATCH_ERROR; + } + /* TODO: Allow intrinsics with gfc_intrinsic_actual_ok + (proc_if->name, 0) after PR33162 is fixed. */ + if (proc_if->attr.intrinsic) + { + gfc_error ("Fortran 2003: Support for intrinsic procedure '%s' " + "in PROCEDURE statement at %C not yet implemented " + "in gfortran", proc_if->name); + return MATCH_ERROR; + } + } + +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; + + /* Get procedure symbols. */ + for(num=1;;num++) + { + + m = gfc_match_symbol (&sym, 0); + if (m == MATCH_NO) + goto syntax; + else if (m == MATCH_ERROR) + return m; + + /* Add current_attr to the symbol attributes. */ + if (gfc_copy_attr (&sym->attr, ¤t_attr, NULL) == FAILURE) + return MATCH_ERROR; + + if (sym->attr.is_bind_c) + { + /* Check for C1218. */ + if (!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 C1217. */ + if (has_name_equals && sym->attr.pointer) + { + gfc_error ("BIND(C) procedure with NAME may not have " + "POINTER attribute at %C"); + return MATCH_ERROR; + } + if (has_name_equals && 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 (!sym->attr.pointer && gfc_add_external (&sym->attr, NULL) == FAILURE) + return MATCH_ERROR; + if (gfc_add_proc (&sym->attr, 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; + sym->ts = sym->interface->ts; + sym->attr.function = sym->interface->attr.function; + } + + if (gfc_match_eos () == MATCH_YES) + return MATCH_YES; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + } + +syntax: + gfc_error ("Syntax error in PROCEDURE statement at %C"); + return MATCH_ERROR; +} + + +/* Match a PROCEDURE declaration inside an interface (R1206). */ + +static match +match_procedure_in_interface (void) +{ + match m; + gfc_symbol *sym; + char name[GFC_MAX_SYMBOL_LEN + 1]; + + 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; + } + + for(;;) + { + m = gfc_match_name (name); + if (m == MATCH_NO) + goto syntax; + else if (m == MATCH_ERROR) + return m; + if (gfc_get_symbol (name, gfc_current_ns->parent, &sym)) + return MATCH_ERROR; + + if (gfc_add_interface (sym) == FAILURE) + return MATCH_ERROR; + + sym->attr.procedure = 1; + + 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; +} + + +/* General matcher for PROCEDURE declarations. */ + +match +gfc_match_procedure (void) +{ + match m; + + switch (gfc_current_state ()) + { + case COMP_NONE: + case COMP_PROGRAM: + case COMP_MODULE: + case COMP_SUBROUTINE: + case COMP_FUNCTION: + 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; + default: + return MATCH_NO; + } + + if (m != MATCH_YES) + return m; + + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROCEDURE statement at %C") + == FAILURE) + return MATCH_ERROR; + + return m; +} + + /* Match a function declaration. */ match diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index b9c6c31..bfd1af8 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -222,7 +222,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; @@ -589,7 +589,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. */ @@ -961,6 +962,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; @@ -2039,6 +2042,7 @@ try gfc_add_recursive (symbol_attribute *, locus *); try gfc_add_function (symbol_attribute *, const char *, locus *); try gfc_add_subroutine (symbol_attribute *, const char *, locus *); try gfc_add_volatile (symbol_attribute *, const char *, locus *); +try gfc_add_proc (symbol_attribute *attr, const char *name, locus *where); try gfc_add_access (symbol_attribute *, gfc_access, const char *, locus *); try gfc_add_is_bind_c(symbol_attribute *, const char *, locus *, int); @@ -2110,6 +2114,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; diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 7bb5a25..741bba5 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -986,7 +986,8 @@ check_interface0 (gfc_interface *p, const char *interface_name) /* Make sure all symbols in the interface have been defined as functions or subroutines. */ for (; p; p = p->next) - if (!p->sym->attr.function && !p->sym->attr.subroutine) + if ((!p->sym->attr.function && !p->sym->attr.subroutine) + || !p->sym->attr.if_source) { if (p->sym->attr.external) gfc_error ("Procedure '%s' in %s at %L has no explicit interface", diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 0909617..4841f33 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -133,6 +133,7 @@ match gfc_match_old_kind_spec (gfc_typespec *); 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); diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 38e62cd..50c0c0d 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -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; @@ -1537,6 +1542,7 @@ parse_derived (void) unexpected_eof (); case ST_DATA_DECL: + case ST_PROCEDURE: accept_statement (st); seen_component = 1; break; @@ -1749,6 +1755,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); diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 424acfc..76a20a4 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -7362,6 +7362,25 @@ 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). */ + if (sym->interface->attr.if_source || sym->interface->attr.intrinsic) + { + 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); + } + else if (sym->interface->name[0] != '\0') + { + gfc_error ("Interface '%s' of procedure '%s' at %L must be explicit", + sym->interface->name, sym->name, &sym->declared_at); + return; + } + } + if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE) return; diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 6f91e75..69a675b 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -352,7 +352,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER", *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE", *volatile_ = "VOLATILE", *protected = "PROTECTED", - *is_bind_c = "BIND(C)"; + *is_bind_c = "BIND(C)", *procedure = "PROCEDURE"; static const char *threadprivate = "THREADPRIVATE"; const char *a1, *a2; @@ -438,7 +438,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (external, intrinsic); - if (attr->if_source || attr->contained) + if ((attr->if_source && !attr->procedure) || attr->contained) { conf (external, subroutine); conf (external, function); @@ -545,6 +545,22 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) goto conflict; } + conf (procedure, allocatable) + conf (procedure, dimension) + conf (procedure, intrinsic) + conf (procedure, protected) + conf (procedure, target) + conf (procedure, value) + conf (procedure, volatile_) + conf (procedure, entry) + /* TODO: Implement procedure pointers. */ + if (attr->procedure && attr->pointer) + { + gfc_error ("Fortran 2003: Procedure pointers at %L are " + "not yet implemented in gfortran", where); + return FAILURE; + } + a1 = gfc_code2string (flavors, attr->flavor); if (attr->in_namelist @@ -1212,6 +1228,29 @@ gfc_add_generic (symbol_attribute *attr, const char *name, locus *where) } +try +gfc_add_proc (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, NULL, where)) + return FAILURE; + + if (attr->flavor != FL_PROCEDURE + && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE) + return FAILURE; + + if (attr->procedure) + { + duplicate_attr ("PROCEDURE", where); + return FAILURE; + } + + attr->procedure = 1; + + return check_conflict (attr, NULL, where); +} + + /* Flavors are special because some flavors are not what Fortran considers attributes and can be reaffirmed multiple times. */ @@ -3532,6 +3571,61 @@ add_proc_interface (gfc_symbol *sym, ifsrc source, 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 -- cgit v1.1