From patchwork Fri Jun 18 22:57:02 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 56228 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 8F7E9B7D5E for ; Sat, 19 Jun 2010 08:57:22 +1000 (EST) Received: (qmail 29807 invoked by alias); 18 Jun 2010 22:57:20 -0000 Received: (qmail 29783 invoked by uid 22791); 18 Jun 2010 22:57:15 -0000 X-SWARE-Spam-Status: No, hits=-1.9 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE, TW_TM 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; Fri, 18 Jun 2010 22:57:06 +0000 Received: from [192.168.178.22] (port-92-204-52-171.dynamic.qsc.de [92.204.52.171]) by mx02.qsc.de (Postfix) with ESMTP id DA73D1D8FD; Sat, 19 Jun 2010 00:57:02 +0200 (CEST) Message-ID: <4C1BF9BE.3010209@net-b.de> Date: Sat, 19 Jun 2010 00:57:02 +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: gcc patches , gfortran Subject: Re: [Patch,Fortran] PR 40632 - Add CONTIGUOUS attribute (part 1) References: <4C1B9B1D.3020902@net-b.de> In-Reply-To: <4C1B9B1D.3020902@net-b.de> 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 Tobias Burnus wrote: > The patch implements the parsing and the constraint checking. The next > step is to use it also for procedure calls and for array operations This patch now does this; the right-most stride (dim[0]) is now one and there is no (un)pack done for procedure calls. Additionally, I added module and dump-parse-tree support, which I initially forgot. While the patch should be OK, I would be happy if someone could carefully read the patch; especially, the constraints, the simply-contiguous conditions and the trans*c part. Build and currently regtesting on x86-64-linux. OK for the trunk? Tobias 2010-06-18 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-18 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 161011) +++ gcc/fortran/interface.c (Arbeitskopie) @@ -1435,6 +1435,16 @@ compare_parameter (gfc_symbol *formal, g 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 @@ compare_parameter (gfc_symbol *formal, g : 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-expr.c =================================================================== --- gcc/fortran/trans-expr.c (Revision 161011) +++ gcc/fortran/trans-expr.c (Arbeitskopie) @@ -1718,6 +1718,7 @@ gfc_add_interface_mapping (gfc_interface 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/trans-array.c =================================================================== --- gcc/fortran/trans-array.c (Revision 161011) +++ gcc/fortran/trans-array.c (Arbeitskopie) @@ -285,7 +285,9 @@ gfc_conv_descriptor_stride_get (tree des 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); @@ -5515,6 +5517,7 @@ gfc_conv_array_parameter (gfc_se * se, g bool array_constructor; bool good_allocatable; bool ultimate_ptr_comp; + bool ultimate_contiguous; bool ultimate_alloc_comp; gfc_symbol *sym; stmtblock_t block; @@ -5522,6 +5525,10 @@ gfc_conv_array_parameter (gfc_se * se, g ultimate_ptr_comp = false; ultimate_alloc_comp = false; + ultimate_contiguous = (expr->expr_type == EXPR_VARIABLE + || expr->expr_type == EXPR_FUNCTION) + ? expr->symtree->n.sym->attr.contiguous : false; + for (ref = expr->ref; ref; ref = ref->next) { if (ref->next == NULL) @@ -5530,6 +5537,7 @@ gfc_conv_array_parameter (gfc_se * se, g if (ref->type == REF_COMPONENT) { ultimate_ptr_comp = ref->u.c.component->attr.pointer; + ultimate_contiguous = ref->u.c.component->attr.contiguous; ultimate_alloc_comp = ref->u.c.component->attr.allocatable; } } @@ -5608,7 +5616,7 @@ gfc_conv_array_parameter (gfc_se * se, g 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 non-CONTIGUOUS deferred- or assumed-shape array. */ no_pack = ((sym && sym->as && !sym->attr.pointer && sym->as->type != AS_DEFERRED @@ -5616,7 +5624,9 @@ gfc_conv_array_parameter (gfc_se * se, g || (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) + || + ultimate_contiguous); no_pack = contiguous && no_pack; Index: gcc/fortran/symbol.c =================================================================== --- gcc/fortran/symbol.c (Revision 161011) +++ gcc/fortran/symbol.c (Arbeitskopie) @@ -372,7 +372,8 @@ check_conflict (symbol_attribute *attr, *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 @@ check_conflict (symbol_attribute *attr, 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 @@ check_conflict (symbol_attribute *attr, 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 @@ check_conflict (symbol_attribute *attr, conf2 (dummy); conf2 (volatile_); conf2 (asynchronous); + conf2 (contiguous); conf2 (pointer); conf2 (is_protected); conf2 (target); @@ -720,6 +724,7 @@ check_conflict (symbol_attribute *attr, conf2 (function); conf2 (subroutine); conf2 (entry); + conf2 (contiguous); conf2 (pointer); conf2 (is_protected); conf2 (target); @@ -928,6 +933,18 @@ gfc_add_dimension (symbol_attribute *att 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 @@ gfc_copy_attr (symbol_attribute *dest, s 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 161011) +++ gcc/fortran/decl.c (Arbeitskopie) @@ -2875,8 +2875,8 @@ match_attr_spec (void) 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 @@ match_attr_spec (void) } break; } + break; case 'b': /* Try and match the bind(c). */ @@ -2950,8 +2951,24 @@ match_attr_spec (void) 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 @@ match_attr_spec (void) case DECL_CODIMENSION: attr = "CODIMENSION"; break; + case DECL_CONTIGUOUS: + attr = "CONTIGUOUS"; + break; case DECL_DIMENSION: attr = "DIMENSION"; break; @@ -3214,7 +3234,7 @@ match_attr_spec (void) 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 @@ match_attr_spec (void) 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 @@ gfc_match_codimension (void) 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 161011) +++ gcc/fortran/dump-parse-tree.c (Arbeitskopie) @@ -598,6 +598,8 @@ show_attr (symbol_attribute *attr) 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 161011) +++ gcc/fortran/gfortran.h (Arbeitskopie) @@ -665,7 +665,8 @@ typedef struct 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_attribute (symbol_attrib 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 @@ void gfc_free_actual_arglist (gfc_actual 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 161011) +++ gcc/fortran/expr.c (Arbeitskopie) @@ -4080,3 +4080,95 @@ gfc_has_ultimate_pointer (gfc_expr *e) 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->symtree->n.sym->result->attr.contiguous; + else if (expr->expr_type != EXPR_VARIABLE) + return false; + + if (expr->rank == 0) + return false; + + 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. */ + 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_UNKNOWN); + + /* Check for simply contiguous array */ + colon = true; + for (i = 0; i < ar->dimen; i++) + { + gcc_assert (ar->dimen_type[i] != DIMEN_UNKNOWN); + + if (ar->dimen_type[i] == DIMEN_VECTOR) + return false; + + /* Element or section. 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 (expr->value.integer, 1) != 0)) + return false; + + if (ar->start[i] + && (strict || ar->start[i]->expr_type != EXPR_CONSTANT + || ar->as->lower[i]->expr_type != EXPR_CONSTANT + || mpz_cmp (ar->start[i]->value.integer, + ar->as->lower[i]->value.integer) != 0)) + { + if (!colon) + return false; + colon = false; + } + if (ar->end[i] + && (strict || ar->end[i]->expr_type != EXPR_CONSTANT + || ar->as->upper[i]->expr_type != EXPR_CONSTANT + || mpz_cmp (ar->end[i]->value.integer, + ar->as->upper[i]->value.integer) != 0)) + { + if (!colon) + return false; + colon = false; + } + } + + return true; +} Index: gcc/fortran/module.c =================================================================== --- gcc/fortran/module.c (Revision 161011) +++ gcc/fortran/module.c (Arbeitskopie) @@ -1675,7 +1675,7 @@ typedef enum 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 @@ static const mstring attr_bits[] = 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_symbol_attribute (symbol_attribute * 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 @@ mio_symbol_attribute (symbol_attribute * 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 161011) +++ gcc/fortran/trans-types.c (Arbeitskopie) @@ -1202,7 +1202,8 @@ gfc_is_nodesc_array (gfc_symbol * sym) 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 @@ gfc_build_array_type (tree type, gfc_arr } 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 @@ gfc_sym_type (gfc_symbol * sym) { 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 @@ gfc_get_derived_type (gfc_symbol * deriv { 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 @@ gfc_get_array_descr_info (const_tree typ 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 @@ gfc_get_array_descr_info (const_tree typ 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 @@ gfc_get_array_descr_info (const_tree typ 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 161011) +++ gcc/fortran/trans.h (Arbeitskopie) @@ -620,14 +620,17 @@ extern GTY(()) tree gfor_fndecl_sr_kind; /* 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 161011) +++ gcc/fortran/resolve.c (Arbeitskopie) @@ -10826,6 +10826,14 @@ resolve_fl_derived (gfc_symbol *sym) 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 @@ resolve_symbol (gfc_symbol *sym) 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 @@ resolve_symbol (gfc_symbol *sym) 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 @@ resolve_symbol (gfc_symbol *sym) 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 161011) +++ gcc/fortran/trans-decl.c (Arbeitskopie) @@ -1213,7 +1213,8 @@ gfc_get_symbol_decl (gfc_symbol * sym) /* 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 161011) +++ gcc/fortran/match.h (Arbeitskopie) @@ -168,6 +168,7 @@ void gfc_set_constant_character_len (int 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 161011) +++ gcc/fortran/parse.c (Arbeitskopie) @@ -139,6 +139,7 @@ decode_specification_statement (void) 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 @@ decode_statement (void) 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 161011) +++ gcc/fortran/dependency.c (Arbeitskopie) @@ -1588,4 +1588,3 @@ gfc_dep_resolver (gfc_ref *lref, gfc_ref return fin_dep == GFC_DEP_OVERLAP; } - Index: gcc/fortran/dependency.h =================================================================== --- gcc/fortran/dependency.h (Revision 161011) +++ gcc/fortran/dependency.h (Arbeitskopie) @@ -43,3 +43,4 @@ int gfc_expr_is_one (gfc_expr *, int); 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,165 @@ +! { 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 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,35 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/40632 +! +! CONTIGUOUS compile-time tests: Check that contigous +! works properly. + +subroutine t(a,b) + integer, pointer, contiguous :: a(:) + call foo(a) + call foo(a(::1)) + call foo(a(::2)) +contains + subroutine foo(b) + integer :: b(*) + end subroutine foo +end subroutine t + +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 "_internal_pack" 1 "original" } } +! { dg-final { scan-tree-dump-times "_internal_unpack" 1 "original" } } + +! { 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" } } + +! { dg-final { cleanup-tree-dump "original" } }