re PR fortran/40632 (Support F2008's contiguous attribute)

2010-06-20  Tobias Burnus  <burnus@net-b.de>

        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  <burnus@net-b.de>

        PR fortran/40632
        * gfortran.dg/contiguous_1.f90: New.
        * gfortran.dg/contiguous_2.f90: New.
        * gfortran.dg/contiguous_3.f90: New.

From-SVN: r161079

1 files changed, 42 insertions, 5 deletions

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 575dd02..7eb8e75 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -285,7 +285,9 @@ gfc_conv_descriptor_stride_get (tree desc, tree dim)
   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 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
 
   ultimate_ptr_comp = false;
   ultimate_alloc_comp = false;
+
   for (ref = expr->ref; ref; ref = ref->next)
     {
       if (ref->next == NULL)
@@ -5608,7 +5611,8 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
   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 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
 		      ||
 	     (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_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
       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 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
 
       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_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, bool g77,
       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);
     }
 }