OSDN Git Service

2010-02-05 Paul Thomas <pault@gcc.gnu.org>
authorpault <pault@138bc75d-0d04-0410-961f-82ee72b054a4>
Fri, 5 Feb 2010 05:28:37 +0000 (05:28 +0000)
committerpault <pault@138bc75d-0d04-0410-961f-82ee72b054a4>
Fri, 5 Feb 2010 05:28:37 +0000 (05:28 +0000)
PR fortran/42309
* trans-expr.c (gfc_conv_subref_array_arg): Add new argument
'formal_ptr'. If this is true, give returned descriptor unity
lbounds, in all dimensions, and the appropriate offset.
(gfc_conv_procedure_call); If formal is a pointer, set the last
argument of gfc_conv_subref_array_arg to true.
* trans.h : Add last argument for gfc_conv_subref_array_arg.
* trans-io.c (set_internal_unit, gfc_trans_transfer): Set the
new arg of gfc_conv_subref_array_arg to false.
* trans-stmt.c (forall_make_variable_temp): The same.

2010-02-05  Paul Thomas  <pault@gcc.gnu.org>

PR fortran/42309
* gfortran.dg/subref_array_pointer_4.f90 : New test.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@156512 138bc75d-0d04-0410-961f-82ee72b054a4

gcc/fortran/ChangeLog
gcc/fortran/trans-expr.c
gcc/fortran/trans-io.c
gcc/fortran/trans-stmt.c
gcc/fortran/trans.h
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/subref_array_pointer_4.f90 [new file with mode: 0644]

index 8a69b42..6d52e5d 100644 (file)
@@ -1,3 +1,16 @@
+2010-02-05  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/42309
+       * trans-expr.c (gfc_conv_subref_array_arg): Add new argument
+       'formal_ptr'. If this is true, give returned descriptor unity
+       lbounds, in all dimensions, and the appropriate offset.
+       (gfc_conv_procedure_call); If formal is a pointer, set the last
+       argument of gfc_conv_subref_array_arg to true.
+       * trans.h : Add last argument for gfc_conv_subref_array_arg.
+       * trans-io.c (set_internal_unit, gfc_trans_transfer): Set the
+       new arg of gfc_conv_subref_array_arg to false.
+       * trans-stmt.c (forall_make_variable_temp): The same.
+
 2010-02-03  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/42936
index b5091a9..4a70e73 100644 (file)
@@ -2294,8 +2294,8 @@ gfc_apply_interface_mapping (gfc_interface_mapping * mapping,
    an actual argument derived type array is copied and then returned
    after the function call.  */
 void
-gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
-                          int g77, sym_intent intent)
+gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
+                          sym_intent intent, bool formal_ptr)
 {
   gfc_se lse;
   gfc_se rse;
@@ -2308,6 +2308,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
   tree tmp_index;
   tree tmp;
   tree base_type;
+  tree size;
   stmtblock_t body;
   int n;
 
@@ -2501,6 +2502,42 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr,
   if (expr->ts.type == BT_CHARACTER)
     parmse->string_length = expr->ts.u.cl->backend_decl;
 
+  /* Determine the offset for pointer formal arguments and set the
+     lbounds to one.  */
+  if (formal_ptr)
+    {
+      size = gfc_index_one_node;
+      offset = gfc_index_zero_node;  
+      for (n = 0; n < info->dimen; n++)
+       {
+         tmp = gfc_conv_descriptor_ubound_get (parmse->expr,
+                                               gfc_rank_cst[n]);
+         tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+                            tmp, gfc_index_one_node);
+         gfc_conv_descriptor_ubound_set (&parmse->pre,
+                                         parmse->expr,
+                                         gfc_rank_cst[n],
+                                         tmp);
+         gfc_conv_descriptor_lbound_set (&parmse->pre,
+                                         parmse->expr,
+                                         gfc_rank_cst[n],
+                                         gfc_index_one_node);
+         size = gfc_evaluate_now (size, &parmse->pre);
+         offset = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+                               offset, size);
+         offset = gfc_evaluate_now (offset, &parmse->pre);
+         tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+                            rse.loop->to[n], rse.loop->from[n]);
+         tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+                            tmp, gfc_index_one_node);
+         size = fold_build2 (MULT_EXPR, gfc_array_index_type,
+                             size, tmp);
+       }
+
+      gfc_conv_descriptor_offset_set (&parmse->pre, parmse->expr,
+                                     offset);
+    }
+
   /* We want either the address for the data or the address of the descriptor,
      depending on the mode of passing array arguments.  */
   if (g77)
