This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.
Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
---|---|---|
Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |
Other format: | [Raw text] |
All, First, a big 'thank you' to pault for the trans-stmt.c portion of the patch. I was stuck on translation to trees for a long time; something about a forest and too many trees. The attached patch implements the SOURCE= tag in an ALLOCATE statement. The three testcases show simple uses of this tag. The patch also includes the parsing/matching of an optional intrinsic-type-spec. This patch does not include parsing/matching of a derived-type-spec, which will be the subject of a follow-up patch and is most likely required by Janus's CLASS() work. To succeed with the intrinsic-type-spec matching, I introduced a new function to match only F2003 intrinsic-types-specs, which is a stripped down version of gfc_match_type_spec(). gfc_match_type_spec() has grown too many special cases and it's use in gfc_match_allocation() led to 2 regression that I simply could not fix. Note, when I say F2003 intrinsic-type-spec, this means neither BYTE nor REAL*4-like types are matched. Given that this is a F2003 feature, there is no need for backwards compatibility. If someone is stupid and does ALLOCATE(REAL*4 :: x(4)), they should be beaten severely; unfortunately, gfortran only issues an error. Regression tested on i686-*-freebsd. OK for trunk? 2009-08-16 Steven G. Kargl <kargl@gcc.gnu.org> * gfortran.dg/allocate_alloc_opt_6.f90: New test. * gfortran.dg/allocate_alloc_opt_5.f90: Ditto. * gfortran.dg/allocate_alloc_opt_4.f90: Ditto. 2009-08-16 Steven G. Kargl <kargl@gcc.gnu.org> Paul Thomas <pault@gcc.gnu.org> * fortran/decl.c (match_char_spec): Rename function to gfc_match_char_spec and remove static qualifier. (gfc_match_type_spec, gfc_match_implicit): Update for name change. * fortran/gfortran.h (gfc_code): Add *expr3 struct member. Add prototype for gfc_match_char_spec(). *gcc/fortran/trans-stmt.c (gfc_trans_allocate): Translate the SOURCE= tag. * fortran/match.c (match_intrinsic_typespec): New function to match a F2003 intrinsic-type-spec. (conformable_arrays): New function to check conformability of allocation-object and source-expr. (gfc_match_allocate): Add parsing/matching of SOURCE= tag. Add checking for constraints. Add parsing/matching of an optional F2003 intrinsic-type-spec. Cleanup tmp gfc_expr on failures. -- Steve
Index: gcc/testsuite/gfortran.dg/allocate_alloc_opt_6.f90 =================================================================== --- gcc/testsuite/gfortran.dg/allocate_alloc_opt_6.f90 (revision 0) +++ gcc/testsuite/gfortran.dg/allocate_alloc_opt_6.f90 (revision 0) @@ -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 Index: gcc/testsuite/gfortran.dg/allocate_alloc_opt_5.f90 =================================================================== --- gcc/testsuite/gfortran.dg/allocate_alloc_opt_5.f90 (revision 0) +++ gcc/testsuite/gfortran.dg/allocate_alloc_opt_5.f90 (revision 0) @@ -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 Index: gcc/testsuite/gfortran.dg/allocate_alloc_opt_4.f90 =================================================================== --- gcc/testsuite/gfortran.dg/allocate_alloc_opt_4.f90 (revision 0) +++ gcc/testsuite/gfortran.dg/allocate_alloc_opt_4.f90 (revision 0) @@ -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 Index: gcc/fortran/decl.c =================================================================== --- gcc/fortran/decl.c (revision 150724) +++ gcc/fortran/decl.c (working copy) @@ -2103,11 +2103,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; @@ -2323,7 +2324,7 @@ gfc_match_type_spec (gfc_typespec *ts, i { ts->type = BT_CHARACTER; if (implicit_flag == 0) - return match_char_spec (ts); + return gfc_match_char_spec (ts); else return MATCH_YES; } @@ -2635,7 +2636,7 @@ gfc_match_implicit (void) /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */ if (ts.type == BT_CHARACTER) - m = match_char_spec (&ts); + m = gfc_match_char_spec (&ts); else { m = gfc_match_kind_spec (&ts, false); Index: gcc/fortran/gfortran.h =================================================================== --- gcc/fortran/gfortran.h (revision 150724) +++ gcc/fortran/gfortran.h (working copy) @@ -1971,7 +1971,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; */ @@ -2178,6 +2178,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); Index: gcc/fortran/trans-stmt.c =================================================================== --- gcc/fortran/trans-stmt.c (revision 150724) +++ gcc/fortran/trans-stmt.c (working copy) @@ -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); } Index: gcc/fortran/match.c =================================================================== --- gcc/fortran/match.c (revision 150724) +++ gcc/fortran/match.c (working copy) @@ -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.derived = gfc_use_derived (tail->expr->ts.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; }
Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
---|---|---|
Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |