aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/ChangeLog27
-rw-r--r--gcc/fortran/expr.c2
-rw-r--r--gcc/fortran/gfortran.h2
-rw-r--r--gcc/fortran/resolve.c140
-rw-r--r--gcc/testsuite/ChangeLog14
-rw-r--r--gcc/testsuite/gfortran.dg/array_simplify_1.f9016
-rw-r--r--gcc/testsuite/gfortran.dg/entry_dummy_ref_1.f9015
-rw-r--r--gcc/testsuite/gfortran.dg/entry_dummy_ref_2.f9020
-rw-r--r--gcc/testsuite/gfortran.dg/saved_automatic_1.f9021
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
+
generated by cgit v1.1 at 2024-11-10 13:48:38 +0000