From 8234e5e0e205db40a4b09067a875a50f111d6ef6 Mon Sep 17 00:00:00 2001 From: "Steven G. Kargl" Date: Sun, 23 Aug 2009 03:19:55 +0000 Subject: [PATCH] allocate_alloc_opt_4.f90: New test. 2009-08-22 Steven K. kargl * gfortran.dg/allocate_alloc_opt_4.f90: New test. * gfortran.dg/allocate_alloc_opt_5.f90: New test. * gfortran.dg/allocate_alloc_opt_6.f90: New test. 2009-08-22 Steven K. kargl * fortran/decl.c (match_char_spec): Rename to gfc_match_char_spec, and remove static. * fortran/gfortran.h: Add *expr3 entity to gfc_code. Add prototype for gfc_match_char_spec. * fortran/trans-stmt.c (gfc_trans_allocate): Translate the SOURCE= tag. * fortran/match.c (match_intrinsic_typespec): New function to match F2003 intrinsic-type-spec. (conformable_arrays): New function. Check SOURCE= and allocation-object are conformable. (gfc_match_allocate): Use new functions. Match SOURCE= tag. From-SVN: r151023 --- gcc/fortran/ChangeLog | 14 + gcc/fortran/decl.c | 9 +- gcc/fortran/gfortran.h | 3 +- gcc/fortran/match.c | 281 ++++++++++++++++++++- gcc/fortran/trans-stmt.c | 38 +++ gcc/testsuite/ChangeLog | 7 + gcc/testsuite/gfortran.dg/allocate_alloc_opt_4.f90 | 27 ++ gcc/testsuite/gfortran.dg/allocate_alloc_opt_5.f90 | 15 ++ gcc/testsuite/gfortran.dg/allocate_alloc_opt_6.f90 | 42 +++ 9 files changed, 418 insertions(+), 18 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/allocate_alloc_opt_4.f90 create mode 100644 gcc/testsuite/gfortran.dg/allocate_alloc_opt_5.f90 create mode 100644 gcc/testsuite/gfortran.dg/allocate_alloc_opt_6.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 635e68c..4869fe8 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,17 @@ +2009-08-22 Steven K. kargl + + * fortran/decl.c (match_char_spec): Rename to gfc_match_char_spec, + and remove static. + * fortran/gfortran.h: Add *expr3 entity to gfc_code. Add prototype + for gfc_match_char_spec. + * fortran/trans-stmt.c (gfc_trans_allocate): Translate the SOURCE= + tag. + * fortran/match.c (match_intrinsic_typespec): New function to match + F2003 intrinsic-type-spec. + (conformable_arrays): New function. Check SOURCE= and + allocation-object are conformable. + (gfc_match_allocate): Use new functions. Match SOURCE= tag. + 2009-08-22 Bud Davis PR fortran/28093 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index e4813b8..1533af5 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -2104,11 +2104,12 @@ no_match: return m; } + /* Match the various kind/length specifications in a CHARACTER declaration. We don't return MATCH_NO. */ -static match -match_char_spec (gfc_typespec *ts) +match +gfc_match_char_spec (gfc_typespec *ts) { int kind, seen_length, is_iso_c; gfc_charlen *cl; @@ -2324,7 +2325,7 @@ gfc_match_type_spec (gfc_typespec *ts, int implicit_flag) { ts->type = BT_CHARACTER; if (implicit_flag == 0) - return match_char_spec (ts); + return gfc_match_char_spec (ts); else return MATCH_YES; } @@ -2636,7 +2637,7 @@ gfc_match_implicit (void) /* Last chance -- check (). */ if (ts.type == BT_CHARACTER) - m = match_char_spec (&ts); + m = gfc_match_char_spec (&ts); else { m = gfc_match_kind_spec (&ts, false); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index a4a3b81..cbab000 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1977,7 +1977,7 @@ typedef struct gfc_code gfc_st_label *here, *label1, *label2, *label3; gfc_symtree *symtree; - gfc_expr *expr1, *expr2; + gfc_expr *expr1, *expr2, *expr3; /* A name isn't sufficient to identify a subroutine, we need the actual symbol for the interface definition. const char *sub_name; */ @@ -2184,6 +2184,7 @@ gfc_finalizer; /* decl.c */ bool gfc_in_match_data (void); +match gfc_match_char_spec (gfc_typespec *); /* scanner.c */ void gfc_scanner_done_1 (void); diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 3c6ef49..9ba3e09 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -2221,23 +2221,186 @@ gfc_free_alloc_list (gfc_alloc *p) } +/* Match a Fortran 2003 intrinsic-type-spec. This is a stripped + down version of gfc_match_type_spec() from decl.c. It only includes + the intrinsic types from the Fortran 2003 standard. Thus, neither + BYTE nor forms like REAL*4 are allowed. Additionally, the implicit_flag + is not needed, so it was removed. The handling of derived types has + been removed and no notion of the gfc_matching_function state + is needed. In short, this functions matches only standard conforming + intrinsic-type-spec (R403). */ + +static match +match_intrinsic_typespec (gfc_typespec *ts) +{ + match m; + + gfc_clear_ts (ts); + + if (gfc_match ("integer") == MATCH_YES) + { + ts->type = BT_INTEGER; + ts->kind = gfc_default_integer_kind; + goto kind_selector; + } + + if (gfc_match ("real") == MATCH_YES) + { + ts->type = BT_REAL; + ts->kind = gfc_default_real_kind; + goto kind_selector; + } + + if (gfc_match ("double precision") == MATCH_YES) + { + ts->type = BT_REAL; + ts->kind = gfc_default_double_kind; + return MATCH_YES; + } + + if (gfc_match ("complex") == MATCH_YES) + { + ts->type = BT_COMPLEX; + ts->kind = gfc_default_complex_kind; + goto kind_selector; + } + + if (gfc_match ("character") == MATCH_YES) + { + ts->type = BT_CHARACTER; + goto char_selector; + } + + if (gfc_match ("logical") == MATCH_YES) + { + ts->type = BT_LOGICAL; + ts->kind = gfc_default_logical_kind; + goto kind_selector; + } + + /* If an intrinsic type is not matched, simply return MATCH_NO. */ + return MATCH_NO; + +kind_selector: + + gfc_gobble_whitespace (); + if (gfc_peek_ascii_char () == '*') + { + gfc_error ("Invalid type-spec at %C"); + return MATCH_ERROR; + } + + m = gfc_match_kind_spec (ts, false); + + if (m == MATCH_NO) + m = MATCH_YES; /* No kind specifier found. */ + + return m; + +char_selector: + + m = gfc_match_char_spec (ts); + + if (m == MATCH_NO) + m = MATCH_YES; /* No kind specifier found. */ + + return m; +} + + +/* Used in gfc_match_allocate to check that a allocation-object and + a source-expr are conformable. This does not catch all possible + cases; in particular a runtime checking is needed. */ + +static gfc_try +conformable_arrays (gfc_expr *e1, gfc_expr *e2) +{ + /* First compare rank. */ + if (e2->ref && e1->rank != e2->ref->u.ar.as->rank) + { + gfc_error ("Source-expr at %L must be scalar or have the " + "same rank as the allocate-object at %L", + &e1->where, &e2->where); + return FAILURE; + } + + if (e1->shape) + { + int i; + mpz_t s; + + mpz_init (s); + + for (i = 0; i < e1->rank; i++) + { + if (e2->ref->u.ar.end[i]) + { + mpz_set (s, e2->ref->u.ar.end[i]->value.integer); + mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer); + mpz_add_ui (s, s, 1); + } + else + { + mpz_set (s, e2->ref->u.ar.start[i]->value.integer); + } + + if (mpz_cmp (e1->shape[i], s) != 0) + { + gfc_error ("Source-expr at %L and allocate-object at %L must " + "have the same shape", &e1->where, &e2->where); + mpz_clear (s); + return FAILURE; + } + } + + mpz_clear (s); + } + + return SUCCESS; +} + + /* Match an ALLOCATE statement. */ match gfc_match_allocate (void) { gfc_alloc *head, *tail; - gfc_expr *stat, *errmsg, *tmp; + gfc_expr *stat, *errmsg, *tmp, *source; + gfc_typespec ts; match m; - bool saw_stat, saw_errmsg; + locus old_locus; + bool saw_stat, saw_errmsg, saw_source, b1, b2, b3; head = tail = NULL; - stat = errmsg = tmp = NULL; - saw_stat = saw_errmsg = false; + stat = errmsg = source = tmp = NULL; + saw_stat = saw_errmsg = saw_source = false; if (gfc_match_char ('(') != MATCH_YES) goto syntax; + /* Match an optional intrinsic-type-spec. */ + old_locus = gfc_current_locus; + m = match_intrinsic_typespec (&ts); + if (m == MATCH_ERROR) + goto cleanup; + else if (m == MATCH_NO) + ts.type = BT_UNKNOWN; + else + { + if (gfc_match (" :: ") == MATCH_YES) + { + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: typespec in " + "ALLOCATE at %L", &old_locus) == FAILURE) + goto cleanup; + } + else + { + ts.type = BT_UNKNOWN; + gfc_current_locus = old_locus; + } + } + for (;;) { if (head == NULL) @@ -2263,17 +2426,46 @@ gfc_match_allocate (void) goto cleanup; } + /* The ALLOCATE statement had an optional typespec. Check the + constraints. */ + if (ts.type != BT_UNKNOWN) + { + /* Enforce C626. */ + if (ts.type != tail->expr->ts.type) + { + gfc_error ("Type of entity at %L is type incompatible with " + "typespec", &tail->expr->where); + goto cleanup; + } + + /* Enforce C627. */ + if (ts.kind != tail->expr->ts.kind) + { + gfc_error ("Kind type parameter for entity at %L differs from " + "the kind type parameter of the typespec", + &tail->expr->where); + goto cleanup; + } + } + if (tail->expr->ts.type == BT_DERIVED) tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived); /* FIXME: disable the checking on derived types and arrays. */ - if (!(tail->expr->ref + b1 = !(tail->expr->ref && (tail->expr->ref->type == REF_COMPONENT - || tail->expr->ref->type == REF_ARRAY)) - && tail->expr->symtree->n.sym - && !(tail->expr->symtree->n.sym->attr.allocatable - || tail->expr->symtree->n.sym->attr.pointer - || tail->expr->symtree->n.sym->attr.proc_pointer)) + || tail->expr->ref->type == REF_ARRAY)); + b2 = tail->expr->symtree->n.sym + && !(tail->expr->symtree->n.sym->attr.allocatable + || tail->expr->symtree->n.sym->attr.pointer + || tail->expr->symtree->n.sym->attr.proc_pointer); + b3 = tail->expr->symtree->n.sym + && tail->expr->symtree->n.sym->ns + && tail->expr->symtree->n.sym->ns->proc_name + && (tail->expr->symtree->n.sym->ns->proc_name->attr.allocatable + || tail->expr->symtree->n.sym->ns->proc_name->attr.pointer + || tail->expr->symtree->n.sym->ns->proc_name->attr.proc_pointer); + if (b1 && b2 && !b3) { gfc_error ("Allocate-object at %C is not a nonprocedure pointer " "or an allocatable variable"); @@ -2290,10 +2482,10 @@ alloc_opt_list: goto cleanup; if (m == MATCH_YES) { + /* Enforce C630. */ if (saw_stat) { gfc_error ("Redundant STAT tag found at %L ", &tmp->where); - gfc_free_expr (tmp); goto cleanup; } @@ -2312,14 +2504,14 @@ alloc_opt_list: goto cleanup; if (m == MATCH_YES) { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L", + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG tag at %L", &tmp->where) == FAILURE) goto cleanup; + /* Enforce C630. */ if (saw_errmsg) { gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where); - gfc_free_expr (tmp); goto cleanup; } @@ -2330,6 +2522,66 @@ alloc_opt_list: goto alloc_opt_list; } + m = gfc_match (" source = %e", &tmp); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_YES) + { + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SOURCE tag at %L", + &tmp->where) == FAILURE) + goto cleanup; + + /* Enforce C630. */ + if (saw_source) + { + gfc_error ("Redundant SOURCE tag found at %L ", &tmp->where); + goto cleanup; + } + + /* The next 3 conditionals check C631. */ + if (ts.type != BT_UNKNOWN) + { + gfc_error ("SOURCE tag at %L conflicts with the typespec at %L", + &tmp->where, &old_locus); + goto cleanup; + } + + if (head->next) + { + gfc_error ("SOURCE tag at %L requires only a single entity in " + "the allocation-list", &tmp->where); + goto cleanup; + } + + gfc_resolve_expr (tmp); + + if (head->expr->ts.type != tmp->ts.type) + { + gfc_error ("Type of entity at %L is type incompatible with " + "source-expr at %L", &head->expr->where, &tmp->where); + goto cleanup; + } + + /* Check C633. */ + if (tmp->ts.kind != head->expr->ts.kind) + { + gfc_error ("The allocate-object at %L and the source-expr at %L " + "shall have the same kind type parameter", + &head->expr->where, &tmp->where); + goto cleanup; + } + + /* Check C632 and restriction following Note 6.18. */ + if (tmp->rank > 0 && conformable_arrays (tmp, head->expr) == FAILURE) + goto cleanup; + + source = tmp; + saw_source = true; + + if (gfc_match_char (',') == MATCH_YES) + goto alloc_opt_list; + } + gfc_gobble_whitespace (); if (gfc_peek_char () == ')') @@ -2343,6 +2595,7 @@ alloc_opt_list: new_st.op = EXEC_ALLOCATE; new_st.expr1 = stat; new_st.expr2 = errmsg; + new_st.expr3 = source; new_st.ext.alloc_list = head; return MATCH_YES; @@ -2352,7 +2605,9 @@ syntax: cleanup: gfc_free_expr (errmsg); + gfc_free_expr (source); gfc_free_expr (stat); + gfc_free_expr (tmp); gfc_free_alloc_list (head); return MATCH_ERROR; } diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 1ae841f..6aed99b 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -4081,6 +4081,44 @@ gfc_trans_allocate (gfc_code * code) gfc_add_expr_to_block (&block, tmp); } + /* SOURCE block. Note, by C631, we know that code->ext.alloc_list + has a single entity. */ + if (code->expr3) + { + gfc_ref *ref; + gfc_array_ref *ar; + int n; + + /* If there is a terminating array reference, this is converted + to a full array, so that gfc_trans_assignment can scalarize the + expression for the source. */ + for (ref = code->ext.alloc_list->expr->ref; ref; ref = ref->next) + { + if (ref->next == NULL) + { + if (ref->type != REF_ARRAY) + break; + + ref->u.ar.type = AR_FULL; + ar = &ref->u.ar; + ar->dimen = ar->as->rank; + for (n = 0; n < ar->dimen; n++) + { + ar->dimen_type[n] = DIMEN_RANGE; + gfc_free_expr (ar->start[n]); + gfc_free_expr (ar->end[n]); + gfc_free_expr (ar->stride[n]); + ar->start[n] = NULL; + ar->end[n] = NULL; + ar->stride[n] = NULL; + } + } + } + + tmp = gfc_trans_assignment (code->ext.alloc_list->expr, code->expr3, false); + gfc_add_expr_to_block (&block, tmp); + } + return gfc_finish_block (&block); } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 8e60e36..2c8997d 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,7 +1,14 @@ +2009-08-22 Steven K. kargl + + * gfortran.dg/allocate_alloc_opt_4.f90: New test. + * gfortran.dg/allocate_alloc_opt_5.f90: New test. + * gfortran.dg/allocate_alloc_opt_6.f90: New test. + 2009-08-22 Bud Davis PR fortran/28039 * gfortran.dg/fmt_with_extra.f: new file. + 2009-08-21 Maciej W. Rozycki * lib/target-supports.exp diff --git a/gcc/testsuite/gfortran.dg/allocate_alloc_opt_4.f90 b/gcc/testsuite/gfortran.dg/allocate_alloc_opt_4.f90 new file mode 100644 index 0000000..89052ef --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_alloc_opt_4.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +program a + + implicit none + + integer n, m(3,3) + integer(kind=8) k + integer, allocatable :: i(:), j(:) + real, allocatable :: x(:) + + n = 42 + m = n + k = 1_8 + + allocate(i(4), source=42, source=n) ! { dg-error "Redundant SOURCE tag found" } + + allocate(integer(4) :: i(4), source=n) ! { dg-error "conflicts with the typespec" } + + allocate(i(4), j(n), source=n) ! { dg-error "requires only a single entity" } + + allocate(x(4), source=n) ! { dg-error "type incompatible with" } + + allocate(i(4), source=m) ! { dg-error "must be scalar or have the same rank" } + + allocate(i(4), source=k) ! { dg-error "shall have the same kind type" } + +end program a diff --git a/gcc/testsuite/gfortran.dg/allocate_alloc_opt_5.f90 b/gcc/testsuite/gfortran.dg/allocate_alloc_opt_5.f90 new file mode 100644 index 0000000..d7e3ea9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_alloc_opt_5.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +program a + + implicit none + + integer n + character(len=70) str + integer, allocatable :: i(:) + + n = 42 + allocate(i(4), source=n) ! { dg-error "Fortran 2003: SOURCE tag" } + allocate(i(4), stat=n, errmsg=str) ! { dg-error "Fortran 2003: ERRMSG tag" } + +end program a diff --git a/gcc/testsuite/gfortran.dg/allocate_alloc_opt_6.f90 b/gcc/testsuite/gfortran.dg/allocate_alloc_opt_6.f90 new file mode 100644 index 0000000..d470b42 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_alloc_opt_6.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +program a + + implicit none + + type :: mytype + real :: r + integer :: i + end type mytype + + integer n + integer, allocatable :: i(:) + real z + real, allocatable :: x(:) + type(mytype), pointer :: t + + n = 42 + z = 99. + + allocate(i(4), source=n) + if (any(i /= 42)) call abort + + allocate(x(4), source=z) + if (any(x /= 99.)) call abort + + allocate(t, source=mytype(1.0,2)) + if (t%r /= 1. .or. t%i /= 2) call abort + + deallocate(i) + allocate(i(3), source=(/1, 2, 3/)) + if (i(1) /= 1 .or. i(2) /= 2 .or. i(3) /= 3) call abort + + call sub1(i) + +end program a + +subroutine sub1(j) + integer, intent(in) :: j(*) + integer, allocatable :: k(:) + allocate(k(2), source=j(1:2)) + if (k(1) /= 1 .or. k(2) /= 2) call abort +end subroutine sub1 -- 2.7.4