From 30b608eb7c0432299ade3b19200315bf5e147d31 Mon Sep 17 00:00:00 2001 From: Daniel Kraft Date: Sun, 24 Aug 2008 18:15:27 +0200 Subject: [PATCH] gfortran.h (gfc_typebound_proc): New struct. 2008-08-24 Daniel Kraft * gfortran.h (gfc_typebound_proc): New struct. (gfc_symtree): New member typebound. (gfc_find_typebound_proc): Prototype for new method. (gfc_get_derived_super_type): Prototype for new method. * parse.h (gfc_compile_state): New state COMP_DERIVED_CONTAINS. * decl.c (gfc_match_procedure): Handle PROCEDURE inside derived-type CONTAINS section. (gfc_match_end): Handle new context COMP_DERIVED_CONTAINS. (gfc_match_private): Ditto. (match_binding_attributes), (match_procedure_in_type): New methods. (gfc_match_final_decl): Rewrote to make use of new COMP_DERIVED_CONTAINS parser state. * parse.c (typebound_default_access): New global helper variable. (set_typebound_default_access): New callback method. (parse_derived_contains): New method. (parse_derived): Extracted handling of CONTAINS to new parser state and parse_derived_contains. * resolve.c (resolve_bindings_derived), (resolve_bindings_result): New. (check_typebound_override), (resolve_typebound_procedure): New methods. (resolve_typebound_procedures): New method. (resolve_fl_derived): Call new resolving method for typebound procs. * symbol.c (gfc_new_symtree): Initialize new member typebound to NULL. (gfc_find_typebound_proc): New method. (gfc_get_derived_super_type): New method. 2008-08-24 Daniel Kraft * gfortran.dg/finalize_5.f03: Adapted expected error message to changes to handling of CONTAINS in derived-type declarations. * gfortran.dg/typebound_proc_1.f08: New test. * gfortran.dg/typebound_proc_2.f90: New test. * gfortran.dg/typebound_proc_3.f03: New test. * gfortran.dg/typebound_proc_4.f03: New test. * gfortran.dg/typebound_proc_5.f03: New test. * gfortran.dg/typebound_proc_6.f03: New test. From-SVN: r139534 --- gcc/fortran/ChangeLog | 27 +++ gcc/fortran/decl.c | 305 +++++++++++++++++++++-- gcc/fortran/gfortran.h | 26 ++ gcc/fortran/parse.c | 192 +++++++++++---- gcc/fortran/parse.h | 4 +- gcc/fortran/resolve.c | 319 +++++++++++++++++++++++++ gcc/fortran/symbol.c | 45 ++++ gcc/testsuite/ChangeLog | 11 + gcc/testsuite/gfortran.dg/finalize_5.f03 | 2 +- gcc/testsuite/gfortran.dg/typebound_proc_1.f08 | 69 ++++++ gcc/testsuite/gfortran.dg/typebound_proc_2.f90 | 35 +++ gcc/testsuite/gfortran.dg/typebound_proc_3.f03 | 17 ++ gcc/testsuite/gfortran.dg/typebound_proc_4.f03 | 43 ++++ gcc/testsuite/gfortran.dg/typebound_proc_5.f03 | 121 ++++++++++ gcc/testsuite/gfortran.dg/typebound_proc_6.f03 | 182 ++++++++++++++ 15 files changed, 1331 insertions(+), 67 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/typebound_proc_1.f08 create mode 100644 gcc/testsuite/gfortran.dg/typebound_proc_2.f90 create mode 100644 gcc/testsuite/gfortran.dg/typebound_proc_3.f03 create mode 100644 gcc/testsuite/gfortran.dg/typebound_proc_4.f03 create mode 100644 gcc/testsuite/gfortran.dg/typebound_proc_5.f03 create mode 100644 gcc/testsuite/gfortran.dg/typebound_proc_6.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index e939f96..0916029 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,30 @@ +2008-08-24 Daniel Kraft + + * gfortran.h (gfc_typebound_proc): New struct. + (gfc_symtree): New member typebound. + (gfc_find_typebound_proc): Prototype for new method. + (gfc_get_derived_super_type): Prototype for new method. + * parse.h (gfc_compile_state): New state COMP_DERIVED_CONTAINS. + * decl.c (gfc_match_procedure): Handle PROCEDURE inside derived-type + CONTAINS section. + (gfc_match_end): Handle new context COMP_DERIVED_CONTAINS. + (gfc_match_private): Ditto. + (match_binding_attributes), (match_procedure_in_type): New methods. + (gfc_match_final_decl): Rewrote to make use of new + COMP_DERIVED_CONTAINS parser state. + * parse.c (typebound_default_access): New global helper variable. + (set_typebound_default_access): New callback method. + (parse_derived_contains): New method. + (parse_derived): Extracted handling of CONTAINS to new parser state + and parse_derived_contains. + * resolve.c (resolve_bindings_derived), (resolve_bindings_result): New. + (check_typebound_override), (resolve_typebound_procedure): New methods. + (resolve_typebound_procedures): New method. + (resolve_fl_derived): Call new resolving method for typebound procs. + * symbol.c (gfc_new_symtree): Initialize new member typebound to NULL. + (gfc_find_typebound_proc): New method. + (gfc_get_derived_super_type): New method. + 2008-08-23 Janus Weil * gfortran.h (gfc_component): Add field "symbol_attribute attr", remove diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index ab4a64f..7ccee8b 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -4320,6 +4320,8 @@ syntax: /* General matcher for PROCEDURE declarations. */ +static match match_procedure_in_type (void); + match gfc_match_procedure (void) { @@ -4338,9 +4340,12 @@ gfc_match_procedure (void) m = match_procedure_in_interface (); break; case COMP_DERIVED: - gfc_error ("Fortran 2003: Procedure components at %C are " - "not yet implemented in gfortran"); + gfc_error ("Fortran 2003: Procedure components at %C are not yet" + " implemented in gfortran"); return MATCH_ERROR; + case COMP_DERIVED_CONTAINS: + m = match_procedure_in_type (); + break; default: return MATCH_NO; } @@ -5099,7 +5104,7 @@ gfc_match_end (gfc_statement *st) block_name = gfc_current_block () == NULL ? NULL : gfc_current_block ()->name; - if (state == COMP_CONTAINS) + if (state == COMP_CONTAINS || state == COMP_DERIVED_CONTAINS) { state = gfc_state_stack->previous->state; block_name = gfc_state_stack->previous->sym == NULL @@ -5146,6 +5151,7 @@ gfc_match_end (gfc_statement *st) break; case COMP_DERIVED: + case COMP_DERIVED_CONTAINS: *st = ST_END_TYPE; target = " type"; eos_ok = 0; @@ -5823,9 +5829,12 @@ gfc_match_private (gfc_statement *st) return MATCH_NO; if (gfc_current_state () != COMP_MODULE - && (gfc_current_state () != COMP_DERIVED - || !gfc_state_stack->previous - || gfc_state_stack->previous->state != COMP_MODULE)) + && !(gfc_current_state () == COMP_DERIVED + && gfc_state_stack->previous + && gfc_state_stack->previous->state == COMP_MODULE) + && !(gfc_current_state () == COMP_DERIVED_CONTAINS + && gfc_state_stack->previous && gfc_state_stack->previous->previous + && gfc_state_stack->previous->previous->state == COMP_MODULE)) { gfc_error ("PRIVATE statement at %C is only allowed in the " "specification part of a module"); @@ -6704,6 +6713,270 @@ cleanup: } +/* Match binding attributes. */ + +static match +match_binding_attributes (gfc_typebound_proc* ba) +{ + bool found_passing = false; + match m; + + /* Intialize to defaults. Do so even before the MATCH_NO check so that in + this case the defaults are in there. */ + ba->access = ACCESS_UNKNOWN; + ba->pass_arg = NULL; + ba->pass_arg_num = 0; + ba->nopass = 0; + ba->non_overridable = 0; + + /* If we find a comma, we believe there are binding attributes. */ + if (gfc_match_char (',') == MATCH_NO) + return MATCH_NO; + + do + { + /* NOPASS flag. */ + m = gfc_match (" nopass"); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_YES) + { + if (found_passing) + { + gfc_error ("Binding attributes already specify passing, illegal" + " NOPASS at %C"); + goto error; + } + + found_passing = true; + ba->nopass = 1; + continue; + } + + /* NON_OVERRIDABLE flag. */ + m = gfc_match (" non_overridable"); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_YES) + { + if (ba->non_overridable) + { + gfc_error ("Duplicate NON_OVERRIDABLE at %C"); + goto error; + } + + ba->non_overridable = 1; + continue; + } + + /* DEFERRED flag. */ + /* TODO: Handle really once implemented. */ + m = gfc_match (" deferred"); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_YES) + { + gfc_error ("DEFERRED not yet implemented at %C"); + goto error; + } + + /* PASS possibly including argument. */ + m = gfc_match (" pass"); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_YES) + { + char arg[GFC_MAX_SYMBOL_LEN + 1]; + + if (found_passing) + { + gfc_error ("Binding attributes already specify passing, illegal" + " PASS at %C"); + goto error; + } + + m = gfc_match (" ( %n )", arg); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_YES) + ba->pass_arg = xstrdup (arg); + gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL)); + + found_passing = true; + ba->nopass = 0; + continue; + } + + /* Access specifier. */ + + m = gfc_match (" public"); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_YES) + { + if (ba->access != ACCESS_UNKNOWN) + { + gfc_error ("Duplicate access-specifier at %C"); + goto error; + } + + ba->access = ACCESS_PUBLIC; + continue; + } + + m = gfc_match (" private"); + if (m == MATCH_ERROR) + goto error; + if (m == MATCH_YES) + { + if (ba->access != ACCESS_UNKNOWN) + { + gfc_error ("Duplicate access-specifier at %C"); + goto error; + } + + ba->access = ACCESS_PRIVATE; + continue; + } + + /* Nothing matching found. */ + gfc_error ("Expected binding attribute at %C"); + goto error; + } + while (gfc_match_char (',') == MATCH_YES); + + return MATCH_YES; + +error: + gfc_free (ba->pass_arg); + return MATCH_ERROR; +} + + +/* Match a PROCEDURE specific binding inside a derived type. */ + +static match +match_procedure_in_type (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + char target_buf[GFC_MAX_SYMBOL_LEN + 1]; + char* target; + gfc_typebound_proc* tb; + bool seen_colons; + bool seen_attrs; + match m; + gfc_symtree* stree; + gfc_namespace* ns; + gfc_symbol* block; + + /* Check current state. */ + gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS); + block = gfc_state_stack->previous->sym; + gcc_assert (block); + + /* TODO: Really implement PROCEDURE(interface). */ + if (gfc_match (" (") == MATCH_YES) + { + gfc_error ("Procedure with interface only allowed in abstract types at" + " %C"); + return MATCH_ERROR; + } + + /* Construct the data structure. */ + tb = XCNEW (gfc_typebound_proc); + tb->where = gfc_current_locus; + + /* Match binding attributes. */ + m = match_binding_attributes (tb); + if (m == MATCH_ERROR) + return m; + seen_attrs = (m == MATCH_YES); + + /* Match the colons. */ + m = gfc_match (" ::"); + if (m == MATCH_ERROR) + return m; + seen_colons = (m == MATCH_YES); + if (seen_attrs && !seen_colons) + { + gfc_error ("Expected '::' after binding-attributes at %C"); + return MATCH_ERROR; + } + + /* Match the binding name. */ + m = gfc_match_name (name); + if (m == MATCH_ERROR) + return m; + if (m == MATCH_NO) + { + gfc_error ("Expected binding name at %C"); + return MATCH_ERROR; + } + + /* Try to match the '=> target', if it's there. */ + target = NULL; + m = gfc_match (" =>"); + if (m == MATCH_ERROR) + return m; + if (m == MATCH_YES) + { + if (!seen_colons) + { + gfc_error ("'::' needed in PROCEDURE binding with explicit target" + " at %C"); + return MATCH_ERROR; + } + + m = gfc_match_name (target_buf); + if (m == MATCH_ERROR) + return m; + if (m == MATCH_NO) + { + gfc_error ("Expected binding target after '=>' at %C"); + return MATCH_ERROR; + } + target = target_buf; + } + + /* Now we should have the end. */ + m = gfc_match_eos (); + if (m == MATCH_ERROR) + return m; + if (m == MATCH_NO) + { + gfc_error ("Junk after PROCEDURE declaration at %C"); + return MATCH_ERROR; + } + + /* If no target was found, it has the same name as the binding. */ + if (!target) + target = name; + + /* Get the namespace to insert the symbols into. */ + ns = block->f2k_derived; + gcc_assert (ns); + + /* See if we already have a binding with this name in the symtree which would + be an error. */ + stree = gfc_find_symtree (ns->sym_root, name); + if (stree) + { + gfc_error ("There's already a procedure with binding name '%s' for the" + " derived type '%s' at %C", name, block->name); + return MATCH_ERROR; + } + + /* Insert it and set attributes. */ + if (gfc_get_sym_tree (name, ns, &stree)) + return MATCH_ERROR; + if (gfc_get_sym_tree (target, gfc_current_ns, &tb->target)) + return MATCH_ERROR; + stree->typebound = tb; + + return MATCH_YES; +} + + /* Match a FINAL declaration inside a derived type. */ match @@ -6714,18 +6987,20 @@ gfc_match_final_decl (void) match m; gfc_namespace* module_ns; bool first, last; + gfc_symbol* block; - if (gfc_state_stack->state != COMP_DERIVED) + if (gfc_state_stack->state != COMP_DERIVED_CONTAINS) { gfc_error ("FINAL declaration at %C must be inside a derived type " - "definition!"); + "CONTAINS section"); return MATCH_ERROR; } - gcc_assert (gfc_current_block ()); + block = gfc_state_stack->previous->sym; + gcc_assert (block); - if (!gfc_state_stack->previous - || gfc_state_stack->previous->state != COMP_MODULE) + if (!gfc_state_stack->previous || !gfc_state_stack->previous->previous + || gfc_state_stack->previous->previous->state != COMP_MODULE) { gfc_error ("Derived type declaration with FINAL at %C must be in the" " specification part of a MODULE"); @@ -6783,7 +7058,7 @@ gfc_match_final_decl (void) return MATCH_ERROR; /* Check if we already have this symbol in the list, this is an error. */ - for (f = gfc_current_block ()->f2k_derived->finalizers; f; f = f->next) + for (f = block->f2k_derived->finalizers; f; f = f->next) if (f->proc_sym == sym) { gfc_error ("'%s' at %C is already defined as FINAL procedure!", @@ -6792,14 +7067,14 @@ gfc_match_final_decl (void) } /* Add this symbol to the list of finalizers. */ - gcc_assert (gfc_current_block ()->f2k_derived); + gcc_assert (block->f2k_derived); ++sym->refs; f = XCNEW (gfc_finalizer); f->proc_sym = sym; f->proc_tree = NULL; f->where = gfc_current_locus; - f->next = gfc_current_block ()->f2k_derived->finalizers; - gfc_current_block ()->f2k_derived->finalizers = f; + f->next = block->f2k_derived->finalizers; + block->f2k_derived->finalizers = f; first = false; } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 7ab1b49..322b4a5 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -991,6 +991,27 @@ typedef struct } gfc_user_op; + +/* Data needed for type-bound procedures. */ +typedef struct +{ + struct gfc_symtree* target; + locus where; /* Where the PROCEDURE definition was. */ + + gfc_access access; + char* pass_arg; /* Argument-name for PASS. NULL if not specified. */ + + /* Once resolved, we use the position of pass_arg in the formal arglist of + the binding-target procedure to identify it. The first argument has + number 0 here, the second 1, and so on. */ + unsigned pass_arg_num; + + unsigned nopass:1; /* Whether we have NOPASS (PASS otherwise). */ + unsigned non_overridable:1; +} +gfc_typebound_proc; + + /* Symbol nodes. These are important things. They are what the standard refers to as "entities". The possibly multiple names that refer to the same entity are accomplished by a binary tree of @@ -1127,6 +1148,8 @@ typedef struct gfc_symtree } n; + /* Data for type-bound procedures; NULL if no type-bound procedure. */ + gfc_typebound_proc* typebound; } gfc_symtree; @@ -2237,6 +2260,9 @@ void gfc_symbol_state (void); gfc_gsymbol *gfc_get_gsymbol (const char *); gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *); +gfc_symbol* gfc_get_derived_super_type (gfc_symbol*); +gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, const char*); + void copy_formal_args (gfc_symbol *dest, gfc_symbol *src); void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too */ diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index f9c3705..4bf1b81 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -1691,13 +1691,143 @@ unexpected_eof (void) } +/* Set the default access attribute for a typebound procedure; this is used + as callback for gfc_traverse_symtree. */ + +static gfc_access typebound_default_access; + +static void +set_typebound_default_access (gfc_symtree* stree) +{ + if (stree->typebound && stree->typebound->access == ACCESS_UNKNOWN) + stree->typebound->access = typebound_default_access; +} + + +/* Parse the CONTAINS section of a derived type definition. */ + +static bool +parse_derived_contains (void) +{ + gfc_state_data s; + bool seen_private = false; + bool seen_comps = false; + bool error_flag = false; + bool to_finish; + + accept_statement (ST_CONTAINS); + gcc_assert (gfc_current_state () == COMP_DERIVED); + push_state (&s, COMP_DERIVED_CONTAINS, NULL); + + to_finish = false; + while (!to_finish) + { + gfc_statement st; + st = next_statement (); + switch (st) + { + case ST_NONE: + unexpected_eof (); + break; + + case ST_DATA_DECL: + gfc_error ("Components in TYPE at %C must precede CONTAINS"); + error_flag = true; + break; + + case ST_PROCEDURE: + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Type-bound" + " procedure at %C") == FAILURE) + error_flag = true; + + accept_statement (ST_PROCEDURE); + seen_comps = true; + break; + + case ST_FINAL: + if (gfc_notify_std (GFC_STD_F2003, + "Fortran 2003: FINAL procedure declaration" + " at %C") == FAILURE) + error_flag = true; + + accept_statement (ST_FINAL); + seen_comps = true; + break; + + case ST_END_TYPE: + to_finish = true; + + if (!seen_comps + && (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Derived type " + "definition at %C with empty CONTAINS " + "section") == FAILURE)) + error_flag = true; + + /* ST_END_TYPE is accepted by parse_derived after return. */ + break; + + case ST_PRIVATE: + if (gfc_find_state (COMP_MODULE) == FAILURE) + { + gfc_error ("PRIVATE statement in TYPE at %C must be inside " + "a MODULE"); + error_flag = true; + break; + } + + if (seen_comps) + { + gfc_error ("PRIVATE statement at %C must precede procedure" + " bindings"); + error_flag = true; + break; + } + + if (seen_private) + { + gfc_error ("Duplicate PRIVATE statement at %C"); + error_flag = true; + } + + accept_statement (ST_PRIVATE); + seen_private = true; + break; + + case ST_SEQUENCE: + gfc_error ("SEQUENCE statement at %C must precede CONTAINS"); + error_flag = true; + break; + + case ST_CONTAINS: + gfc_error ("Already inside a CONTAINS block at %C"); + error_flag = true; + break; + + default: + unexpected_statement (st); + break; + } + } + + pop_state (); + gcc_assert (gfc_current_state () == COMP_DERIVED); + + /* Walk the parsed type-bound procedures and set ACCESS_UNKNOWN attributes + to PUBLIC or PRIVATE depending on seen_private. */ + typebound_default_access = (seen_private ? ACCESS_PRIVATE : ACCESS_PUBLIC); + gfc_traverse_symtree (gfc_current_block ()->f2k_derived->sym_root, + &set_typebound_default_access); + + return error_flag; +} + + /* Parse a derived type. */ static void parse_derived (void) { int compiling_type, seen_private, seen_sequence, seen_component, error_flag; - int seen_contains, seen_contains_comp; gfc_statement st; gfc_state_data s; gfc_symbol *derived_sym = NULL; @@ -1713,8 +1843,6 @@ parse_derived (void) seen_private = 0; seen_sequence = 0; seen_component = 0; - seen_contains = 0; - seen_contains_comp = 0; compiling_type = 1; @@ -1727,34 +1855,22 @@ parse_derived (void) unexpected_eof (); case ST_DATA_DECL: - case ST_PROCEDURE: - if (seen_contains) - { - gfc_error ("Components in TYPE at %C must precede CONTAINS"); - error_flag = 1; - } - accept_statement (st); seen_component = 1; break; - case ST_FINAL: - if (!seen_contains) - { - gfc_error ("FINAL declaration at %C must be inside CONTAINS"); - error_flag = 1; - } - - if (gfc_notify_std (GFC_STD_F2003, - "Fortran 2003: FINAL procedure declaration" - " at %C") == FAILURE) - error_flag = 1; + case ST_PROCEDURE: + gfc_error ("PROCEDURE binding at %C must be inside CONTAINS"); + error_flag = 1; + break; - accept_statement (ST_FINAL); - seen_contains_comp = 1; + case ST_FINAL: + gfc_error ("FINAL declaration at %C must be inside CONTAINS"); + error_flag = 1; break; case ST_END_TYPE: +endType: compiling_type = 0; if (!seen_component @@ -1763,22 +1879,10 @@ parse_derived (void) == FAILURE)) error_flag = 1; - if (seen_contains && !seen_contains_comp - && (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Derived type " - "definition at %C with empty CONTAINS " - "section") == FAILURE)) - error_flag = 1; - accept_statement (ST_END_TYPE); break; case ST_PRIVATE: - if (seen_contains) - { - gfc_error ("PRIVATE statement at %C must precede CONTAINS"); - error_flag = 1; - } - if (gfc_find_state (COMP_MODULE) == FAILURE) { gfc_error ("PRIVATE statement in TYPE at %C must be inside " @@ -1802,17 +1906,12 @@ parse_derived (void) } s.sym->component_access = ACCESS_PRIVATE; + accept_statement (ST_PRIVATE); seen_private = 1; break; case ST_SEQUENCE: - if (seen_contains) - { - gfc_error ("SEQUENCE statement at %C must precede CONTAINS"); - error_flag = 1; - } - if (seen_component) { gfc_error ("SEQUENCE statement at %C must precede " @@ -1842,15 +1941,10 @@ parse_derived (void) " definition at %C") == FAILURE) error_flag = 1; - if (seen_contains) - { - gfc_error ("Already inside a CONTAINS block at %C"); - error_flag = 1; - } - - seen_contains = 1; accept_statement (ST_CONTAINS); - break; + if (parse_derived_contains ()) + error_flag = 1; + goto endType; default: unexpected_statement (st); diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index 1ac3e94..7fe2330 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -29,8 +29,8 @@ along with GCC; see the file COPYING3. If not see typedef enum { COMP_NONE, COMP_PROGRAM, COMP_MODULE, COMP_SUBROUTINE, COMP_FUNCTION, - COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_IF, COMP_DO, - COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM, + COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_DERIVED_CONTAINS, COMP_IF, + COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM, COMP_OMP_STRUCTURED_BLOCK } gfc_compile_state; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 51d0654..9cde435 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -7613,6 +7613,321 @@ error: } +/* Check that it is ok for the typebound procedure proc to override the + procedure old. */ + +static gfc_try +check_typebound_override (gfc_symtree* proc, gfc_symtree* old) +{ + locus where; + const gfc_symbol* proc_target; + const gfc_symbol* old_target; + unsigned proc_pass_arg, old_pass_arg, argpos; + gfc_formal_arglist* proc_formal; + gfc_formal_arglist* old_formal; + + where = proc->typebound->where; + proc_target = proc->typebound->target->n.sym; + old_target = old->typebound->target->n.sym; + + /* Check that overridden binding is not NON_OVERRIDABLE. */ + if (old->typebound->non_overridable) + { + gfc_error ("'%s' at %L overrides a procedure binding declared" + " NON_OVERRIDABLE", proc->name, &where); + return FAILURE; + } + + /* If the overridden binding is PURE, the overriding must be, too. */ + if (old_target->attr.pure && !proc_target->attr.pure) + { + gfc_error ("'%s' at %L overrides a PURE procedure and must also be PURE", + proc->name, &where); + return FAILURE; + } + + /* If the overridden binding is ELEMENTAL, the overriding must be, too. If it + is not, the overriding must not be either. */ + if (old_target->attr.elemental && !proc_target->attr.elemental) + { + gfc_error ("'%s' at %L overrides an ELEMENTAL procedure and must also be" + " ELEMENTAL", proc->name, &where); + return FAILURE; + } + if (!old_target->attr.elemental && proc_target->attr.elemental) + { + gfc_error ("'%s' at %L overrides a non-ELEMENTAL procedure and must not" + " be ELEMENTAL, either", proc->name, &where); + return FAILURE; + } + + /* If the overridden binding is a SUBROUTINE, the overriding must also be a + SUBROUTINE. */ + if (old_target->attr.subroutine && !proc_target->attr.subroutine) + { + gfc_error ("'%s' at %L overrides a SUBROUTINE and must also be a" + " SUBROUTINE", proc->name, &where); + return FAILURE; + } + + /* If the overridden binding is a FUNCTION, the overriding must also be a + FUNCTION and have the same characteristics. */ + if (old_target->attr.function) + { + if (!proc_target->attr.function) + { + gfc_error ("'%s' at %L overrides a FUNCTION and must also be a" + " FUNCTION", proc->name, &where); + return FAILURE; + } + + /* FIXME: Do more comprehensive checking (including, for instance, the + rank and array-shape). */ + gcc_assert (proc_target->result && old_target->result); + if (!gfc_compare_types (&proc_target->result->ts, + &old_target->result->ts)) + { + gfc_error ("'%s' at %L and the overridden FUNCTION should have" + " matching result types", proc->name, &where); + return FAILURE; + } + } + + /* If the overridden binding is PUBLIC, the overriding one must not be + PRIVATE. */ + if (old->typebound->access == ACCESS_PUBLIC + && proc->typebound->access == ACCESS_PRIVATE) + { + gfc_error ("'%s' at %L overrides a PUBLIC procedure and must not be" + " PRIVATE", proc->name, &where); + return FAILURE; + } + + /* Compare the formal argument lists of both procedures. This is also abused + to find the position of the passed-object dummy arguments of both + bindings as at least the overridden one might not yet be resolved and we + need those positions in the check below. */ + proc_pass_arg = old_pass_arg = 0; + if (!proc->typebound->nopass && !proc->typebound->pass_arg) + proc_pass_arg = 1; + if (!old->typebound->nopass && !old->typebound->pass_arg) + old_pass_arg = 1; + argpos = 1; + for (proc_formal = proc_target->formal, old_formal = old_target->formal; + proc_formal && old_formal; + proc_formal = proc_formal->next, old_formal = old_formal->next) + { + if (proc->typebound->pass_arg + && !strcmp (proc->typebound->pass_arg, proc_formal->sym->name)) + proc_pass_arg = argpos; + if (old->typebound->pass_arg + && !strcmp (old->typebound->pass_arg, old_formal->sym->name)) + old_pass_arg = argpos; + + /* Check that the names correspond. */ + if (strcmp (proc_formal->sym->name, old_formal->sym->name)) + { + gfc_error ("Dummy argument '%s' of '%s' at %L should be named '%s' as" + " to match the corresponding argument of the overridden" + " procedure", proc_formal->sym->name, proc->name, &where, + old_formal->sym->name); + return FAILURE; + } + + /* Check that the types correspond if neither is the passed-object + argument. */ + /* FIXME: Do more comprehensive testing here. */ + if (proc_pass_arg != argpos && old_pass_arg != argpos + && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts)) + { + gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L in" + " in respect to the overridden procedure", + proc_formal->sym->name, proc->name, &where); + return FAILURE; + } + + ++argpos; + } + if (proc_formal || old_formal) + { + gfc_error ("'%s' at %L must have the same number of formal arguments as" + " the overridden procedure", proc->name, &where); + return FAILURE; + } + + /* If the overridden binding is NOPASS, the overriding one must also be + NOPASS. */ + if (old->typebound->nopass && !proc->typebound->nopass) + { + gfc_error ("'%s' at %L overrides a NOPASS binding and must also be" + " NOPASS", proc->name, &where); + return FAILURE; + } + + /* If the overridden binding is PASS(x), the overriding one must also be + PASS and the passed-object dummy arguments must correspond. */ + if (!old->typebound->nopass) + { + if (proc->typebound->nopass) + { + gfc_error ("'%s' at %L overrides a binding with PASS and must also be" + " PASS", proc->name, &where); + return FAILURE; + } + + if (proc_pass_arg != old_pass_arg) + { + gfc_error ("Passed-object dummy argument of '%s' at %L must be at" + " the same position as the passed-object dummy argument of" + " the overridden procedure", proc->name, &where); + return FAILURE; + } + } + + return SUCCESS; +} + + +/* Resolve the type-bound procedures for a derived type. */ + +static gfc_symbol* resolve_bindings_derived; +static gfc_try resolve_bindings_result; + +static void +resolve_typebound_procedure (gfc_symtree* stree) +{ + gfc_symbol* proc; + locus where; + gfc_symbol* me_arg; + gfc_symbol* super_type; + + /* If this is no type-bound procedure, just return. */ + if (!stree->typebound) + return; + + /* Get the target-procedure to check it. */ + gcc_assert (stree->typebound->target); + proc = stree->typebound->target->n.sym; + where = stree->typebound->where; + + /* Default access should already be resolved from the parser. */ + gcc_assert (stree->typebound->access != ACCESS_UNKNOWN); + + /* It should be a module procedure or an external procedure with explicit + interface. */ + if ((!proc->attr.subroutine && !proc->attr.function) + || (proc->attr.proc != PROC_MODULE + && proc->attr.if_source != IFSRC_IFBODY) + || proc->attr.abstract) + { + gfc_error ("'%s' must be a module procedure or an external procedure with" + " an explicit interface at %L", proc->name, &where); + goto error; + } + + /* Find the super-type of the current derived type. We could do this once and + store in a global if speed is needed, but as long as not I believe this is + more readable and clearer. */ + super_type = gfc_get_derived_super_type (resolve_bindings_derived); + + /* If PASS, resolve and check arguments. */ + if (!stree->typebound->nopass) + { + if (stree->typebound->pass_arg) + { + gfc_formal_arglist* i; + + /* If an explicit passing argument name is given, walk the arg-list + and look for it. */ + + me_arg = NULL; + stree->typebound->pass_arg_num = 0; + for (i = proc->formal; i; i = i->next) + { + if (!strcmp (i->sym->name, stree->typebound->pass_arg)) + { + me_arg = i->sym; + break; + } + ++stree->typebound->pass_arg_num; + } + + if (!me_arg) + { + gfc_error ("Procedure '%s' with PASS(%s) at %L has no" + " argument '%s'", + proc->name, stree->typebound->pass_arg, &where, + stree->typebound->pass_arg); + goto error; + } + } + else + { + /* Otherwise, take the first one; there should in fact be at least + one. */ + stree->typebound->pass_arg_num = 0; + if (!proc->formal) + { + gfc_error ("Procedure '%s' with PASS at %L must have at" + " least one argument", proc->name, &where); + goto error; + } + me_arg = proc->formal->sym; + } + + /* Now check that the argument-type matches. */ + gcc_assert (me_arg); + if (me_arg->ts.type != BT_DERIVED + || me_arg->ts.derived != resolve_bindings_derived) + { + gfc_error ("Argument '%s' of '%s' with PASS(%s) at %L must be of" + " the derived-type '%s'", me_arg->name, proc->name, + me_arg->name, &where, resolve_bindings_derived->name); + goto error; + } + } + + /* If we are extending some type, check that we don't override a procedure + flagged NON_OVERRIDABLE. */ + if (super_type) + { + gfc_symtree* overridden; + overridden = gfc_find_typebound_proc (super_type, stree->name); + + if (overridden && check_typebound_override (stree, overridden) == FAILURE) + goto error; + } + + /* FIXME: Remove once typebound-procedures are fully implemented. */ + { + /* Output the error only once so we can do reasonable testing. */ + static bool tbp_error = false; + if (!tbp_error) + gfc_error ("Type-bound procedures are not yet implemented at %L", &where); + tbp_error = true; + } + + return; + +error: + resolve_bindings_result = FAILURE; +} + +static gfc_try +resolve_typebound_procedures (gfc_symbol* derived) +{ + if (!derived->f2k_derived || !derived->f2k_derived->sym_root) + return SUCCESS; + + resolve_bindings_derived = derived; + resolve_bindings_result = SUCCESS; + gfc_traverse_symtree (derived->f2k_derived->sym_root, + &resolve_typebound_procedure); + + return resolve_bindings_result; +} + + /* Add a derived type to the dt_list. The dt_list is used in trans-types.c to give all identical derived types the same backend_decl. */ static void @@ -7722,6 +8037,10 @@ resolve_fl_derived (gfc_symbol *sym) } } + /* Resolve the type-bound procedures. */ + if (resolve_typebound_procedures (sym) == FAILURE) + return FAILURE; + /* Resolve the finalizer procedures. */ if (gfc_resolve_finalizers (sym) == FAILURE) return FAILURE; diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 6244eed..005086d 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -2225,6 +2225,7 @@ gfc_new_symtree (gfc_symtree **root, const char *name) st = XCNEW (gfc_symtree); st->name = gfc_get_string (name); + st->typebound = NULL; gfc_insert_bbt (root, st, compare_symtree); return st; @@ -4238,3 +4239,47 @@ gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns, /* Everything is ok. */ return SUCCESS; } + + +/* Get the super-type of a given derived type. */ + +gfc_symbol* +gfc_get_derived_super_type (gfc_symbol* derived) +{ + if (!derived->attr.extension) + return NULL; + + gcc_assert (derived->components); + gcc_assert (derived->components->ts.type == BT_DERIVED); + gcc_assert (derived->components->ts.derived); + + return derived->components->ts.derived; +} + + +/* Find a type-bound procedure by name for a derived-type (looking recursively + through the super-types). */ + +gfc_symtree* +gfc_find_typebound_proc (gfc_symbol* derived, const char* name) +{ + gfc_symtree* res; + + /* Try to find it in the current type's namespace. */ + gcc_assert (derived->f2k_derived); + res = gfc_find_symtree (derived->f2k_derived->sym_root, name); + if (res) + return res->typebound ? res : NULL; + + /* Otherwise, recurse on parent type if derived is an extension. */ + if (derived->attr.extension) + { + gfc_symbol* super_type; + super_type = gfc_get_derived_super_type (derived); + gcc_assert (super_type); + return gfc_find_typebound_proc (super_type, name); + } + + /* Nothing found. */ + return NULL; +} diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index a85f6b4..29593bc 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,14 @@ +2008-08-24 Daniel Kraft + + * gfortran.dg/finalize_5.f03: Adapted expected error message to changes + to handling of CONTAINS in derived-type declarations. + * gfortran.dg/typebound_proc_1.f08: New test. + * gfortran.dg/typebound_proc_2.f90: New test. + * gfortran.dg/typebound_proc_3.f03: New test. + * gfortran.dg/typebound_proc_4.f03: New test. + * gfortran.dg/typebound_proc_5.f03: New test. + * gfortran.dg/typebound_proc_6.f03: New test. + 2008-08-23 Tobias Burnus PR fortran/37076 diff --git a/gcc/testsuite/gfortran.dg/finalize_5.f03 b/gcc/testsuite/gfortran.dg/finalize_5.f03 index 9f5dc17..1df2d8c 100644 --- a/gcc/testsuite/gfortran.dg/finalize_5.f03 +++ b/gcc/testsuite/gfortran.dg/finalize_5.f03 @@ -9,7 +9,7 @@ MODULE final_type TYPE :: mytype INTEGER, ALLOCATABLE :: fooarr(:) REAL :: foobar - FINAL :: finalize_matrix ! { dg-error "must be inside CONTAINS" } + FINAL :: finalize_matrix ! { dg-error "must be inside a derived type" } CONTAINS FINAL :: ! { dg-error "Empty FINAL" } FINAL ! { dg-error "Empty FINAL" } diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_1.f08 b/gcc/testsuite/gfortran.dg/typebound_proc_1.f08 new file mode 100644 index 0000000..a10b928 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_proc_1.f08 @@ -0,0 +1,69 @@ +! { dg-do compile } + +! Type-bound procedures +! Test that the basic syntax for specific bindings is parsed and resolved. + +MODULE othermod + IMPLICIT NONE + +CONTAINS + + SUBROUTINE othersub () + IMPLICIT NONE + END SUBROUTINE othersub + +END MODULE othermod + +MODULE testmod + USE othermod + IMPLICIT NONE + + TYPE t1 + ! Might be empty + CONTAINS + PROCEDURE proc1 + PROCEDURE, PASS(me) :: p2 => proc2 ! { dg-error "not yet implemented" } + END TYPE t1 + + TYPE t2 + INTEGER :: x + CONTAINS + PRIVATE + PROCEDURE, NOPASS, PRIVATE :: othersub + PROCEDURE,NON_OVERRIDABLE,PUBLIC,PASS :: proc3 + END TYPE t2 + + TYPE t3 + CONTAINS + ! This might be empty for Fortran 2008 + END TYPE t3 + + TYPE t4 + CONTAINS + PRIVATE + ! Empty, too + END TYPE t4 + +CONTAINS + + SUBROUTINE proc1 (me) + IMPLICIT NONE + TYPE(t1) :: me + END SUBROUTINE proc1 + + REAL FUNCTION proc2 (x, me) + IMPLICIT NONE + REAL :: x + TYPE(t1) :: me + proc2 = x / 2 + END FUNCTION proc2 + + INTEGER FUNCTION proc3 (me) + IMPLICIT NONE + TYPE(t2) :: me + proc3 = 42 + END FUNCTION proc3 + +END MODULE testmod + +! { dg-final { cleanup-modules "testmod" } } diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_2.f90 b/gcc/testsuite/gfortran.dg/typebound_proc_2.f90 new file mode 100644 index 0000000..8654eee --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_proc_2.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! { dg-options "-std=f95" } + +! Type-bound procedures +! Test that F95 does not allow type-bound procedures + +MODULE testmod + IMPLICIT NONE + + TYPE t + INTEGER :: x + CONTAINS ! { dg-error "Fortran 2003" } + PROCEDURE proc1 ! { dg-error "Fortran 2003" } + PROCEDURE :: proc2 => p2 ! { dg-error "Fortran 2003" } + END TYPE t + +CONTAINS + + SUBROUTINE proc1 (me) + IMPLICIT NONE + TYPE(t1) :: me + END SUBROUTINE proc1 + + REAL FUNCTION proc2 (me, x) + IMPLICIT NONE + TYPE(t1) :: me + REAL :: x + proc2 = x / 2 + END FUNCTION proc2 + +END MODULE testmod + +! { dg-final { cleanup-modules "testmod" } } +! FIXME: Remove not-yet-implemented error when implemented. +! { dg-excess-errors "no IMPLICIT type|not yet implemented" } diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_3.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_3.f03 new file mode 100644 index 0000000..13b90c1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_proc_3.f03 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } + +! Type-bound procedures +! Test that F2003 does not allow empty CONTAINS sections. + +MODULE testmod + IMPLICIT NONE + + TYPE t + INTEGER :: x + CONTAINS + END TYPE t ! { dg-error "Fortran 2008" } + +END MODULE testmod + +! { dg-final { cleanup-modules "testmod" } } diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_4.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_4.f03 new file mode 100644 index 0000000..bf5be56 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_proc_4.f03 @@ -0,0 +1,43 @@ +! { dg-do compile } + +! Type-bound procedures +! Test for errors in specific bindings, during parsing (not resolution). + +MODULE testmod + IMPLICIT NONE + + TYPE t + REAL :: a + CONTAINS + PROCEDURE p0 ! { dg-error "no IMPLICIT|module procedure" } + PRIVATE ! { dg-error "must precede" } + PROCEDURE p1 => proc1 ! { dg-error "::" } + PROCEDURE :: ! { dg-error "Expected binding name" } + PROCEDURE ! { dg-error "Expected binding name" } + PROCEDURE ? ! { dg-error "Expected binding name" } + PROCEDURE :: p2 => ! { dg-error "Expected binding target" } + PROCEDURE :: p3 =>, ! { dg-error "Expected binding target" } + PROCEDURE p4, ! { dg-error "Junk after" } + PROCEDURE :: p5 => proc2, ! { dg-error "Junk after" } + PROCEDURE :: p0 => proc3 ! { dg-error "already a procedure" } + PROCEDURE, PASS p6 ! { dg-error "::" } + PROCEDURE, PASS NON_OVERRIDABLE ! { dg-error "Expected" } + PROCEDURE PASS :: ! { dg-error "Junk after" } + PROCEDURE, PASS (x ! { dg-error "Expected" } + PROCEDURE, PASS () ! { dg-error "Expected" } + PROCEDURE, NOPASS, PASS ! { dg-error "illegal PASS" } + PROCEDURE, PASS, NON_OVERRIDABLE, PASS(x) ! { dg-error "illegal PASS" } + PROCEDURE, PUBLIC, PRIVATE ! { dg-error "Duplicate" } + PROCEDURE, NON_OVERRIDABLE, NON_OVERRIDABLE ! { dg-error "Duplicate" } + PROCEDURE, NOPASS, NOPASS ! { dg-error "illegal NOPASS" } + + ! TODO: Correct these when things get implemented. + PROCEDURE, DEFERRED :: x ! { dg-error "not yet implemented" } + PROCEDURE(abc) ! { dg-error "abstract type" } + END TYPE t + +CONTAINS + +END MODULE testmod + +! { dg-final { cleanup-modules "testmod" } } diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_5.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_5.f03 new file mode 100644 index 0000000..18f01f1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_proc_5.f03 @@ -0,0 +1,121 @@ +! { dg-do compile } + +! Type-bound procedures +! Test for errors in specific bindings, during resolution. + +MODULE othermod + IMPLICIT NONE +CONTAINS + + REAL FUNCTION proc_noarg () + IMPLICIT NONE + END FUNCTION proc_noarg + +END MODULE othermod + +MODULE testmod + USE othermod + IMPLICIT NONE + + INTEGER :: noproc + + PROCEDURE() :: proc_nointf + + INTERFACE + SUBROUTINE proc_intf () + END SUBROUTINE proc_intf + END INTERFACE + + ABSTRACT INTERFACE + SUBROUTINE proc_abstract_intf () + END SUBROUTINE proc_abstract_intf + END INTERFACE + + TYPE supert + CONTAINS + PROCEDURE, NOPASS :: super_overrid => proc_sub_noarg + PROCEDURE, NOPASS, NON_OVERRIDABLE :: super_nonoverrid => proc_sub_noarg + END TYPE supert + + TYPE, EXTENDS(supert) :: t + CONTAINS + + ! Bindings that should succeed + PROCEDURE, NOPASS :: p0 => proc_noarg + PROCEDURE, PASS :: p1 => proc_arg_first + PROCEDURE proc_arg_first + PROCEDURE, PASS(me) :: p2 => proc_arg_middle + PROCEDURE, PASS(me), NON_OVERRIDABLE :: p3 => proc_arg_last + PROCEDURE, NOPASS :: p4 => proc_nome + PROCEDURE, NOPASS :: p5 => proc_intf + PROCEDURE, NOPASS :: super_overrid => proc_sub_noarg + + ! Bindings that should not succeed + PROCEDURE :: e0 => undefined ! { dg-error "has no IMPLICIT|module procedure" } + PROCEDURE, PASS :: e1 => proc_noarg ! { dg-error "at least one argument" } + PROCEDURE :: e2 => proc_noarg ! { dg-error "at least one argument" } + PROCEDURE, PASS(me) :: e3 => proc_nome ! { dg-error "no argument 'me'" } + PROCEDURE, PASS(me) :: e4 => proc_mewrong ! { dg-error "of the derived" } + PROCEDURE, PASS :: e5 => proc_mewrong ! { dg-error "of the derived" } + PROCEDURE :: e6 => noproc ! { dg-error "module procedure" } + PROCEDURE :: e7 => proc_nointf ! { dg-error "explicit interface" } + PROCEDURE, NOPASS :: e8 => proc_abstract_intf ! { dg-error "explicit interface" } + PROCEDURE :: super_nonoverrid => proc_arg_first ! { dg-error "NON_OVERRIDABLE" } + + END TYPE t + +CONTAINS + + SUBROUTINE proc_arg_first (me, x) + IMPLICIT NONE + TYPE(t) :: me + REAL :: x + END SUBROUTINE proc_arg_first + + INTEGER FUNCTION proc_arg_middle (x, me, y) + IMPLICIT NONE + REAL :: x, y + TYPE(t) :: me + END FUNCTION proc_arg_middle + + SUBROUTINE proc_arg_last (x, me) + IMPLICIT NONE + TYPE(t) :: me + REAL :: x + END SUBROUTINE proc_arg_last + + SUBROUTINE proc_nome (arg, x, y) + IMPLICIT NONE + TYPE(t) :: arg + REAL :: x, y + END SUBROUTINE proc_nome + + SUBROUTINE proc_mewrong (me, x) + IMPLICIT NONE + REAL :: x + INTEGER :: me + END SUBROUTINE proc_mewrong + + SUBROUTINE proc_sub_noarg () + END SUBROUTINE proc_sub_noarg + +END MODULE testmod + +PROGRAM main + IMPLICIT NONE + + TYPE t + CONTAINS + PROCEDURE, NOPASS :: proc_no_module ! { dg-error "module procedure" } + END TYPE t + +CONTAINS + + SUBROUTINE proc_no_module () + END SUBROUTINE proc_no_module + +END PROGRAM main + +! { dg-final { cleanup-modules "othermod testmod" } } +! FIXME: Remove not-yet-implemented error when implemented. +! { dg-excess-errors "not yet implemented" } diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_6.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_6.f03 new file mode 100644 index 0000000..9cea9c5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/typebound_proc_6.f03 @@ -0,0 +1,182 @@ +! { dg-do compile } + +! Type-bound procedures +! Test for the check if overriding methods "match" the overridden ones by their +! characteristics. + +MODULE testmod + IMPLICIT NONE + + TYPE supert + CONTAINS + + ! For checking the PURE/ELEMENTAL matching. + PROCEDURE, NOPASS :: pure1 => proc_pure + PROCEDURE, NOPASS :: pure2 => proc_pure + PROCEDURE, NOPASS :: nonpure => proc_sub + PROCEDURE, NOPASS :: elemental1 => proc_elemental + PROCEDURE, NOPASS :: elemental2 => proc_elemental + PROCEDURE, NOPASS :: nonelem1 => proc_nonelem + PROCEDURE, NOPASS :: nonelem2 => proc_nonelem + + ! Same number of arguments! + PROCEDURE, NOPASS :: three_args_1 => proc_threearg + PROCEDURE, NOPASS :: three_args_2 => proc_threearg + + ! For SUBROUTINE/FUNCTION/result checking. + PROCEDURE, NOPASS :: subroutine1 => proc_sub + PROCEDURE, NOPASS :: subroutine2 => proc_sub + PROCEDURE, NOPASS :: intfunction1 => proc_intfunc + PROCEDURE, NOPASS :: intfunction2 => proc_intfunc + PROCEDURE, NOPASS :: intfunction3 => proc_intfunc + + ! For access-based checks. + PROCEDURE, NOPASS, PRIVATE :: priv => proc_sub + PROCEDURE, NOPASS, PUBLIC :: publ1 => proc_sub + PROCEDURE, NOPASS, PUBLIC :: publ2 => proc_sub + + ! For passed-object dummy argument checks. + PROCEDURE, NOPASS :: nopass1 => proc_stme1 + PROCEDURE, NOPASS :: nopass2 => proc_stme1 + PROCEDURE, PASS :: pass1 => proc_stme1 + PROCEDURE, PASS(me) :: pass2 => proc_stme1 + PROCEDURE, PASS(me1) :: pass3 => proc_stmeme + + ! For corresponding dummy arguments. + PROCEDURE, PASS :: corresp1 => proc_stmeint + PROCEDURE, PASS :: corresp2 => proc_stmeint + PROCEDURE, PASS :: corresp3 => proc_stmeint + + END TYPE supert + + ! Checking for NON_OVERRIDABLE is in typebound_proc_5.f03. + + TYPE, EXTENDS(supert) :: t + CONTAINS + + ! For checking the PURE/ELEMENTAL matching. + PROCEDURE, NOPASS :: pure1 => proc_pure ! Ok, both pure. + PROCEDURE, NOPASS :: pure2 => proc_sub ! { dg-error "must also be PURE" } + PROCEDURE, NOPASS :: nonpure => proc_pure ! Ok, overridden not pure. + PROCEDURE, NOPASS :: elemental1 => proc_elemental ! Ok, both elemental. + PROCEDURE, NOPASS :: elemental2 => proc_nonelem ! { dg-error "must also be ELEMENTAL" } + PROCEDURE, NOPASS :: nonelem1 => proc_nonelem ! Ok, non elemental. + PROCEDURE, NOPASS :: nonelem2 => proc_elemental ! { dg-error "must not be ELEMENTAL" } + + ! Same number of arguments! + PROCEDURE, NOPASS :: three_args_1 => proc_threearg ! Ok. + PROCEDURE, NOPASS :: three_args_2 => proc_twoarg ! { dg-error "same number of formal arguments" } + + ! For SUBROUTINE/FUNCTION/result checking. + PROCEDURE, NOPASS :: subroutine1 => proc_sub ! Ok, both subroutines. + PROCEDURE, NOPASS :: subroutine2 => proc_intfunc ! { dg-error "must also be a SUBROUTINE" } + PROCEDURE, NOPASS :: intfunction1 => proc_intfunc ! Ok, matching functions. + PROCEDURE, NOPASS :: intfunction2 => proc_sub ! { dg-error "must also be a FUNCTION" } + PROCEDURE, NOPASS :: intfunction3 => proc_realfunc ! { dg-error "matching result types" } + + ! For access-based checks. + PROCEDURE, NOPASS, PUBLIC :: priv => proc_sub ! Ok, increases visibility. + PROCEDURE, NOPASS, PUBLIC :: publ1 => proc_sub ! Ok, both PUBLIC. + PROCEDURE, NOPASS, PRIVATE :: publ2 => proc_sub ! { dg-error "must not be PRIVATE" } + + ! For passed-object dummy argument checks. + PROCEDURE, NOPASS :: nopass1 => proc_stme1 ! Ok, both NOPASS. + PROCEDURE, PASS :: nopass2 => proc_tme1 ! { dg-error "must also be NOPASS" } + PROCEDURE, PASS :: pass1 => proc_tme1 ! Ok. + PROCEDURE, NOPASS :: pass2 => proc_stme1 ! { dg-error "must also be PASS" } + PROCEDURE, PASS(me2) :: pass3 => proc_tmeme ! { dg-error "same position" } + + ! For corresponding dummy arguments. + PROCEDURE, PASS :: corresp1 => proc_tmeint ! Ok. + PROCEDURE, PASS :: corresp2 => proc_tmeintx ! { dg-error "should be named 'a'" } + PROCEDURE, PASS :: corresp3 => proc_tmereal ! { dg-error "Types mismatch for dummy argument 'a'" } + + END TYPE t + +CONTAINS + + PURE SUBROUTINE proc_pure () + END SUBROUTINE proc_pure + + ELEMENTAL SUBROUTINE proc_elemental (arg) + IMPLICIT NONE + INTEGER, INTENT(INOUT) :: arg + END SUBROUTINE proc_elemental + + SUBROUTINE proc_nonelem (arg) + IMPLICIT NONE + INTEGER, INTENT(INOUT) :: arg + END SUBROUTINE proc_nonelem + + SUBROUTINE proc_threearg (a, b, c) + IMPLICIT NONE + INTEGER :: a, b, c + END SUBROUTINE proc_threearg + + SUBROUTINE proc_twoarg (a, b) + IMPLICIT NONE + INTEGER :: a, b + END SUBROUTINE proc_twoarg + + SUBROUTINE proc_sub () + END SUBROUTINE proc_sub + + INTEGER FUNCTION proc_intfunc () + proc_intfunc = 42 + END FUNCTION proc_intfunc + + REAL FUNCTION proc_realfunc () + proc_realfunc = 42.0 + END FUNCTION proc_realfunc + + SUBROUTINE proc_stme1 (me, a) + IMPLICIT NONE + TYPE(supert) :: me + INTEGER :: a + END SUBROUTINE proc_stme1 + + SUBROUTINE proc_tme1 (me, a) + IMPLICIT NONE + TYPE(t) :: me + INTEGER :: a + END SUBROUTINE proc_tme1 + + SUBROUTINE proc_stmeme (me1, me2) + IMPLICIT NONE + TYPE(supert) :: me1, me2 + END SUBROUTINE proc_stmeme + + SUBROUTINE proc_tmeme (me1, me2) + IMPLICIT NONE + TYPE(t) :: me1, me2 + END SUBROUTINE proc_tmeme + + SUBROUTINE proc_stmeint (me, a) + IMPLICIT NONE + TYPE(supert) :: me + INTEGER :: a + END SUBROUTINE proc_stmeint + + SUBROUTINE proc_tmeint (me, a) + IMPLICIT NONE + TYPE(t) :: me + INTEGER :: a + END SUBROUTINE proc_tmeint + + SUBROUTINE proc_tmeintx (me, x) + IMPLICIT NONE + TYPE(t) :: me + INTEGER :: x + END SUBROUTINE proc_tmeintx + + SUBROUTINE proc_tmereal (me, a) + IMPLICIT NONE + TYPE(t) :: me + REAL :: a + END SUBROUTINE proc_tmereal + +END MODULE testmod + +! { dg-final { cleanup-modules "testmod" } } +! FIXME: Remove not-yet-implemented error when implemented. +! { dg-excess-errors "not yet implemented" } -- 2.7.4