@@ -3005,7 +3042,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
                   is converted to a temporary, which is passed and then
                   written back after the procedure call.  */
                gfc_conv_subref_array_arg (&parmse, e, f,
-                       fsym ? fsym->attr.intent : INTENT_INOUT);
+                               fsym ? fsym->attr.intent : INTENT_INOUT,
+                               fsym && fsym->attr.pointer);
              else
                gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
                                          sym->name, NULL);
index 690464e..30561bb 100644 (file)
@@ -741,7 +741,7 @@ set_internal_unit (stmtblock_t * block, stmtblock_t * post_block,
          /* Use a temporary for components of arrays of derived types
             or substring array references.  */
          gfc_conv_subref_array_arg (&se, e, 0,
-               last_dt == READ ? INTENT_IN : INTENT_OUT);
+               last_dt == READ ? INTENT_IN : INTENT_OUT, false);
          tmp = build_fold_indirect_ref_loc (input_location,
                                         se.expr);
          se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
@@ -2211,7 +2211,7 @@ gfc_trans_transfer (gfc_code * code)
          if (seen_vector && last_dt == READ)
            {
              /* Create a temp, read to that and copy it back.  */
-             gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT);
+             gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT, false);
              tmp =  se.expr;
            }
          else
index dd3d10d..84c3c85 100644 (file)
@@ -1800,7 +1800,7 @@ forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
   if (old_sym->attr.dimension)
     {
       gfc_init_se (&tse, NULL);
-      gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN);
+      gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN, false);
       gfc_add_block_to_block (pre, &tse.pre);
       gfc_add_block_to_block (post, &tse.post);
       tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr);
index 27b040a..30a7753 100644 (file)
@@ -315,7 +315,7 @@ int gfc_is_intrinsic_libcall (gfc_expr *);
 int gfc_conv_procedure_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
                            gfc_expr *, tree);
 
-void gfc_conv_subref_array_arg (gfc_se *, gfc_expr *, int, sym_intent);
+void gfc_conv_subref_array_arg (gfc_se *, gfc_expr *, int, sym_intent, bool);
 
 /* gfc_trans_* shouldn't call push/poplevel, use gfc_push/pop_scope */
 
index 4a4273e..94ccbc4 100644 (file)
@@ -1,3 +1,8 @@
+2010-02-05  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/42309
+       * gfortran.dg/subref_array_pointer_4.f90 : New test.
+
 2010-02-04  Richard Guenther  <rguenther@suse.de>
 
        PR rtl-optimization/42952
diff --git a/gcc/testsuite/gfortran.dg/subref_array_pointer_4.f90 b/gcc/testsuite/gfortran.dg/subref_array_pointer_4.f90
new file mode 100644 (file)
index 0000000..19edfdc
--- /dev/null
@@ -0,0 +1,28 @@
+! { dg-do run }
+! Tests the fix for PR42309, in which the indexing of 'Q'
+! was off by one.
+!
+! Contributed by Gilbert Scott <gilbert.scott@easynet.co.uk>
+!
+PROGRAM X
+  TYPE T
+    INTEGER :: I
+    REAL :: X
+  END TYPE T
+  TYPE(T), TARGET :: T1(0:3)
+  INTEGER, POINTER :: P(:)
+  REAL :: SOURCE(4) = [10., 20., 30., 40.]
+
+  T1%I = [1, 2, 3, 4]
+  T1%X = SOURCE
+  P => T1%I
+  CALL Z(P)
+  IF (ANY (T1%I .NE. [999, 2, 999, 4])) CALL ABORT
+  IF (ANY (T1%X .NE. SOURCE)) CALL ABORT
+CONTAINS
+  SUBROUTINE Z(Q)
+    INTEGER, POINTER :: Q(:)
+    Q(1:3:2) = 999
+  END SUBROUTINE Z
+END PROGRAM X
+