From patchwork Sat Jun 19 22:00:52 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 56250 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 7972F1007D1 for ; Sun, 20 Jun 2010 08:01:24 +1000 (EST) Received: (qmail 9217 invoked by alias); 19 Jun 2010 22:01:20 -0000 Received: (qmail 8003 invoked by uid 22791); 19 Jun 2010 22:01:10 -0000 X-SWARE-Spam-Status: No, hits=-1.9 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE, TW_GP X-Spam-Check-By: sourceware.org Received: from mx02.qsc.de (HELO mx02.qsc.de) (213.148.130.14) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Sat, 19 Jun 2010 22:00:57 +0000 Received: from [192.168.178.22] (port-92-204-85-235.dynamic.qsc.de [92.204.85.235]) by mx02.qsc.de (Postfix) with ESMTP id 299531E561; Sun, 20 Jun 2010 00:00:52 +0200 (CEST) Message-ID: <4C1D3E14.1080704@net-b.de> Date: Sun, 20 Jun 2010 00:00:52 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; U; Linux x86_64; de; rv:1.9.1.9) Gecko/20100317 SUSE/3.0.4 Thunderbird/3.0.4 MIME-Version: 1.0 To: Mikael Morin CC: gcc patches , gfortran Subject: Re: [Patch,Fortran] PR 40632 - Add CONTIGUOUS attribute (part 1) References: <4C1B9B1D.3020902@net-b.de> <4C1BF9BE.3010209@net-b.de> <4C1C757D.8030509@sfr.fr> In-Reply-To: <4C1C757D.8030509@sfr.fr> Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Dear all, hi Mikael, here comes an updated patch. On 19.06.2010 09:45, Mikael Morin wrote: > The error message is a bit cryptic to me. Since there were no better suggestion, I kept it. Hopefully, no one will run into this message. >> + for (ref = expr->ref; ref; ref = ref->next) >> + { >> + if (ref->type == REF_COMPONENT) >> + part_ref = ref; >> + else if (ref->type == REF_SUBSTRING) >> + return false; >> + else >> + { >> + if (ar) >> + return false; /* Array shall be last part-ref. */ > I think this should be outside the else block. For array(:)%component > cases. I have moved it before REF_COMPONENT. >> + gcc_assert (ar->type != AR_UNKNOWN); > You can even assert that ar->type == AR_SECTION. Done. > I think you are not rejecting the case array(:,1,:) Fixed - and added a test case. Additional fixes in trans-array.c's gfc_conv_array_parameter: * I now use gfc_is_simply_contiguous for no_pack, which is shorter and more correct * I had completely forgotten about passing "array(::2)" to " ..., contiguous :: dummy(:)". The standard says (slightly hidden) that this is valid and that a copy-in/copy-out can happen if the variable is not simply contiguous (cf. 12.5.2.13 and 12.3.3 [paragraph 9 and 10]). Well, that's what the patch now does: It (un)packs the array if needed. (+ test case added) Build and regtested on x86-64-linux. OK for the trunk? Tobias PS: I think one can clean up a bit the contiguity checks in gfc_conv_array_parameter as gfc_is_simply_contiguous covers a lot - though it does not cover all items. 2010-06-20 Tobias Burnus PR fortran/40632 * interface.c (compare_parameter): Add gfc_is_simply_contiguous checks. * symbol.c (gfc_add_contiguous): New function. (gfc_copy_attr, check_conflict): Handle contiguous attribute. * decl.c (match_attr_spec): Ditto. (gfc_match_contiguous): New function. * resolve.c (resolve_fl_derived, resolve_symbol): Handle contiguous. * gfortran.h (symbol_attribute): Add contiguous. (gfc_is_simply_contiguous): Add prototype. (gfc_add_contiguous): Add prototype. * match.h (gfc_match_contiguous): Add prototype. * parse.c (decode_specification_statement, decode_statement): Handle contiguous attribute. * expr.c (gfc_is_simply_contiguous): New function. * dump-parse-tree.c (show_attr): Handle contiguous. * module.c (ab_attribute, attr_bits, mio_symbol_attribute): Ditto. * trans-expr.c (gfc_add_interface_mapping): Copy attr.contiguous. * trans-array.c (gfc_conv_descriptor_stride_get, gfc_conv_array_parameter): Handle contiguous arrays. * trans-types.c (gfc_build_array_type, gfc_build_array_type, gfc_sym_type, gfc_get_derived_type, gfc_get_array_descr_info): Ditto. * trans.h (gfc_array_kind): Ditto. * trans-decl.c (gfc_get_symbol_decl): Ditto. 2010-06-20 Tobias Burnus PR fortran/40632 * gfortran.dg/contiguous_1.f90: New. * gfortran.dg/contiguous_2.f90: New. * gfortran.dg/contiguous_3.f90: New. Index: gcc/fortran/interface.c =================================================================== --- gcc/fortran/interface.c (Revision 161033) +++ gcc/fortran/interface.c (Arbeitskopie) @@ -1435,6 +1435,16 @@ return 1; } + /* F2008, C1241. */ + if (formal->attr.pointer && formal->attr.contiguous + && !gfc_is_simply_contiguous (actual, true)) + { + if (where) + gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L " + "must be simply contigous", formal->name, &actual->where); + return 0; + } + if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN) && !gfc_compare_types (&formal->ts, &actual->ts)) { @@ -1502,6 +1512,34 @@ : actual->symtree->n.sym->as->corank); return 0; } + + /* F2008, 12.5.2.8. */ + if (formal->attr.dimension + && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE) + && !gfc_is_simply_contiguous (actual, true)) + { + if (where) + gfc_error ("Actual argument to '%s' at %L must be simply " + "contiguous", formal->name, &actual->where); + return 0; + } + } + + /* F2008, C1239/C1240. */ + if (actual->expr_type == EXPR_VARIABLE + && (actual->symtree->n.sym->attr.asynchronous + || actual->symtree->n.sym->attr.volatile_) + && (formal->attr.asynchronous || formal->attr.volatile_) + && actual->rank && !gfc_is_simply_contiguous (actual, true) + && ((formal->as->type != AS_ASSUMED_SHAPE && !formal->attr.pointer) + || formal->attr.contiguous)) + { + if (where) + gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape " + "array without CONTIGUOUS attribute as actual argument at " + "%L is not not simply contiguous and both are ASYNCHRONOUS " + "or VOLATILE", formal->name, &actual->where); + return 0; } if (symbol_rank (formal) == actual->rank) Index: gcc/fortran/trans-array.c =================================================================== --- gcc/fortran/trans-array.c (Revision 161033) +++ gcc/fortran/trans-array.c (Arbeitskopie) @@ -285,7 +285,9 @@ tree type = TREE_TYPE (desc); gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); if (integer_zerop (dim) - && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE) + && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE + ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT + ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)) return gfc_index_one_node; return gfc_conv_descriptor_stride (desc, dim); @@ -5522,6 +5524,7 @@ ultimate_ptr_comp = false; ultimate_alloc_comp = false; + for (ref = expr->ref; ref; ref = ref->next) { if (ref->next == NULL) @@ -5608,7 +5611,8 @@ contiguous = g77 && !this_array_result && contiguous; /* There is no need to pack and unpack the array, if it is contiguous - and not deferred or assumed shape. */ + and not a deferred- or assumed-shape array, or if it is simply + contiguous. */ no_pack = ((sym && sym->as && !sym->attr.pointer && sym->as->type != AS_DEFERRED @@ -5616,7 +5620,9 @@ || (ref && ref->u.ar.as && ref->u.ar.as->type != AS_DEFERRED - && ref->u.ar.as->type != AS_ASSUMED_SHAPE)); + && ref->u.ar.as->type != AS_ASSUMED_SHAPE) + || + gfc_is_simply_contiguous (expr, false)); no_pack = contiguous && no_pack; @@ -5680,9 +5686,24 @@ gfc_add_expr_to_block (&se->post, tmp); } - if (g77) + if (g77 || (fsym && fsym->attr.contiguous + && !gfc_is_simply_contiguous (expr, false))) { + tree origptr = NULL_TREE; + desc = se->expr; + + /* For contiguous arrays, save the original value of the descriptor. */ + if (!g77) + { + origptr = gfc_create_var (pvoid_type_node, "origptr"); + tmp = build_fold_indirect_ref_loc (input_location, desc); + tmp = gfc_conv_array_data (tmp); + tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (origptr), origptr, + fold_convert (TREE_TYPE (origptr), tmp)); + gfc_add_expr_to_block (&se->pre, tmp); + } + /* Repack the array. */ if (gfc_option.warn_array_temp) { @@ -5706,7 +5727,15 @@ ptr = gfc_evaluate_now (ptr, &se->pre); - se->expr = ptr; + /* Use the packed data for the actual argument, except for contiguous arrays, + where the descriptor's data component is set. */ + if (g77) + se->expr = ptr; + else + { + tmp = build_fold_indirect_ref_loc (input_location, desc); + gfc_conv_descriptor_data_set (&se->pre, tmp, ptr); + } if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS) { @@ -5768,6 +5797,14 @@ gfc_add_block_to_block (&block, &se->post); gfc_init_block (&se->post); + + /* Reset the descriptor pointer. */ + if (!g77) + { + tmp = build_fold_indirect_ref_loc (input_location, desc); + gfc_conv_descriptor_data_set (&se->post, tmp, origptr); + } + gfc_add_block_to_block (&se->post, &block); } } Index: gcc/fortran/trans-expr.c =================================================================== --- gcc/fortran/trans-expr.c (Revision 161033) +++ gcc/fortran/trans-expr.c (Arbeitskopie) @@ -1718,6 +1718,7 @@ new_sym->as = gfc_copy_array_spec (sym->as); new_sym->attr.referenced = 1; new_sym->attr.dimension = sym->attr.dimension; + new_sym->attr.contiguous = sym->attr.contiguous; new_sym->attr.codimension = sym->attr.codimension; new_sym->attr.pointer = sym->attr.pointer; new_sym->attr.allocatable = sym->attr.allocatable; Index: gcc/fortran/symbol.c =================================================================== --- gcc/fortran/symbol.c (Revision 161033) +++ gcc/fortran/symbol.c (Arbeitskopie) @@ -372,7 +372,8 @@ *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE", *volatile_ = "VOLATILE", *is_protected = "PROTECTED", *is_bind_c = "BIND(C)", *procedure = "PROCEDURE", - *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION"; + *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION", + *contiguous = "CONTIGUOUS"; static const char *threadprivate = "THREADPRIVATE"; const char *a1, *a2; @@ -518,6 +519,7 @@ conf (cray_pointer, cray_pointee); conf (cray_pointer, dimension); conf (cray_pointer, codimension); + conf (cray_pointer, contiguous); conf (cray_pointer, pointer); conf (cray_pointer, target); conf (cray_pointer, allocatable); @@ -529,6 +531,7 @@ conf (cray_pointer, entry); conf (cray_pointee, allocatable); + conf (cray_pointer, contiguous); conf (cray_pointer, codimension); conf (cray_pointee, intent); conf (cray_pointee, optional); @@ -613,6 +616,7 @@ conf2 (dummy); conf2 (volatile_); conf2 (asynchronous); + conf2 (contiguous); conf2 (pointer); conf2 (is_protected); conf2 (target); @@ -720,6 +724,7 @@ conf2 (function); conf2 (subroutine); conf2 (entry); + conf2 (contiguous); conf2 (pointer); conf2 (is_protected); conf2 (target); @@ -928,6 +933,18 @@ gfc_try +gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return FAILURE; + + attr->contiguous = 1; + return check_conflict (attr, name, where); +} + + +gfc_try gfc_add_external (symbol_attribute *attr, locus *where) { @@ -1715,6 +1732,8 @@ goto fail; if (src->codimension && gfc_add_codimension (dest, NULL, where) == FAILURE) goto fail; + if (src->contiguous && gfc_add_contiguous (dest, NULL, where) == FAILURE) + goto fail; if (src->optional && gfc_add_optional (dest, where) == FAILURE) goto fail; if (src->pointer && gfc_add_pointer (dest, where) == FAILURE) Index: gcc/fortran/decl.c =================================================================== --- gcc/fortran/decl.c (Revision 161033) +++ gcc/fortran/decl.c (Arbeitskopie) @@ -2875,8 +2875,8 @@ DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL, DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE, DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE, - DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_NONE, - GFC_DECL_END /* Sentinel */ + DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS, + DECL_NONE, GFC_DECL_END /* Sentinel */ } decl_types; @@ -2939,6 +2939,7 @@ } break; } + break; case 'b': /* Try and match the bind(c). */ @@ -2950,8 +2951,24 @@ break; case 'c': - if (match_string_p ("codimension")) - d = DECL_CODIMENSION; + gfc_next_ascii_char (); + if ('o' != gfc_next_ascii_char ()) + break; + switch (gfc_next_ascii_char ()) + { + case 'd': + if (match_string_p ("imension")) + { + d = DECL_CODIMENSION; + break; + } + case 'n': + if (match_string_p ("tiguous")) + { + d = DECL_CONTIGUOUS; + break; + } + } break; case 'd': @@ -3144,6 +3161,9 @@ case DECL_CODIMENSION: attr = "CODIMENSION"; break; + case DECL_CONTIGUOUS: + attr = "CONTIGUOUS"; + break; case DECL_DIMENSION: attr = "DIMENSION"; break; @@ -3214,7 +3234,7 @@ if (gfc_current_state () == COMP_DERIVED && d != DECL_DIMENSION && d != DECL_CODIMENSION && d != DECL_POINTER && d != DECL_PRIVATE - && d != DECL_PUBLIC && d != DECL_NONE) + && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE) { if (d == DECL_ALLOCATABLE) { @@ -3283,6 +3303,15 @@ t = gfc_add_codimension (¤t_attr, NULL, &seen_at[d]); break; + case DECL_CONTIGUOUS: + if (gfc_notify_std (GFC_STD_F2008, + "Fortran 2008: CONTIGUOUS attribute at %C") + == FAILURE) + t = FAILURE; + else + t = gfc_add_contiguous (¤t_attr, NULL, &seen_at[d]); + break; + case DECL_DIMENSION: t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]); break; @@ -6118,6 +6147,20 @@ return attr_decl (); } + + +match +gfc_match_contiguous (void) +{ + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTIGUOUS statement at %C") + == FAILURE) + return MATCH_ERROR; + + gfc_clear_attr (¤t_attr); + current_attr.contiguous = 1; + + return attr_decl (); +} match Index: gcc/fortran/dump-parse-tree.c =================================================================== --- gcc/fortran/dump-parse-tree.c (Revision 161033) +++ gcc/fortran/dump-parse-tree.c (Arbeitskopie) @@ -598,6 +598,8 @@ fputs (" CODIMENSION", dumpfile); if (attr->dimension) fputs (" DIMENSION", dumpfile); + if (attr->contiguous) + fputs (" CONTIGUOUS", dumpfile); if (attr->external) fputs (" EXTERNAL", dumpfile); if (attr->intrinsic) Index: gcc/fortran/gfortran.h =================================================================== --- gcc/fortran/gfortran.h (Revision 161033) +++ gcc/fortran/gfortran.h (Arbeitskopie) @@ -665,7 +665,8 @@ unsigned allocatable:1, dimension:1, codimension:1, external:1, intrinsic:1, optional:1, pointer:1, target:1, value:1, volatile_:1, temporary:1, dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1, - implied_index:1, subref_array_pointer:1, proc_pointer:1, asynchronous:1; + implied_index:1, subref_array_pointer:1, proc_pointer:1, asynchronous:1, + contiguous:1; /* For CLASS containers, the pointer attribute is sometimes set internally even though it was not directly specified. In this case, keep the @@ -2437,6 +2438,7 @@ gfc_try gfc_add_ext_attribute (symbol_attribute *, ext_attr_id_t, locus *); gfc_try gfc_add_allocatable (symbol_attribute *, locus *); gfc_try gfc_add_codimension (symbol_attribute *, const char *, locus *); +gfc_try gfc_add_contiguous (symbol_attribute *, const char *, locus *); gfc_try gfc_add_dimension (symbol_attribute *, const char *, locus *); gfc_try gfc_add_external (symbol_attribute *, locus *); gfc_try gfc_add_intrinsic (symbol_attribute *, locus *); @@ -2614,6 +2616,7 @@ gfc_actual_arglist *gfc_copy_actual_arglist (gfc_actual_arglist *); const char *gfc_extract_int (gfc_expr *, int *); bool is_subref_array (gfc_expr *); +bool gfc_is_simply_contiguous (gfc_expr *, bool); gfc_expr *gfc_build_conversion (gfc_expr *); void gfc_free_ref_list (gfc_ref *); Index: gcc/fortran/expr.c =================================================================== --- gcc/fortran/expr.c (Revision 161033) +++ gcc/fortran/expr.c (Arbeitskopie) @@ -4080,3 +4080,105 @@ else return false; } + + +/* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4. + Note: A scalar is not regarded as "simply contiguous" by the standard. + if bool is not strict, some futher checks are done - for instance, + a "(::1)" is accepted. */ + +bool +gfc_is_simply_contiguous (gfc_expr *expr, bool strict) +{ + bool colon; + int i; + gfc_array_ref *ar = NULL; + gfc_ref *ref, *part_ref = NULL; + + if (expr->expr_type == EXPR_FUNCTION) + return expr->value.function.esym + ? expr->value.function.esym->result->attr.contiguous : false; + else if (expr->expr_type != EXPR_VARIABLE) + return false; + + if (expr->rank == 0) + return false; + + for (ref = expr->ref; ref; ref = ref->next) + { + if (ar) + return false; /* Array shall be last part-ref. */ + + if (ref->type == REF_COMPONENT) + part_ref = ref; + else if (ref->type == REF_SUBSTRING) + return false; + else if (ref->u.ar.type != AR_ELEMENT) + ar = &ref->u.ar; + } + + if ((part_ref && !part_ref->u.c.component->attr.contiguous + && part_ref->u.c.component->attr.pointer) + || (!part_ref && !expr->symtree->n.sym->attr.contiguous + && (expr->symtree->n.sym->attr.pointer + || expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE))) + return false; + + if (!ar || ar->type == AR_FULL) + return true; + + gcc_assert (ar->type == AR_SECTION); + + /* Check for simply contiguous array */ + colon = true; + for (i = 0; i < ar->dimen; i++) + { + if (ar->dimen_type[i] == DIMEN_VECTOR) + return false; + + if (ar->dimen_type[i] == DIMEN_ELEMENT) + { + colon = false; + continue; + } + + gcc_assert (ar->dimen_type[i] == DIMEN_RANGE); + + + /* If the previous section was not contiguous, that's an error, + unless we have effective only one element and checking is not + strict. */ + if (!colon && (strict || !ar->start[i] || !ar->end[i] + || ar->start[i]->expr_type != EXPR_CONSTANT + || ar->end[i]->expr_type != EXPR_CONSTANT + || mpz_cmp (ar->start[i]->value.integer, + ar->end[i]->value.integer) != 0)) + return false; + + /* Following the standard, "(::1)" or - if known at compile time - + "(lbound:ubound)" are not simply contigous; if strict + is false, they are regarded as simple contiguous. */ + if (ar->stride[i] && (strict || ar->stride[i]->expr_type != EXPR_CONSTANT + || ar->stride[i]->ts.type != BT_INTEGER + || mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0)) + return false; + + if (ar->start[i] + && (strict || ar->start[i]->expr_type != EXPR_CONSTANT + || !ar->as->lower[i] + || ar->as->lower[i]->expr_type != EXPR_CONSTANT + || mpz_cmp (ar->start[i]->value.integer, + ar->as->lower[i]->value.integer) != 0)) + colon = false; + + if (ar->end[i] + && (strict || ar->end[i]->expr_type != EXPR_CONSTANT + || !ar->as->upper[i] + || ar->as->upper[i]->expr_type != EXPR_CONSTANT + || mpz_cmp (ar->end[i]->value.integer, + ar->as->upper[i]->value.integer) != 0)) + colon = false; + } + + return true; +} Index: gcc/fortran/module.c =================================================================== --- gcc/fortran/module.c (Revision 161033) +++ gcc/fortran/module.c (Arbeitskopie) @@ -1675,7 +1675,7 @@ AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP, AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION, - AB_COARRAY_COMP, AB_VTYPE, AB_VTAB + AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS } ab_attribute; @@ -1685,6 +1685,7 @@ minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS), minit ("DIMENSION", AB_DIMENSION), minit ("CODIMENSION", AB_CODIMENSION), + minit ("CONTIGUOUS", AB_CONTIGUOUS), minit ("EXTERNAL", AB_EXTERNAL), minit ("INTRINSIC", AB_INTRINSIC), minit ("OPTIONAL", AB_OPTIONAL), @@ -1807,6 +1808,8 @@ MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits); if (attr->codimension) MIO_NAME (ab_attribute) (AB_CODIMENSION, attr_bits); + if (attr->contiguous) + MIO_NAME (ab_attribute) (AB_CONTIGUOUS, attr_bits); if (attr->external) MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits); if (attr->intrinsic) @@ -1915,6 +1918,9 @@ case AB_CODIMENSION: attr->codimension = 1; break; + case AB_CONTIGUOUS: + attr->contiguous = 1; + break; case AB_EXTERNAL: attr->external = 1; break; Index: gcc/fortran/trans-types.c =================================================================== --- gcc/fortran/trans-types.c (Revision 161033) +++ gcc/fortran/trans-types.c (Arbeitskopie) @@ -1202,7 +1202,8 @@ static tree gfc_build_array_type (tree type, gfc_array_spec * as, - enum gfc_array_kind akind, bool restricted) + enum gfc_array_kind akind, bool restricted, + bool contiguous) { tree lbound[GFC_MAX_DIMENSIONS]; tree ubound[GFC_MAX_DIMENSIONS]; @@ -1219,7 +1220,8 @@ } if (as->type == AS_ASSUMED_SHAPE) - akind = GFC_ARRAY_ASSUMED_SHAPE; + akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT + : GFC_ARRAY_ASSUMED_SHAPE; return gfc_get_array_type_bounds (type, as->rank, as->corank, lbound, ubound, 0, akind, restricted); } @@ -1799,10 +1801,12 @@ { enum gfc_array_kind akind = GFC_ARRAY_UNKNOWN; if (sym->attr.pointer) - akind = GFC_ARRAY_POINTER; + akind = sym->attr.contiguous ? GFC_ARRAY_POINTER_CONT + : GFC_ARRAY_POINTER; else if (sym->attr.allocatable) akind = GFC_ARRAY_ALLOCATABLE; - type = gfc_build_array_type (type, sym->as, akind, restricted); + type = gfc_build_array_type (type, sym->as, akind, restricted, + sym->attr.contiguous); } } else @@ -2121,14 +2125,16 @@ { enum gfc_array_kind akind; if (c->attr.pointer) - akind = GFC_ARRAY_POINTER; + akind = c->attr.contiguous ? GFC_ARRAY_POINTER_CONT + : GFC_ARRAY_POINTER; else akind = GFC_ARRAY_ALLOCATABLE; /* Pointers to arrays aren't actually pointer types. The descriptors are separate, but the data is common. */ field_type = gfc_build_array_type (field_type, c->as, akind, !c->attr.target - && !c->attr.pointer); + && !c->attr.pointer, + c->attr.contiguous); } else field_type = gfc_get_nodesc_array_type (field_type, c->as, @@ -2516,7 +2522,8 @@ if (int_size_in_bytes (etype) <= 0) return false; /* Nor non-constant lower bounds in assumed shape arrays. */ - if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE) + if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE + || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT) { for (dim = 0; dim < rank; dim++) if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE @@ -2565,7 +2572,8 @@ if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE) info->allocated = build2 (NE_EXPR, boolean_type_node, info->data_location, null_pointer_node); - else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER) + else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER + || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT) info->associated = build2 (NE_EXPR, boolean_type_node, info->data_location, null_pointer_node); @@ -2579,7 +2587,8 @@ size_binop (PLUS_EXPR, dim_off, upper_suboff)); t = build1 (INDIRECT_REF, gfc_array_index_type, t); info->dimen[dim].upper_bound = t; - if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE) + if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE + || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT) { /* Assumed shape arrays have known lower bounds. */ info->dimen[dim].upper_bound Index: gcc/fortran/trans.h =================================================================== --- gcc/fortran/trans.h (Revision 161033) +++ gcc/fortran/trans.h (Arbeitskopie) @@ -620,14 +620,17 @@ /* True if node is an integer constant. */ #define INTEGER_CST_P(node) (TREE_CODE(node) == INTEGER_CST) -/* G95-specific declaration information. */ +/* gfortran-specific declaration information, the _CONT versions denote + arrays with CONTIGUOUS attribute. */ enum gfc_array_kind { GFC_ARRAY_UNKNOWN, GFC_ARRAY_ASSUMED_SHAPE, + GFC_ARRAY_ASSUMED_SHAPE_CONT, GFC_ARRAY_ALLOCATABLE, - GFC_ARRAY_POINTER + GFC_ARRAY_POINTER, + GFC_ARRAY_POINTER_CONT }; /* Array types only. */ Index: gcc/fortran/resolve.c =================================================================== --- gcc/fortran/resolve.c (Revision 161033) +++ gcc/fortran/resolve.c (Arbeitskopie) @@ -10826,6 +10826,14 @@ return FAILURE; } + /* F2008, C448. */ + if (c->attr.contiguous && (!c->attr.dimension || !c->attr.pointer)) + { + gfc_error ("Component '%s' at %L has the CONTIGUOUS attribute but " + "is not an array pointer", c->name, &c->loc); + return FAILURE; + } + if (c->attr.proc_pointer && c->ts.interface) { if (c->ts.interface->attr.procedure && !sym->attr.vtype) @@ -11397,6 +11405,7 @@ sym->attr.pure = ifc->attr.pure; sym->attr.elemental = ifc->attr.elemental; sym->attr.dimension = ifc->attr.dimension; + sym->attr.contiguous = ifc->attr.contiguous; sym->attr.recursive = ifc->attr.recursive; sym->attr.always_explicit = ifc->attr.always_explicit; sym->attr.ext_attr |= ifc->attr.ext_attr; @@ -11442,6 +11451,18 @@ return; } + + /* F2008, C530. */ + if (sym->attr.contiguous + && (!sym->attr.dimension || (sym->as->type != AS_ASSUMED_SHAPE + && !sym->attr.pointer))) + { + gfc_error ("'%s' at %L has the CONTIGUOUS attribute but is not an " + "array pointer or an assumed-shape array", sym->name, + &sym->declared_at); + return; + } + if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE) return; @@ -11500,6 +11521,7 @@ sym->attr.dimension = sym->result->attr.dimension; sym->attr.pointer = sym->result->attr.pointer; sym->attr.allocatable = sym->result->attr.allocatable; + sym->attr.contiguous = sym->result->attr.contiguous; } } } Index: gcc/fortran/trans-decl.c =================================================================== --- gcc/fortran/trans-decl.c (Revision 161033) +++ gcc/fortran/trans-decl.c (Arbeitskopie) @@ -1213,7 +1213,8 @@ /* Create variables to hold the non-constant bits of array info. */ gfc_build_qualified_array (decl, sym); - if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer) + if (sym->attr.contiguous + || ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)) GFC_DECL_PACKED_ARRAY (decl) = 1; } Index: gcc/fortran/match.h =================================================================== --- gcc/fortran/match.h (Revision 161033) +++ gcc/fortran/match.h (Arbeitskopie) @@ -168,6 +168,7 @@ match gfc_match_allocatable (void); match gfc_match_asynchronous (void); match gfc_match_codimension (void); +match gfc_match_contiguous (void); match gfc_match_dimension (void); match gfc_match_external (void); match gfc_match_gcc_attributes (void); Index: gcc/fortran/parse.c =================================================================== --- gcc/fortran/parse.c (Revision 161033) +++ gcc/fortran/parse.c (Arbeitskopie) @@ -139,6 +139,7 @@ case 'c': match ("codimension", gfc_match_codimension, ST_ATTR_DECL); + match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL); break; case 'd': @@ -346,6 +347,7 @@ match ("call", gfc_match_call, ST_CALL); match ("close", gfc_match_close, ST_CLOSE); match ("continue", gfc_match_continue, ST_CONTINUE); + match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL); match ("cycle", gfc_match_cycle, ST_CYCLE); match ("case", gfc_match_case, ST_CASE); match ("common", gfc_match_common, ST_COMMON); Index: gcc/fortran/dependency.c =================================================================== --- gcc/fortran/dependency.c (Revision 161033) +++ gcc/fortran/dependency.c (Arbeitskopie) @@ -1588,4 +1588,3 @@ return fin_dep == GFC_DEP_OVERLAP; } - Index: gcc/fortran/dependency.h =================================================================== --- gcc/fortran/dependency.h (Revision 161033) +++ gcc/fortran/dependency.h (Arbeitskopie) @@ -43,3 +43,4 @@ int gfc_dep_resolver(gfc_ref *, gfc_ref *); int gfc_are_equivalenced_arrays (gfc_expr *, gfc_expr *); + Index: gcc/testsuite/gfortran.dg/contiguous_1.f90 =================================================================== --- gcc/testsuite/gfortran.dg/contiguous_1.f90 (Revision 0) +++ gcc/testsuite/gfortran.dg/contiguous_1.f90 (Revision 0) @@ -0,0 +1,177 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/40632 +! +! CONTIGUOUS compile-time tests +! + +! C448: Must be an array with POINTER attribute +type t1 + integer, contiguous :: ca(5) ! { dg-error "Component .ca. at .1. has the CONTIGUOUS" } +end type t1 +type t2 + integer, contiguous, allocatable :: cb(:) ! { dg-error "Component .cb. at .1. has the CONTIGUOUS" } +end type t2 +type t3 + integer, contiguous, pointer :: cc(:) ! OK +end type t3 +type t4 + integer, pointer, contiguous :: cd ! { dg-error "Component .cd. at .1. has the CONTIGUOUS" } +end type t4 +end + +! C530: Must be an array and (a) a POINTER or (b) assumed shape. +subroutine test(x, y) + integer, pointer :: x(:) + integer, intent(in) :: y(:) + contiguous :: x, y + + integer, contiguous :: a(5) ! { dg-error ".a. at .1. has the CONTIGUOUS attribute" } + integer, contiguous, allocatable :: b(:) ! { dg-error ".b. at .1. has the CONTIGUOUS attribute" } + integer, contiguous, pointer :: c(:) ! OK + integer, pointer, contiguous :: d ! { dg-error ".d. at .1. has the CONTIGUOUS attribute" } +end + +! Pointer assignment check: +! If the pointer object has the CONTIGUOUS attribute, the pointer target shall be contiguous. +! Note: This is not compile-time checkable; but F2008, 5.3.7 except in a very few cases. +subroutine ptr_assign() + integer, pointer, contiguous :: ptr1(:) + integer, target :: tgt(5) + ptr1 => tgt +end subroutine + + +! C1239 (R1223) If an actual argument is a nonpointer array that has the ASYNCHRONOUS or VOLATILE +! attribute but is not simply contiguous (6.5.4), and the corresponding dummy argument has either the +! VOLATILE or ASYNCHRONOUS attribute, that dummy argument shall be an assumed-shape array +! that does not have the CONTIGUOUS attribute. + +subroutine C1239 + type t + integer :: e(4) + end type t + type(t), volatile :: f + integer, asynchronous :: a(4), b(4) + integer, volatile :: c(4), d(4) + call test (a,b,c) ! OK + call test (a,b(::2),c) ! { dg-error "array without CONTIGUOUS" } + call test (a(::2),b,c) ! { dg-error "array without CONTIGUOUS" } + + call test (a,b,f%e) ! OK + call test (a,f%e,c) ! OK + call test (f%e,b,c) ! OK + call test (a,b,f%e(::2)) ! OK + call test (a,f%e(::2),c) ! { dg-error "array without CONTIGUOUS" } + call test (f%e(::2),b,c) ! { dg-error "array without CONTIGUOUS" } +contains + subroutine test(u, v, w) + integer, asynchronous :: u(:), v(*) + integer, volatile :: w(:) + contiguous :: u + end subroutine test +end subroutine C1239 + + +! C1240 (R1223) If an actual argument is an array pointer that has the ASYNCHRONOUS or VOLATILE +! attribute but does not have the CONTIGUOUS attribute, and the corresponding dummy argument has +! either the VOLATILE or ASYNCHRONOUS attribute, that dummy argument shall be an array pointer +! or an assumed-shape array that does not have the CONTIGUOUS attribute. + +subroutine C1240 + type t + integer,pointer :: e(:) + end type t + type(t), volatile :: f + integer, pointer, asynchronous :: a(:), b(:) + integer,pointer, volatile :: c(:), d(:) + call test (a,b,c) ! { dg-error "array without CONTIGUOUS" } + call test (a,b(::2),c) ! { dg-error "array without CONTIGUOUS" } + call test (a(::2),b,c) ! { dg-error "array without CONTIGUOUS" } + + call test (a,b,f%e) ! { dg-error "array without CONTIGUOUS" } + call test (a,f%e,c) ! { dg-error "array without CONTIGUOUS" } + call test (f%e,b,c) ! { dg-error "array without CONTIGUOUS" } + call test (a,b,f%e(::2)) ! { dg-error "array without CONTIGUOUS" } + call test (a,f%e(::2),c) ! { dg-error "array without CONTIGUOUS" } + call test (f%e(::2),b,c) ! { dg-error "array without CONTIGUOUS" } + + call test2(a,b) + call test3(a,b) + call test2(c,d) + call test3(c,d) + call test2(f%e,d) + call test3(c,f%e) +contains + subroutine test(u, v, w) + integer, asynchronous :: u(:), v(*) + integer, volatile :: w(:) + contiguous :: u + end subroutine test + subroutine test2(x,y) + integer, asynchronous :: x(:) + integer, volatile :: y(:) + end subroutine test2 + subroutine test3(x,y) + integer, pointer, asynchronous :: x(:) + integer, pointer, volatile :: y(:) + end subroutine test3 +end subroutine C1240 + + + +! 12.5.2.7 Pointer dummy variables +! C1241 The actual argument corresponding to a dummy pointer with the CONTIGUOUS attribute shall be +! simply contiguous (6.5.4). + +subroutine C1241 + integer, pointer, contiguous :: a(:) + integer, pointer :: b(:) + call test(a) + call test(b) ! { dg-error "must be simply contigous" } +contains + subroutine test(x) + integer, pointer, contiguous :: x(:) + end subroutine test +end subroutine C1241 + + +! 12.5.2.8 Coarray dummy variables +! If the dummy argument is an array coarray that has the CONTIGUOUS attribute or is not of assumed shape, +! the corresponding actual argument shall be simply contiguous + +subroutine sect12528(cob) + integer, save :: coa(6)[*] + integer :: cob(:)[*] + + call test(coa) + call test2(coa) + call test3(coa) + + call test(cob) ! { dg-error "must be simply contiguous" } + call test2(cob) ! { dg-error "must be simply contiguous" } + call test3(cob) +contains + subroutine test(x) + integer, contiguous :: x(:)[*] + end subroutine test + subroutine test2(x) + integer :: x(*)[*] + end subroutine test2 + subroutine test3(x) + integer :: x(:)[*] + end subroutine test3 +end subroutine sect12528 + + + +subroutine test34 + implicit none + integer, volatile,pointer :: a(:,:),i + call foo(a(2,2:3:2)) ! { dg-error "must be simply contigous" } +contains + subroutine foo(x) + integer, pointer, contiguous, volatile :: x(:) + end subroutine +end subroutine test34 Index: gcc/testsuite/gfortran.dg/contiguous_2.f90 =================================================================== --- gcc/testsuite/gfortran.dg/contiguous_2.f90 (Revision 0) +++ gcc/testsuite/gfortran.dg/contiguous_2.f90 (Revision 0) @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/40632 +! +! CONTIGUOUS compile-time tests +! + +integer, pointer, contiguous :: a(:) ! { dg-error "Fortran 2008:" } +integer, pointer :: b(:) +contiguous :: b ! { dg-error "Fortran 2008:" } +end Index: gcc/testsuite/gfortran.dg/contiguous_3.f90 =================================================================== --- gcc/testsuite/gfortran.dg/contiguous_3.f90 (Revision 0) +++ gcc/testsuite/gfortran.dg/contiguous_3.f90 (Revision 0) @@ -0,0 +1,65 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/40632 +! +! CONTIGUOUS compile-time tests: Check that contigous +! works properly. + +subroutine test1(a,b) + integer, pointer, contiguous :: test1_a(:) + call foo(test1_a) + call foo(test1_a(::1)) + call foo(test1_a(::2)) +contains + subroutine foo(b) + integer :: b(*) + end subroutine foo +end subroutine test1 + +! For the first two no pack is done; for the third one, an array descriptor +! (cf. below test3) is created for packing. +! +! { dg-final { scan-tree-dump-times "_internal_pack.*test1_a" 0 "original" } } +! { dg-final { scan-tree-dump-times "_internal_unpack.*test1_a" 0 "original" } } + + +subroutine t2(a1,b1,c2,d2) + integer, pointer, contiguous :: a1(:), b1(:) + integer, pointer :: c2(:), d2(:) + a1 = b1 + c2 = d2 +end subroutine t2 + +! { dg-final { scan-tree-dump-times "= a1->dim.0..stride;" 0 "original" } } +! { dg-final { scan-tree-dump-times "= b1->dim.0..stride;" 0 "original" } } +! { dg-final { scan-tree-dump-times "= c2->dim.0..stride;" 1 "original" } } +! { dg-final { scan-tree-dump-times "= d2->dim.0..stride;" 1 "original" } } + + +subroutine test3() + implicit none + integer :: test3_a(8),i + test3_a = [(i,i=1,8)] + call foo(test3_a(::1)) + call foo(test3_a(::2)) + call bar(test3_a(::1)) + call bar(test3_a(::2)) +contains + subroutine foo(x) + integer, contiguous :: x(:) + print *, x + end subroutine + subroutine bar(x) + integer :: x(:) + print *, x + end subroutine bar +end subroutine test3 + +! Once for test1 (third call), once for test3 (second call) +! { dg-final { scan-tree-dump-times "data = origptr" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_internal_pack .&parm" 2 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_internal_unpack .&parm" 2 "original" } } + + +! { dg-final { cleanup-tree-dump "original" } }