diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/fortran/ChangeLog | 27 | ||||
| -rw-r--r-- | gcc/fortran/expr.c | 2 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 2 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 140 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 14 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/array_simplify_1.f90 | 16 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/entry_dummy_ref_1.f90 | 15 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/entry_dummy_ref_2.f90 | 20 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/saved_automatic_1.f90 | 21 |
9 files changed, 243 insertions, 14 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index a2cd96e..23e50d1 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,30 @@ +2006-06-07 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/23091 + * resolve.c (resolve_fl_variable): Error if an automatic + object has the SAVE attribute. + + PR fortran/24168 + * expr.c (simplify_intrinsic_op): Transfer the rank and + the locus to the simplified expression. + + PR fortran/25090 + PR fortran/25058 + * gfortran.h : Add int entry_id to gfc_symbol. + * resolve.c : Add static variables current_entry_id and + specification_expr. + (resolve_variable): During code resolution, check if a + reference to a dummy variable in an executable expression + is preceded by its appearance as a parameter in an entry. + Likewise check its specification expressions. + (resolve_code): Update current_entry_id on EXEC_ENTRY. + (resolve_charlen, resolve_fl_variable): Set and reset + specifiaction_expr. + (is_non_constant_shape_array): Do not return on detection + of a variable but continue to resolve all the expressions. + (resolve_codes): set current_entry_id to an out of range + value. + 2006-06-06 Mike Stump <mrs@apple.com> * Make-lang.in: Rename to htmldir to build_htmldir to avoid diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 84dcf68..a163151 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -869,6 +869,8 @@ simplify_intrinsic_op (gfc_expr * p, int type) return FAILURE; } + result->rank = p->rank; + result->where = p->where; gfc_replace_expr (p, result); return SUCCESS; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index d5b3411..6cfd934 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -838,6 +838,8 @@ typedef struct gfc_symbol order. */ int dummy_order; + int entry_id; + gfc_namelist *namelist, *namelist_tail; /* Change management fields. Symbols that might be modified by the diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 8e54d3c..33e21df 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -60,6 +60,12 @@ static int omp_workshare_flag; resets the flag each time that it is read. */ static int formal_arg_flag = 0; +/* True if we are resolving a specification expression. */ +static int specification_expr = 0; + +/* The id of the last entry seen. */ +static int current_entry_id; + int gfc_is_formal_arg (void) { @@ -2763,6 +2769,9 @@ static try resolve_variable (gfc_expr * e) { gfc_symbol *sym; + try t; + + t = SUCCESS; if (e->ref && resolve_ref (e) == FAILURE) return FAILURE; @@ -2790,7 +2799,73 @@ resolve_variable (gfc_expr * e) if (check_assumed_size_reference (sym, e)) return FAILURE; - return SUCCESS; + /* Deal with forward references to entries during resolve_code, to + satisfy, at least partially, 12.5.2.5. */ + if (gfc_current_ns->entries + && current_entry_id == sym->entry_id + && cs_base + && cs_base->current + && cs_base->current->op != EXEC_ENTRY) + { + gfc_entry_list *entry; + gfc_formal_arglist *formal; + int n; + bool seen; + + /* If the symbol is a dummy... */ + if (sym->attr.dummy) + { + entry = gfc_current_ns->entries; + seen = false; + + /* ...test if the symbol is a parameter of previous entries. */ + for (; entry && entry->id <= current_entry_id; entry = entry->next) + for (formal = entry->sym->formal; formal; formal = formal->next) + { + if (formal->sym && sym->name == formal->sym->name) + seen = true; + } + + /* If it has not been seen as a dummy, this is an error. */ + if (!seen) + { + if (specification_expr) + gfc_error ("Variable '%s',used in a specification expression, " + "is referenced at %L before the ENTRY statement " + "in which it is a parameter", + sym->name, &cs_base->current->loc); + else + gfc_error ("Variable '%s' is used at %L before the ENTRY " + "statement in which it is a parameter", + sym->name, &cs_base->current->loc); + t = FAILURE; + } + } + + /* Now do the same check on the specification expressions. */ + specification_expr = 1; + if (sym->ts.type == BT_CHARACTER + && gfc_resolve_expr (sym->ts.cl->length) == FAILURE) + t = FAILURE; + + if (sym->as) + for (n = 0; n < sym->as->rank; n++) + { + specification_expr = 1; + if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE) + t = FAILURE; + specification_expr = 1; + if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE) + t = FAILURE; + } + specification_expr = 0; + + if (t == SUCCESS) + /* Update the symbol's entry level. */ + sym->entry_id = current_entry_id + 1; + } + + return t; } @@ -4490,7 +4565,11 @@ resolve_code (gfc_code * code, gfc_namespace * ns) case EXEC_EXIT: case EXEC_CONTINUE: case EXEC_DT_END: + break; + case EXEC_ENTRY: + /* Keep track of which entry we are up to. */ + current_entry_id = code->ext.entry->id; break; case EXEC_WHERE: @@ -4769,7 +4848,6 @@ resolve_values (gfc_symbol * sym) static try resolve_index_expr (gfc_expr * e) { - if (gfc_resolve_expr (e) == FAILURE) return FAILURE; @@ -4792,8 +4870,13 @@ resolve_charlen (gfc_charlen *cl) cl->resolved = 1; + specification_expr = 1; + if (resolve_index_expr (cl->length) == FAILURE) - return FAILURE; + { + specification_expr = 0; + return FAILURE; + } return SUCCESS; } @@ -4806,7 +4889,9 @@ is_non_constant_shape_array (gfc_symbol *sym) { gfc_expr *e; int i; + bool not_constant; + not_constant = false; if (sym->as != NULL) { /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that @@ -4817,15 +4902,15 @@ is_non_constant_shape_array (gfc_symbol *sym) e = sym->as->lower[i]; if (e && (resolve_index_expr (e) == FAILURE || !gfc_is_constant_expr (e))) - return true; + not_constant = true; e = sym->as->upper[i]; if (e && (resolve_index_expr (e) == FAILURE || !gfc_is_constant_expr (e))) - return true; + not_constant = true; } } - return false; + return not_constant; } /* Resolution of common features of flavors variable and procedure. */ @@ -4877,22 +4962,34 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) int i; gfc_expr *e; gfc_expr *constructor_expr; + const char * auto_save_msg; + + auto_save_msg = "automatic object '%s' at %L cannot have the " + "SAVE attribute"; if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE) return FAILURE; - /* The shape of a main program or module array needs to be constant. */ - if (sym->ns->proc_name - && (sym->ns->proc_name->attr.flavor == FL_MODULE - || sym->ns->proc_name->attr.is_main_program) - && !sym->attr.use_assoc + /* Set this flag to check that variables are parameters of all entries. + This check is effected by the call to gfc_resolve_expr through + is_non_constant_shape_array. */ + specification_expr = 1; + + if (!sym->attr.use_assoc && !sym->attr.allocatable && !sym->attr.pointer && is_non_constant_shape_array (sym)) { - gfc_error ("The module or main program array '%s' at %L must " - "have constant shape", sym->name, &sym->declared_at); - return FAILURE; + /* The shape of a main program or module array needs to be constant. */ + if (sym->ns->proc_name + && (sym->ns->proc_name->attr.flavor == FL_MODULE + || sym->ns->proc_name->attr.is_main_program)) + { + gfc_error ("The module or main program array '%s' at %L must " + "have constant shape", sym->name, &sym->declared_at); + specification_expr = 0; + return FAILURE; + } } if (sym->ts.type == BT_CHARACTER) @@ -4907,6 +5004,12 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) return FAILURE; } + if (e && sym->attr.save && !gfc_is_constant_expr (e)) + { + gfc_error (auto_save_msg, sym->name, &sym->declared_at); + return FAILURE; + } + if (!gfc_is_constant_expr (e) && !(e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.flavor == FL_PARAMETER) @@ -4940,6 +5043,13 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) break; } } + + /* Also, they must not have the SAVE attribute. */ + if (flag && sym->attr.save) + { + gfc_error (auto_save_msg, sym->name, &sym->declared_at); + return FAILURE; + } } /* Reject illegal initializers. */ @@ -6416,6 +6526,8 @@ resolve_codes (gfc_namespace * ns) gfc_current_ns = ns; cs_base = NULL; + /* Set to an out of range value. */ + current_entry_id = -1; resolve_code (ns->code, ns); } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 0f42204..b93f912 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,17 @@ +2006-06-07 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/23091 + * gfortran.dg/saved_automatic_1.f90: New test. + + PR fortran/24168 + * gfortran.dg/array_simplify_1.f90: New test. + + PR fortran/25090 + * gfortran.dg/entry_dummy_ref_1.f90: New test. + + PR fortran/25058 + * gfortran.dg/entry_dummy_ref_2.f90: New test. + 2006-06-06 Mark Mitchell <mark@codesourcery.com> PR c++/27177 diff --git a/gcc/testsuite/gfortran.dg/array_simplify_1.f90 b/gcc/testsuite/gfortran.dg/array_simplify_1.f90 new file mode 100644 index 0000000..c638dee --- /dev/null +++ b/gcc/testsuite/gfortran.dg/array_simplify_1.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! Tests the fix for PR24168, in which line would return +! Error: Incompatible ranks 2 and 1 in assignment at (1) +! This came about because the simplification of the binary +! operation, in the first actual argument of spread, was not +! returning the rank of the result. Thus the error could +! be generated with any operator and other intrinsics than +! cshift. +! +! Contributed by Steve Kargl <kargl@gcc.gnu.org> +! + integer, parameter :: nx=2, ny=2 + real, dimension(nx, ny) :: f + f = spread(2 * cshift((/ 1, 2 /), nx/2), 2, ny) +end + diff --git a/gcc/testsuite/gfortran.dg/entry_dummy_ref_1.f90 b/gcc/testsuite/gfortran.dg/entry_dummy_ref_1.f90 new file mode 100644 index 0000000..8985b93 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/entry_dummy_ref_1.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! Tests fix for PR25090 in which references in specification +! expressions to variables that were not entry formal arguments +! would be missed. +! +! Contributed by Joost VandeVondele <jv244@cam.ac.uk> +! + SUBROUTINE S1(I) + CHARACTER(LEN=I+J) :: a + real :: x(i:j), z + a = "" ! { dg-error "before the ENTRY statement in which it is a parameter" } + x = 0.0 ! { dg-error "before the ENTRY statement in which it is a parameter" } + ENTRY E1(J) + END SUBROUTINE S1 + END diff --git a/gcc/testsuite/gfortran.dg/entry_dummy_ref_2.f90 b/gcc/testsuite/gfortran.dg/entry_dummy_ref_2.f90 new file mode 100644 index 0000000..46dbdf6 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/entry_dummy_ref_2.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! Tests fix for PR25058 in which references to dummy +! parameters before the entry would be missed. +! +! Contributed by Joost VandeVondele <jv244@cam.ac.uk> +! +MODULE M1 +CONTAINS +FUNCTION F1(I) RESULT(RF1) + INTEGER :: I,K,RE1,RF1 + RE1=K ! { dg-error "before the ENTRY statement" } + RETURN + ENTRY E1(K) RESULT(RE1) + RE1=-I + RETURN +END FUNCTION F1 +END MODULE M1 +END + +! { dg-final { cleanup-modules "M1" } } diff --git a/gcc/testsuite/gfortran.dg/saved_automatic_1.f90 b/gcc/testsuite/gfortran.dg/saved_automatic_1.f90 new file mode 100644 index 0000000..53e7dce --- /dev/null +++ b/gcc/testsuite/gfortran.dg/saved_automatic_1.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! Tests patch for PR23091, in which autmatic objects caused +! an ICE if they were given the SAVE attribute. +! +! Contributed by Valera Veryazov <valera.veryazov@teokem.lu.se> +! +Subroutine My(n1) + integer :: myArray(n1) + character(n1) :: ch + save ! OK because only allowed objects are saved globally. + call xxx(myArray, ch) + return + end + +Subroutine Thy(n1) + integer, save :: myArray(n1) ! { dg-error "SAVE attribute" } + character(n1), save :: ch ! { dg-error "SAVE attribute" } + call xxx(myArray, ch) + return + end + |