diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 28 | ||||
| -rw-r--r-- | gcc/fortran/decl.c | 113 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 2 | ||||
| -rw-r--r-- | gcc/fortran/misc.c | 2 | ||||
| -rw-r--r-- | gcc/fortran/parse.c | 230 | ||||
| -rw-r--r-- | gcc/fortran/parse.h | 5 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 20 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/auto_internal_assumed.f90 | 4 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/defined_operators_1.f90 | 16 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/elemental_args_check_2.f90 | 4 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/function_charlen_1.f90 | 23 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/function_kinds_4.f90 | 56 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/function_kinds_5.f90 | 10 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/function_types_1.f90 | 12 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/function_types_2.f90 | 104 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/interface_15.f90 | 4 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/private_type_4.f90 | 4 |
17 files changed, 554 insertions, 83 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 35944a2..dccfcdf 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,31 @@ +2008-01-17 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/34429 + PR fortran/34431 + PR fortran/34471 + * decl.c : Remove gfc_function_kind_locus and + gfc_function_type_locus. Add gfc_matching_function. + (match_char_length): If matching a function and the length + does not match, return MATCH_YES and try again later. + (gfc_match_kind_spec): The same. + (match_char_kind): The same. + (gfc_match_type_spec): The same for numeric and derived types. + (match_prefix): Rename as gfc_match_prefix. + (gfc_match_function_decl): Except for function valued character + lengths, defer applying kind, type and charlen info until the + end of specification block. + gfortran.h (gfc_statement): Add ST_GET_FCN_CHARACTERISTICS. + parse.c (decode_specification_statement): New function. + (decode_statement): Call it when a function has kind = -1. Set + and reset gfc_matching function, as function statement is being + matched. + (match_deferred_characteristics): Simplify with a single call + to gfc_match_prefix. Do appropriate error handling. In any + case, make sure that kind = -1 is reset or corrected. + (parse_spec): Call above on seeing ST_GET_FCN_CHARACTERISTICS. + Throw an error if kind = -1 after last specification statement. + parse.h : Prototype for gfc_match_prefix. + 2008-01-16 Tobias Burnus <burnus@net-b.de> PR fortran/34796 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 74d0962..115b30e 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -86,8 +86,7 @@ static enumerator_history *max_enum = NULL; gfc_symbol *gfc_new_block; -locus gfc_function_kind_locus; -locus gfc_function_type_locus; +bool gfc_matching_function; /********************* DATA statement subroutines *********************/ @@ -653,6 +652,12 @@ match_char_length (gfc_expr **expr) goto syntax; m = char_len_param_value (expr); + if (m != MATCH_YES && gfc_matching_function) + { + gfc_undo_symbols (); + m = MATCH_YES; + } + if (m == MATCH_ERROR) return m; if (m == MATCH_NO) @@ -1869,13 +1874,11 @@ kind_expr: if (n != MATCH_YES) { - if (gfc_current_state () == COMP_INTERFACE - || gfc_current_state () == COMP_NONE - || gfc_current_state () == COMP_CONTAINS) + if (gfc_matching_function) { - /* Signal using kind = -1 that the expression might include - use associated or imported parameters and try again after - the specification expressions..... */ + /* The function kind expression might include use associated or + imported parameters and try again after the specification + expressions..... */ if (gfc_match_char (')') != MATCH_YES) { gfc_error ("Missing right parenthesis at %C"); @@ -1884,8 +1887,6 @@ kind_expr: } gfc_free_expr (e); - ts->kind = -1; - gfc_function_kind_locus = loc; gfc_undo_symbols (); return MATCH_YES; } @@ -1907,6 +1908,7 @@ kind_expr: } msg = gfc_extract_int (e, &ts->kind); + if (msg != NULL) { gfc_error (msg); @@ -1977,17 +1979,12 @@ match_char_kind (int * kind, int * is_iso_c) n = gfc_match_init_expr (&e); - if (n != MATCH_YES - && (gfc_current_state () == COMP_INTERFACE - || gfc_current_state () == COMP_NONE - || gfc_current_state () == COMP_CONTAINS)) + if (n != MATCH_YES && gfc_matching_function) { - /* Signal using kind = -1 that the expression might include - use-associated or imported parameters and try again after - the specification expressions. */ + /* The expression might include use-associated or imported + parameters and try again after the specification + expressions. */ gfc_free_expr (e); - *kind = -1; - gfc_function_kind_locus = where; gfc_undo_symbols (); return MATCH_YES; } @@ -2154,6 +2151,17 @@ syntax: return m; done: + /* Except in the case of the length being a function, where symbol + association looks after itself, deal with character functions + after the specification statements. */ + if (gfc_matching_function + && !(len && len->expr_type != EXPR_VARIABLE + && len->expr_type != EXPR_OP)) + { + gfc_undo_symbols (); + return MATCH_YES; + } + if (m != MATCH_YES) { gfc_free_expr (len); @@ -2209,9 +2217,16 @@ gfc_match_type_spec (gfc_typespec *ts, int implicit_flag) gfc_symbol *sym; match m; int c; - locus loc = gfc_current_locus; + bool seen_deferred_kind; + /* A belt and braces check that the typespec is correctly being treated + as a deferred characteristic association. */ + seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION) + && (gfc_current_block ()->result->ts.kind == -1) + && (ts->kind == -1); gfc_clear_ts (ts); + if (seen_deferred_kind) + ts->kind = -1; /* Clear the current binding label, in case one is given. */ curr_binding_label[0] = '\0'; @@ -2293,18 +2308,24 @@ gfc_match_type_spec (gfc_typespec *ts, int implicit_flag) if (m != MATCH_YES) return m; - if (gfc_current_state () == COMP_INTERFACE - || gfc_current_state () == COMP_NONE) + ts->type = BT_DERIVED; + + /* Defer association of the derived type until the end of the + specification block. However, if the derived type can be + found, add it to the typespec. */ + if (gfc_matching_function) { - gfc_function_type_locus = loc; - ts->type = BT_UNKNOWN; - ts->kind = -1; + ts->derived = NULL; + if (gfc_current_state () != COMP_INTERFACE + && !gfc_find_symbol (name, NULL, 1, &sym) && sym) + ts->derived = sym; return MATCH_YES; } /* Search for the name but allow the components to be defined later. If type = -1, this typespec has been seen in a function declaration but - the type could not legally be accessed at that point. */ + the type could not be accessed at that point. */ + sym = NULL; if (ts->kind != -1 && gfc_get_ha_symbol (name, &sym)) { gfc_error ("Type name '%s' at %C is ambiguous", name); @@ -2312,12 +2333,15 @@ gfc_match_type_spec (gfc_typespec *ts, int implicit_flag) } else if (ts->kind == -1) { - if (gfc_find_symbol (name, NULL, 0, &sym)) + int iface = gfc_state_stack->previous->state != COMP_INTERFACE + || gfc_current_ns->has_import_set; + if (gfc_find_symbol (name, NULL, iface, &sym)) { gfc_error ("Type name '%s' at %C is ambiguous", name); return MATCH_ERROR; } + ts->kind = 0; if (sym == NULL) return MATCH_NO; } @@ -2326,8 +2350,7 @@ gfc_match_type_spec (gfc_typespec *ts, int implicit_flag) && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE) return MATCH_ERROR; - ts->type = BT_DERIVED; - ts->kind = 0; + gfc_set_sym_referenced (sym); ts->derived = sym; return MATCH_YES; @@ -2350,6 +2373,12 @@ get_kind: if (m == MATCH_NO && ts->type != BT_CHARACTER) m = gfc_match_old_kind_spec (ts); + /* Defer association of the KIND expression of function results + until after USE and IMPORT statements. */ + if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ()) + || gfc_matching_function) + return MATCH_YES; + if (m == MATCH_NO) m = MATCH_YES; /* No kind specifier found. */ @@ -3673,8 +3702,8 @@ cleanup: can be matched. Note that if nothing matches, MATCH_YES is returned (the null string was matched). */ -static match -match_prefix (gfc_typespec *ts) +match +gfc_match_prefix (gfc_typespec *ts) { bool seen_type; @@ -3720,7 +3749,7 @@ loop: } -/* Copy attributes matched by match_prefix() to attributes on a symbol. */ +/* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */ static try copy_prefix (symbol_attribute *dest, locus *where) @@ -4245,7 +4274,7 @@ gfc_match_function_decl (void) old_loc = gfc_current_locus; - m = match_prefix (¤t_ts); + m = gfc_match_prefix (¤t_ts); if (m != MATCH_YES) { gfc_current_locus = old_loc; @@ -4329,6 +4358,22 @@ gfc_match_function_decl (void) goto cleanup; } + /* Except in the case of a function valued character length, + delay matching the function characteristics until after the + specification block by signalling kind=-1. */ + if (!(current_ts.type == BT_CHARACTER + && current_ts.cl + && current_ts.cl->length + && current_ts.cl->length->expr_type != EXPR_OP + && current_ts.cl->length->expr_type != EXPR_VARIABLE)) + { + sym->declared_at = old_loc; + if (current_ts.type != BT_UNKNOWN) + current_ts.kind = -1; + else + current_ts.kind = 0; + } + if (result == NULL) { sym->ts = current_ts; @@ -4635,7 +4680,7 @@ gfc_match_subroutine (void) && gfc_current_state () != COMP_CONTAINS) return MATCH_NO; - m = match_prefix (NULL); + m = gfc_match_prefix (NULL); if (m != MATCH_YES) return m; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 54c6ad8..aac1f82 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -223,7 +223,7 @@ typedef enum 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_PROCEDURE, - ST_NONE + ST_GET_FCN_CHARACTERISTICS, ST_NONE } gfc_statement; diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c index 4bc5c43..5ee5434 100644 --- a/gcc/fortran/misc.c +++ b/gcc/fortran/misc.c @@ -74,8 +74,8 @@ void gfc_clear_ts (gfc_typespec *ts) { ts->type = BT_UNKNOWN; - ts->kind = 0; ts->derived = NULL; + ts->kind = 0; ts->cl = NULL; /* flag that says if the type is C interoperable */ ts->is_c_interop = 0; diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index c941b4e..e57e10d 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -85,6 +85,144 @@ match_word (const char *str, match (*subr) (void), locus *old_locus) undo_new_statement (); \ } while (0); + +/* This is a specialist version of decode_statement that is used + for the specification statements in a function, whose + characteristics are deferred into the specification statements. + eg.: INTEGER (king = mykind) foo () + USE mymodule, ONLY mykind..... + The KIND parameter needs a return after USE or IMPORT, whereas + derived type declarations can occur anywhere, up the executable + block. ST_GET_FCN_CHARACTERISTICS is returned when we have run + out of the correct kind of specification statements. */ +static gfc_statement +decode_specification_statement (void) +{ + gfc_statement st; + locus old_locus; + int c; + + if (gfc_match_eos () == MATCH_YES) + return ST_NONE; + + old_locus = gfc_current_locus; + + match ("import", gfc_match_import, ST_IMPORT); + match ("use", gfc_match_use, ST_USE); + + if (gfc_numeric_ts (&gfc_current_block ()->ts)) + goto end_of_block; + + match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION); + match (NULL, gfc_match_data_decl, ST_DATA_DECL); + match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR); + + /* General statement matching: Instead of testing every possible + statement, we eliminate most possibilities by peeking at the + first character. */ + + c = gfc_peek_char (); + + switch (c) + { + case 'a': + match ("abstract% interface", gfc_match_abstract_interface, + ST_INTERFACE); + break; + + case 'b': + match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL); + break; + + case 'c': + break; + + case 'd': + match ("data", gfc_match_data, ST_DATA); + match ("dimension", gfc_match_dimension, ST_ATTR_DECL); + break; + + case 'e': + match ("enum , bind ( c )", gfc_match_enum, ST_ENUM); + match ("entry% ", gfc_match_entry, ST_ENTRY); + match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE); + match ("external", gfc_match_external, ST_ATTR_DECL); + break; + + case 'f': + match ("format", gfc_match_format, ST_FORMAT); + break; + + case 'g': + break; + + case 'i': + match ("implicit", gfc_match_implicit, ST_IMPLICIT); + match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE); + match ("interface", gfc_match_interface, ST_INTERFACE); + match ("intent", gfc_match_intent, ST_ATTR_DECL); + match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL); + break; + + case 'm': + break; + + case 'n': + match ("namelist", gfc_match_namelist, ST_NAMELIST); + break; + + case 'o': + match ("optional", gfc_match_optional, ST_ATTR_DECL); + break; + + case 'p': + match ("parameter", gfc_match_parameter, ST_PARAMETER); + match ("pointer", gfc_match_pointer, ST_ATTR_DECL); + if (gfc_match_private (&st) == MATCH_YES) + return st; + match ("procedure", gfc_match_procedure, ST_PROCEDURE); + if (gfc_match_public (&st) == MATCH_YES) + return st; + match ("protected", gfc_match_protected, ST_ATTR_DECL); + break; + + case 'r': + break; + + case 's': + match ("save", gfc_match_save, ST_ATTR_DECL); + break; + + case 't': + match ("target", gfc_match_target, ST_ATTR_DECL); + match ("type", gfc_match_derived_decl, ST_DERIVED_DECL); + break; + + case 'u': + break; + + case 'v': + match ("value", gfc_match_value, ST_ATTR_DECL); + match ("volatile", gfc_match_volatile, ST_ATTR_DECL); + break; + + case 'w': + break; + } + + /* This is not a specification statement. See if any of the matchers + has stored an error message of some sort. */ + +end_of_block: + gfc_clear_error (); + gfc_buffer_error (0); + gfc_current_locus = old_locus; + + return ST_GET_FCN_CHARACTERISTICS; +} + + +/* This is the primary 'decode_statement'. */ static gfc_statement decode_statement (void) { @@ -100,9 +238,15 @@ decode_statement (void) gfc_clear_error (); /* Clear any pending errors. */ gfc_clear_warning (); /* Clear any pending warnings. */ + gfc_matching_function = false; + if (gfc_match_eos () == MATCH_YES) return ST_NONE; + if (gfc_current_state () == COMP_FUNCTION + && gfc_current_block ()->result->ts.kind == -1) + return decode_specification_statement (); + old_locus = gfc_current_locus; /* Try matching a data declaration or function declaration. The @@ -113,6 +257,7 @@ decode_statement (void) || gfc_current_state () == COMP_INTERFACE || gfc_current_state () == COMP_CONTAINS) { + gfc_matching_function = true; m = gfc_match_function_decl (); if (m == MATCH_YES) return ST_FUNCTION; @@ -122,6 +267,8 @@ decode_statement (void) gfc_undo_symbols (); gfc_current_locus = old_locus; } + gfc_matching_function = false; + /* Match statements whose error messages are meant to be overwritten by something better. */ @@ -1870,30 +2017,48 @@ done: } -/* Recover use associated or imported function characteristics. */ +/* Associate function characteristics by going back to the function + declaration and rematching the prefix. */ -static try +static match match_deferred_characteristics (gfc_typespec * ts) { locus loc; - match m; + match m = MATCH_ERROR; + char name[GFC_MAX_SYMBOL_LEN + 1]; loc = gfc_current_locus; - if (gfc_current_block ()->ts.type != BT_UNKNOWN) + gfc_current_locus = gfc_current_block ()->declared_at; + + gfc_clear_error (); + gfc_buffer_error (1); + m = gfc_match_prefix (ts); + gfc_buffer_error (0); + + if (ts->type == BT_DERIVED) { - /* Kind expression for an intrinsic type. */ - gfc_current_locus = gfc_function_kind_locus; - m = gfc_match_kind_spec (ts, true); + ts->kind = 0; + + if (!ts->derived || !ts->derived->components) + m = MATCH_ERROR; } - else + + /* Only permit one go at the characteristic association. */ + if (ts->kind == -1) + ts->kind = 0; + + /* Set the function locus correctly. If we have not found the + function name, there is an error. */ + gfc_match ("function% %n", name); + if (m == MATCH_YES && strcmp (name, gfc_current_block ()->name) == 0) { - /* A derived type. */ - gfc_current_locus = gfc_function_type_locus; - m = gfc_match_type_spec (ts, 0); + gfc_current_block ()->declared_at = gfc_current_locus; + gfc_commit_symbols (); } + else + gfc_error_check (); - gfc_current_ns->proc_name->result->ts = *ts; gfc_current_locus =loc; return m; } @@ -1906,6 +2071,8 @@ static gfc_statement parse_spec (gfc_statement st) { st_state ss; + bool bad_characteristic = false; + gfc_typespec *ts; verify_st_order (&ss, ST_NONE); if (st == ST_NONE) @@ -1984,15 +2151,6 @@ loop: } accept_statement (st); - - /* Look out for function kind/type information that used - use associated or imported parameter. This is signalled - by kind = -1. */ - if (gfc_current_state () == COMP_FUNCTION - && (st == ST_USE || st == ST_IMPORT || st == ST_DERIVED_DECL) - && gfc_current_block ()->ts.kind == -1) - match_deferred_characteristics (&gfc_current_block ()->ts); - st = next_statement (); goto loop; @@ -2002,21 +2160,37 @@ loop: st = next_statement (); goto loop; + case ST_GET_FCN_CHARACTERISTICS: + /* This statement triggers the association of a function's result + characteristics. */ + ts = &gfc_current_block ()->result->ts; + if (match_deferred_characteristics (ts) != MATCH_YES) + bad_characteristic = true; + + st = next_statement (); + goto loop; + default: break; } - /* If we still have kind = -1 at the end of the specification block, - then there is an error. */ - if (gfc_current_state () == COMP_FUNCTION - && gfc_current_block ()->ts.kind == -1) + /* If match_deferred_characteristics failed, then there is an error. */ + if (bad_characteristic) { - if (gfc_current_block ()->ts.type != BT_UNKNOWN) + ts = &gfc_current_block ()->result->ts; + if (ts->type != BT_DERIVED) gfc_error ("Bad kind expression for function '%s' at %L", - gfc_current_block ()->name, &gfc_function_kind_locus); + gfc_current_block ()->name, + &gfc_current_block ()->declared_at); else gfc_error ("The type for function '%s' at %L is not accessible", - gfc_current_block ()->name, &gfc_function_type_locus); + gfc_current_block ()->name, + &gfc_current_block ()->declared_at); + + gfc_current_block ()->ts.kind = 0; + /* Keep the derived type; if it's bad, it will be discovered later. */ + if (!(ts->type = BT_DERIVED && ts->derived)) + ts->type = BT_UNKNOWN; } return st; diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index 307d59a..be885bb 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -66,7 +66,6 @@ const char *gfc_ascii_statement (gfc_statement); match gfc_match_enum (void); match gfc_match_enumerator_def (void); void gfc_free_enum_history (void); -extern locus gfc_function_kind_locus; -extern locus gfc_function_type_locus; - +extern bool gfc_matching_function; +match gfc_match_prefix (gfc_typespec *); #endif /* GFC_PARSE_H */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index ed896b4..c86bb45 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,23 @@ +2008-01-17 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/34429 + * gfortran.dg/function_charlen_1.f90: New test. + + PR fortran/34431 + * gfortran.dg/function_types_1.f90: New test. + * gfortran.dg/function_types_2.f90: New test. + + PR fortran/34471 + * gfortran.dg/function_kinds_4.f90: New test. + * gfortran.dg/function_kinds_5.f90: New test. + + * gfortran.dg/defined_operators_1.f90: Errors now at function + declarations. + * gfortran.dg/private_type_4.f90: The same. + * gfortran.dg/interface_15.f90: The same. + * gfortran.dg/elemental_args_check_2.f90: The same. + * gfortran.dg/auto_internal_assumed.f90: The same. + 2008-01-16 Eric Botcazou <ebotcazou@adacore.com> * gnat.dg/sizetype.adb: New test. diff --git a/gcc/testsuite/gfortran.dg/auto_internal_assumed.f90 b/gcc/testsuite/gfortran.dg/auto_internal_assumed.f90 index c053216..ec0ea7f 100644 --- a/gcc/testsuite/gfortran.dg/auto_internal_assumed.f90 +++ b/gcc/testsuite/gfortran.dg/auto_internal_assumed.f90 @@ -3,10 +3,10 @@ ! internal function. ! character (6) :: c - c = f1 () ! { dg-error "must not be assumed length" } + c = f1 () if (c .ne. 'abcdef') call abort contains - function f1 () + function f1 () ! { dg-error "must not be assumed length" } character (*) :: f1 f1 = 'abcdef' end function f1 diff --git a/gcc/testsuite/gfortran.dg/defined_operators_1.f90 b/gcc/testsuite/gfortran.dg/defined_operators_1.f90 index 0233bf0..bd25021 100644 --- a/gcc/testsuite/gfortran.dg/defined_operators_1.f90 +++ b/gcc/testsuite/gfortran.dg/defined_operators_1.f90 @@ -7,10 +7,10 @@ ! module mymod interface operator (.foo.) - module procedure foo_0 ! { dg-error "must have at least one argument" } - module procedure foo_1 ! { dg-error "must be INTENT" } - module procedure foo_2 ! { dg-error "cannot be optional" } - module procedure foo_3 ! { dg-error "must have, at most, two arguments" } + module procedure foo_0 + module procedure foo_1 + module procedure foo_2 + module procedure foo_3 module procedure foo_1_OK ! { dg-error "Ambiguous interfaces" } module procedure foo_2_OK function foo_chr (chr) ! { dg-error "cannot be assumed character length" } @@ -22,11 +22,11 @@ module mymod end subroutine bad_foo end interface contains - function foo_0 () + function foo_0 () ! { dg-error "must have at least one argument" } integer :: foo_1 foo_0 = 1 end function foo_0 - function foo_1 (a) + function foo_1 (a) ! { dg-error "must be INTENT" } integer :: foo_1 integer :: a foo_1 = 1 @@ -36,7 +36,7 @@ contains integer, intent (in) :: a foo_1_OK = 1 end function foo_1_OK - function foo_2 (a, b) + function foo_2 (a, b) ! { dg-error "cannot be optional" } integer :: foo_2 integer, intent(in) :: a integer, intent(in), optional :: b @@ -48,7 +48,7 @@ contains real, intent(in) :: b foo_2_OK = 2.0 * a + b end function foo_2_OK - function foo_3 (a, b, c) + function foo_3 (a, b, c) ! { dg-error "must have, at most, two arguments" } integer :: foo_3 integer, intent(in) :: a, b, c foo_3 = a + 3 * b - c diff --git a/gcc/testsuite/gfortran.dg/elemental_args_check_2.f90 b/gcc/testsuite/gfortran.dg/elemental_args_check_2.f90 index 1a10af3..51e69a4 100644 --- a/gcc/testsuite/gfortran.dg/elemental_args_check_2.f90 +++ b/gcc/testsuite/gfortran.dg/elemental_args_check_2.f90 @@ -8,10 +8,10 @@ MODULE M1 IMPLICIT NONE CONTAINS - PURE ELEMENTAL SUBROUTINE S1(I,F) ! { dg-error "Dummy procedure 'f' not allowed in elemental procedure" } + PURE ELEMENTAL SUBROUTINE S1(I,F) INTEGER, INTENT(IN) :: I INTERFACE - PURE INTEGER FUNCTION F(I) + PURE INTEGER FUNCTION F(I) ! { dg-error "Dummy procedure 'f' not allowed in elemental procedure" } INTEGER, INTENT(IN) :: I END FUNCTION F END INTERFACE diff --git a/gcc/testsuite/gfortran.dg/function_charlen_1.f90 b/gcc/testsuite/gfortran.dg/function_charlen_1.f90 new file mode 100644 index 0000000..e0ecc63 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/function_charlen_1.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! Tests the fix for PR34429 in which function charlens that were +! USE associated would cause an error. +! +! Contributed by Tobias Burnus <burnus@gcc.gnu.org> +! +module m + integer, parameter :: strlen = 5 +end module m + +character(strlen) function test() + use m + test = 'A' +end function test + + interface + character(strlen) function test() + use m + end function test + end interface + print *, test() +end +! { dg-final { cleanup-modules "m" } } diff --git a/gcc/testsuite/gfortran.dg/function_kinds_4.f90 b/gcc/testsuite/gfortran.dg/function_kinds_4.f90 new file mode 100644 index 0000000..bcde1e4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/function_kinds_4.f90 @@ -0,0 +1,56 @@ +! { dg-do run } +! Tests the fix for PR34471 in which function KINDs that were +! USE associated would cause an error. +! +! This only needs to be run once. +! { dg-options "-O2" } +! +! Contributed by Tobias Burnus <burnus@gcc.gnu.org> +! +module m1 + integer, parameter :: i1 = 1, i2 = 2 +end module m1 + +module m2 + integer, parameter :: i1 = 8 +end module m2 + +integer(i1) function three() + use m1, only: i2 + use m2 ! This provides the function kind + three = i1 + if(three /= kind(three)) call abort() +end function three + +! At one stage during the development of the patch, this started failing +! but was not tested in gfortran.dg. */ +real (kind(0d0)) function foo () + foo = real (kind (foo)) +end function + +program main +implicit none + interface + integer(8) function three() + end function three + end interface + integer, parameter :: i1 = 4 + integer :: i + real (kind(0d0)) foo + i = one() + i = two() + if(three() /= 8) call abort() + if (int(foo()) /= 8) call abort () +contains + integer(i1) function one() ! Host associated kind + if (kind(one) /= 4) call abort() + one = 1 + end function one + integer(i1) function two() ! Use associated kind + use m1, only: i2 + use m2 + if (kind(two) /= 8) call abort() + two = 1 + end function two +end program main +! { dg-final { cleanup-modules "m1 m2" } } diff --git a/gcc/testsuite/gfortran.dg/function_kinds_5.f90 b/gcc/testsuite/gfortran.dg/function_kinds_5.f90 new file mode 100644 index 0000000..fde5bef1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/function_kinds_5.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! Tests the fix for PR34471 in which function KINDs that were +! USE associated would cause an error. This checks a regression +! caused by an intermediate version of the patch. +! +! Contributed by Tobias Burnus <burnus@gcc.gnu.org> +! +real (bad_kind(0d0)) function foo () ! { dg-error "must be an intrinsic or" } + foo = real (kind (foo)) +end function diff --git a/gcc/testsuite/gfortran.dg/function_types_1.f90 b/gcc/testsuite/gfortran.dg/function_types_1.f90 new file mode 100644 index 0000000..fb18d2f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/function_types_1.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! Tests the fix for PR34431 in which function TYPEs that were +! USE associated would cause an error. +! +! Contributed by Tobias Burnus <burnus@gcc.gnu.org> +! +module bar +contains + type(non_exist) function func2() ! { dg-error "not accessible" } + end function func2 +end module bar +! { dg-final { cleanup-modules "bar" } } diff --git a/gcc/testsuite/gfortran.dg/function_types_2.f90 b/gcc/testsuite/gfortran.dg/function_types_2.f90 new file mode 100644 index 0000000..b3b5a0a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/function_types_2.f90 @@ -0,0 +1,104 @@ +! { dg-do compile } +! Tests the fix for PR34431 in which function TYPEs that were +! USE associated would cause an error. +! +! Contributed by Tobias Burnus <burnus@gcc.gnu.org> +! +module m1 + integer :: hh + type t + real :: r + end type t +end module m1 + +module m2 + type t + integer :: k + end type t +end module m2 + +module m3 +contains + type(t) function func() + use m2 + func%k = 77 + end function func +end module m3 + +type(t) function a() + use m1, only: hh + type t2 + integer :: j + end type t2 + type t + logical :: b + end type t + + a%b = .true. +end function a + +type(t) function b() + use m1, only: hh + use m2 + use m3 + b = func () + b%k = 5 +end function b + +type(t) function c() + use m1, only: hh + type t2 + integer :: j + end type t2 + type t + logical :: b + end type t + + c%b = .true. +end function c + +program main + type t + integer :: m + end type t +contains + type(t) function a1() + use m1, only: hh + type t2 + integer :: j + end type t2 + type t + logical :: b + end type t + + a1%b = .true. + end function a1 + + type(t) function b1() + use m1, only: hh + use m2, only: t +! NAG f95 believes that the host-associated type(t) +! should be used: +! b1%m = 5 +! However, I (Tobias Burnus) believe that the use-associated one should +! be used: + b1%k = 5 + end function b1 + + type(t) function c1() + use m1, only: hh + type t2 + integer :: j + end type t2 + type t + logical :: b + end type t + + c1%b = .true. + end function c1 + + type(t) function d1() + d1%m = 55 + end function d1 +end program main +! { dg-final { cleanup-modules "m1 m2 m3" } } diff --git a/gcc/testsuite/gfortran.dg/interface_15.f90 b/gcc/testsuite/gfortran.dg/interface_15.f90 index 15f4298..2186061 100644 --- a/gcc/testsuite/gfortran.dg/interface_15.f90 +++ b/gcc/testsuite/gfortran.dg/interface_15.f90 @@ -8,12 +8,12 @@ MODULE M1 INTEGER :: I END TYPE T1 INTERFACE I - MODULE PROCEDURE F1 ! { dg-error "PUBLIC interface" } + MODULE PROCEDURE F1 END INTERFACE PRIVATE ! :: T1,F1 PUBLIC :: I CONTAINS - INTEGER FUNCTION F1(D) + INTEGER FUNCTION F1(D) ! { dg-error "PUBLIC interface" } TYPE(T1) :: D F1 = D%I END FUNCTION diff --git a/gcc/testsuite/gfortran.dg/private_type_4.f90 b/gcc/testsuite/gfortran.dg/private_type_4.f90 index aca8795..9ff39b2 100644 --- a/gcc/testsuite/gfortran.dg/private_type_4.f90 +++ b/gcc/testsuite/gfortran.dg/private_type_4.f90 @@ -7,11 +7,11 @@ module m1 end type t1 private :: t1 - public :: f1 ! { dg-error "cannot be of PRIVATE type" } + public :: f1 contains - type(t1) function f1() + type(t1) function f1() ! { dg-error "cannot be of PRIVATE type" } end function end module |