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/decl.c | 242 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 242 insertions(+) (limited to 'gcc/fortran/decl.c') 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 -- cgit v1.1