+2005-08-06 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.
+
2005-08-05 Thomas Koenig <Thomas.Koenig@online.de>
* trans-expr.c (gfc_build_builtin_function_decls): Mark
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;
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)
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;
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;
+ }
}
}
+2005-08-06 Jakub Jelinek <jakub@redhat.com>
+
+ PR fortran/18833
+ PR fortran/20850
+ * 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.
+
2005-08-05 James A. Morrison <phython@gcc.gnu.org>
* gcc.c-torture/execute/vrp-5.c: New test.
--- /dev/null
+ 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
--- /dev/null
+ 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
--- /dev/null
+ 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
--- /dev/null
+ 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
--- /dev/null
+ 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
projects / gcc.git / commitdiff