[PATCH] Fix equivalence handling (PRs fortran/18833, fortran/20850)
Jakub Jelinek
jakub@redhat.com
Mon Jul 25 21:06:00 GMT 2005
Hi!
As equivalence can come before or after variable declaration (or
e.g. between var declaration and its dimension specification),
match_varspec shouldn't really use any symbol's attributes during parsing.
Whether there is array reference, substring or substring of array reference
is in this patch figured out early in resolve_equivalence.
Tested on x86-linux and ppc64-linux, ok to commit?
2005-07-25 Jakub Jelinek <jakub@redhat.com>
PR fortran/18833
PR fortran/20850
* primary.c (match_varspec): If equiv_flag, don't look at sym's
attributes, call gfc_Match_array_ref up to twice and don't do any
substring or component processing.
* resolve.c (resolve_equivalence): Transform REF_ARRAY into
REF_SUBSTRING or nothing if needed. Check that substrings
don't have zero length.
* gfortran.dg/equiv_1.f90: New test.
* gfortran.dg/equiv_2.f90: New test.
* gfortran.fortran-torture/execute/equiv_2.f90: New test.
* gfortran.fortran-torture/execute/equiv_3.f90: New test.
* gfortran.fortran-torture/execute/equiv_4.f90: New test.
--- gcc/fortran/primary.c.jj 2005-07-14 12:10:34.000000000 +0200
+++ gcc/fortran/primary.c 2005-07-25 21:38:48.000000000 +0200
@@ -1517,28 +1517,42 @@ match_varspec (gfc_expr * primary, int e
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_ref *substring, *tail;
gfc_component *component;
- gfc_symbol *sym;
+ gfc_symbol *sym = primary->symtree->n.sym;
match m;
tail = NULL;
- if (primary->symtree->n.sym->attr.dimension
- || (equiv_flag
- && gfc_peek_char () == '('))
+ if ((equiv_flag && gfc_peek_char () == '(')
+ || sym->attr.dimension)
{
-
+ /* In EQUIVALENCE, we don't know yet whether we are seeing
+ an array, character variable or array of character
+ variables. We'll leave the decision till resolve
+ time. */
tail = extend_ref (primary, tail);
tail->type = REF_ARRAY;
- m = gfc_match_array_ref (&tail->u.ar, primary->symtree->n.sym->as,
- equiv_flag);
+ m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
+ equiv_flag);
if (m != MATCH_YES)
return m;
+
+ if (equiv_flag && gfc_peek_char () == '(')
+ {
+ tail = extend_ref (primary, tail);
+ tail->type = REF_ARRAY;
+
+ m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag);
+ if (m != MATCH_YES)
+ return m;
+ }
}
- sym = primary->symtree->n.sym;
primary->ts = sym->ts;
+ if (equiv_flag)
+ return MATCH_YES;
+
if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
goto check_substring;
--- gcc/fortran/resolve.c.jj 2005-07-02 02:28:32.000000000 +0200
+++ gcc/fortran/resolve.c 2005-07-25 21:38:48.000000000 +0200
@@ -4727,7 +4727,7 @@ resolve_equivalence_derived (gfc_symbol
sequence derived type containing a pointer at any level of component
selection, an automatic object, a function name, an entry name, a result
name, a named constant, a structure component, or a subobject of any of
- the preceding objects. */
+ the preceding objects. A substring shall not have length zero. */
static void
resolve_equivalence (gfc_equiv *eq)
@@ -4740,6 +4740,69 @@ resolve_equivalence (gfc_equiv *eq)
for (; eq; eq = eq->eq)
{
e = eq->expr;
+
+ e->ts = e->symtree->n.sym->ts;
+ /* match_varspec might not know yet if it is seeing
+ array reference or substring reference, as it doesn't
+ know the types. */
+ if (e->ref && e->ref->type == REF_ARRAY)
+ {
+ gfc_ref *ref = e->ref;
+ sym = e->symtree->n.sym;
+
+ if (sym->attr.dimension)
+ {
+ ref->u.ar.as = sym->as;
+ ref = ref->next;
+ }
+
+ /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */
+ if (e->ts.type == BT_CHARACTER
+ && ref
+ && ref->type == REF_ARRAY
+ && ref->u.ar.dimen == 1
+ && ref->u.ar.dimen_type[0] == DIMEN_RANGE
+ && ref->u.ar.stride[0] == NULL)
+ {
+ gfc_expr *start = ref->u.ar.start[0];
+ gfc_expr *end = ref->u.ar.end[0];
+ void *mem = NULL;
+
+ /* Optimize away the (:) reference. */
+ if (start == NULL && end == NULL)
+ {
+ if (e->ref == ref)
+ e->ref = ref->next;
+ else
+ e->ref->next = ref->next;
+ mem = ref;
+ }
+ else
+ {
+ ref->type = REF_SUBSTRING;
+ if (start == NULL)
+ start = gfc_int_expr (1);
+ ref->u.ss.start = start;
+ if (end == NULL && e->ts.cl)
+ end = gfc_copy_expr (e->ts.cl->length);
+ ref->u.ss.end = end;
+ ref->u.ss.length = e->ts.cl;
+ e->ts.cl = NULL;
+ }
+ ref = ref->next;
+ gfc_free (mem);
+ }
+
+ /* Any further ref is an error. */
+ if (ref)
+ {
+ gcc_assert (ref->type == REF_ARRAY);
+ gfc_error ("Syntax error in EQUIVALENCE statement at %L",
+ &ref->u.ar.where);
+ continue;
+ }
+ }
+
if (gfc_resolve_expr (e) == FAILURE)
continue;
@@ -4802,19 +4865,30 @@ resolve_equivalence (gfc_equiv *eq)
continue;
}
- /* Shall not be a structure component. */
r = e->ref;
while (r)
{
- if (r->type == REF_COMPONENT)
- {
- gfc_error ("Structure component '%s' at %L cannot be an "
- "EQUIVALENCE object",
- r->u.c.component->name, &e->where);
- break;
- }
- r = r->next;
- }
+ /* Shall not be a structure component. */
+ if (r->type == REF_COMPONENT)
+ {
+ gfc_error ("Structure component '%s' at %L cannot be an "
+ "EQUIVALENCE object",
+ r->u.c.component->name, &e->where);
+ break;
+ }
+
+ /* A substring shall not have length zero. */
+ if (r->type == REF_SUBSTRING)
+ {
+ if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT)
+ {
+ gfc_error ("Substring at %L has length zero",
+ &r->u.ss.start->where);
+ break;
+ }
+ }
+ r = r->next;
+ }
}
}
--- gcc/testsuite/gfortran.dg/equiv_1.f90.jj 2005-07-20 16:15:36.000000000 +0200
+++ gcc/testsuite/gfortran.dg/equiv_1.f90 2005-07-20 16:25:16.000000000 +0200
@@ -0,0 +1,9 @@
+ program broken_equiv
+ real d (2) ! { dg-error "Inconsistent equivalence rules" "d" }
+ real e ! { dg-error "Inconsistent equivalence rules" "e" }
+ equivalence (d (1), e), (d (2), e)
+
+ real f (2) ! { dg-error "Inconsistent equivalence rules" "f" }
+ double precision g (2) ! { dg-error "Inconsistent equivalence rules" "g" }
+ equivalence (f (1), g (1)), (f (2), g (2)) ! Not standard conforming
+ end
--- gcc/testsuite/gfortran.dg/equiv_2.f90.jj 2005-07-20 16:15:33.000000000 +0200
+++ gcc/testsuite/gfortran.dg/equiv_2.f90 2005-07-25 21:45:10.000000000 +0200
@@ -0,0 +1,17 @@
+ subroutine broken_equiv1
+ character*4 h
+ character*3 i
+ equivalence (h(1:3), i(2:1)) ! { dg-error "has length zero" }
+ end subroutine
+
+ subroutine broken_equiv2
+ character*4 j
+ character*2 k
+ equivalence (j(2:3), k(1:5)) ! { dg-error "out of bounds" }
+ end subroutine
+
+ subroutine broken_equiv3
+ character*4 l
+ character*2 m
+ equivalence (l(2:3:4), m(1:2)) ! { dg-error "\[Ss\]yntax error" }
+ end subroutine
--- gcc/testsuite/gfortran.fortran-torture/execute/equiv_2.f90.jj 2005-07-20 15:31:29.000000000 +0200
+++ gcc/testsuite/gfortran.fortran-torture/execute/equiv_2.f90 2005-07-25 15:12:14.000000000 +0200
@@ -0,0 +1,46 @@
+ subroutine test1
+ character*8 c
+ character*1 d, f
+ dimension d(2), f(2)
+ character*4 e
+ equivalence (c(1:1), d(1)), (c(3:5), e(2:4)), (c(6:6), f(2))
+ c='abcdefgh'
+ if (c.ne.'abcdefgh'.or.d(1).ne.'a'.or.d(2).ne.'b') call abort
+ if (e.ne.'bcde'.or.f(1).ne.'e'.or.f(2).ne.'f') call abort
+ end subroutine test1
+ subroutine test2
+ equivalence (c(1:1), d(1)), (c(3:5), e(2:4)), (c(6:6), f(2))
+ character*8 c
+ character*1 d, f
+ dimension d(2), f(2)
+ character*4 e
+ c='abcdefgh'
+ if (c.ne.'abcdefgh'.or.d(1).ne.'a'.or.d(2).ne.'b') call abort
+ if (e.ne.'bcde'.or.f(1).ne.'e'.or.f(2).ne.'f') call abort
+ end subroutine test2
+ subroutine test3
+ character*8 c
+ character*1 d, f
+ character*4 e
+ equivalence (c(1:1), d(1)), (c(3:5), e(2:4)), (c(6:6), f(2))
+ dimension d(2), f(2)
+ c='abcdefgh'
+ if (c.ne.'abcdefgh'.or.d(1).ne.'a'.or.d(2).ne.'b') call abort
+ if (e.ne.'bcde'.or.f(1).ne.'e'.or.f(2).ne.'f') call abort
+ end subroutine test3
+ subroutine test4
+ dimension d(2), f(2)
+ equivalence (c(1:1), d(1)), (c(3:5), e(2:4)), (c(6:6), f(2))
+ character*8 c
+ character*1 d, f
+ character*4 e
+ c='abcdefgh'
+ if (c.ne.'abcdefgh'.or.d(1).ne.'a'.or.d(2).ne.'b') call abort
+ if (e.ne.'bcde'.or.f(1).ne.'e'.or.f(2).ne.'f') call abort
+ end subroutine test4
+ program main
+ call test1
+ call test2
+ call test3
+ call test4
+ end program main
--- gcc/testsuite/gfortran.fortran-torture/execute/equiv_3.f90.jj 2005-07-25 15:11:40.000000000 +0200
+++ gcc/testsuite/gfortran.fortran-torture/execute/equiv_3.f90 2005-07-25 15:11:58.000000000 +0200
@@ -0,0 +1,13 @@
+ subroutine test1
+ type t
+ sequence
+ character(8) c
+ end type t
+ type(t) :: tc, td
+ equivalence (tc, td)
+ tc%c='abcdefgh'
+ if (tc%c.ne.'abcdefgh'.or.td%c(1:1).ne.'a') call abort
+ end subroutine test1
+ program main
+ call test1
+ end program main
--- gcc/testsuite/gfortran.fortran-torture/execute/equiv_4.f90.jj 2005-07-25 16:38:21.000000000 +0200
+++ gcc/testsuite/gfortran.fortran-torture/execute/equiv_4.f90 2005-07-25 17:21:50.000000000 +0200
@@ -0,0 +1,54 @@
+ subroutine test1
+ character*8 c
+ character*2 d, f
+ dimension d(2), f(2)
+ character*4 e
+ equivalence (c(1:1), d(1)(2:)), (c(3:5), e(2:4))
+ equivalence (c(6:6), f(2)(:))
+ d(1)='AB'
+ c='abcdefgh'
+ if (c.ne.'abcdefgh'.or.d(1).ne.'Aa'.or.d(2).ne.'bc') call abort
+ if (e.ne.'bcde'.or.f(1).ne.'de'.or.f(2).ne.'fg') call abort
+ end subroutine test1
+ subroutine test2
+ equivalence (c(1:1), d(1)(2:2)), (c(3:5), e(2:4))
+ equivalence (c(6:6), f(2)(1:))
+ character*8 c
+ character*2 d, f
+ dimension d(2), f(2)
+ character*4 e
+ d(1)='AB'
+ c='abcdefgh'
+ if (c.ne.'abcdefgh'.or.d(1).ne.'Aa'.or.d(2).ne.'bc') call abort
+ if (e.ne.'bcde'.or.f(1).ne.'de'.or.f(2).ne.'fg') call abort
+ end subroutine test2
+ subroutine test3
+ character*8 c
+ character*2 d, f
+ character*4 e
+ equivalence (c(1:1), d(1)(2:)), (c(3:5), e(2:4))
+ equivalence (c(6:6), f(2)(:1))
+ dimension d(2), f(2)
+ d(1)='AB'
+ c='abcdefgh'
+ if (c.ne.'abcdefgh'.or.d(1).ne.'Aa'.or.d(2).ne.'bc') call abort
+ if (e.ne.'bcde'.or.f(1).ne.'de'.or.f(2).ne.'fg') call abort
+ end subroutine test3
+ subroutine test4
+ dimension d(2), f(2)
+ equivalence (c(1:1), d(1)(2:2)), (c(3:5), e(2:4))
+ equivalence (c(6:6), f(2)(1:2))
+ character*8 c
+ character*2 d, f
+ character*4 e
+ d(1)='AB'
+ c='abcdefgh'
+ if (c.ne.'abcdefgh'.or.d(1).ne.'Aa'.or.d(2).ne.'bc') call abort
+ if (e.ne.'bcde'.or.f(1).ne.'de'.or.f(2).ne.'fg') call abort
+ end subroutine test4
+ program main
+ call test1
+ call test2
+ call test3
+ call test4
+ end program main
Jakub
More information about the Gcc-patches
mailing list