Re: [gfortran] Fix PR 15557: Substring references in DATA

[Tobias Schlüter <tobias dot schlueter at physik dot uni-muenchen dot de>]

Paul Brook wrote:
> That function is getting rather large so my preference would be to split it 
> out into a separate function.

Done.

> Ok, preferably after splitting into a separate function.
> Please add a comment in the testcase saying why lines are commented. Mention 
> whichever PR would fix them (update the existing PR in neccessary).

That was an accident, those lines weren't meant to be commented. I also 
enhanced the testcase slightly to test more variations.

Tested on i686-pc-linux, below is what I committed, except for the new 
testcase, which is attached.

- Tobi

Index: fortran/ChangeLog
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/ChangeLog,v
retrieving revision 1.56
diff -c -3 -p -r1.56 ChangeLog
*** fortran/ChangeLog   1 Jun 2004 12:12:57 -0000       1.56
--- fortran/ChangeLog   2 Jun 2004 11:36:24 -0000
***************
*** 1,3 ****
--- 1,10 ----
+ 2004-06-02  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+       PR fortran/15557
+       * data.c (assign_substring_data_value): New function.
+       (gfc_assign_data_value): Call the new function if we're dealing
+       with a substring LHS.
+
  2004-06-01  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>

        PR fortran/15477
Index: fortran/data.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/data.c,v
retrieving revision 1.3
diff -c -3 -p -r1.3 data.c
*** fortran/data.c      14 May 2004 13:00:04 -0000      1.3
--- fortran/data.c      2 Jun 2004 11:36:24 -0000
*************** find_con_by_component (gfc_component *co
*** 108,115 ****
    return NULL;
  }


- /* Assign the initial value RVALUE to  LVALUE's symbol->value.  */
  void
  gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
  {
--- 108,194 ----
    return NULL;
  }

+ /* Assign RVALUE to LVALUE where we assume that LVALUE is a substring
+    reference. We do a little more than that: if LVALUE already has an
+    initialization, we put RVALUE into the existing initialization as
+    per the rules of assignment to a substring. If LVALUE has no
+    initialization yet, we initialize it to all blanks, then filling in
+    the RVALUE.  */
+
+ static void
+ assign_substring_data_value (gfc_expr * lvalue, gfc_expr * rvalue)
+ {
+   gfc_symbol *symbol;
+   gfc_expr *expr, *init;
+   gfc_ref *ref;
+   int len, i;
+   int start, end;
+   char *c, *d;
+
+   symbol = lvalue->symtree->n.sym;
+   ref = lvalue->ref;
+   init = symbol->value;
+
+   assert (symbol->ts.type == BT_CHARACTER);
+   assert (symbol->ts.cl->length->expr_type == EXPR_CONSTANT);
+   assert (symbol->ts.cl->length->ts.type == BT_INTEGER);
+   assert (symbol->ts.kind == 1);
+
+   gfc_extract_int (symbol->ts.cl->length, &len);
+
+   if (init == NULL)
+     {
+       /* Setup the expression to hold the constructor.  */
+       expr = gfc_get_expr ();
+       expr->expr_type = EXPR_CONSTANT;
+       expr->ts.type = BT_CHARACTER;
+       expr->ts.kind = 1;
+
+       expr->value.character.length = len;
+       expr->value.character.string = gfc_getmem (len);
+       memset (expr->value.character.string, ' ', len);
+
+       symbol->value = expr;
+     }
+   else
+     expr = init;
+
+   /* Now that we have allocated the memory for the string,
+      fill in the initialized places, truncating the
+      intialization string if necessary, i.e.
+      DATA a(1:2) /'123'/
+      doesn't initialize a(3:3).  */
+
+   gfc_extract_int (ref->u.ss.start, &start);
+   gfc_extract_int (ref->u.ss.end, &end);
+
+   assert (start >= 1);
+   assert (end <= len);
+
+   len = rvalue->value.character.length;
+   c = rvalue->value.character.string;
+   d = &expr->value.character.string[start - 1];
+
+   for (i = 0; i <= end - start && i < len; i++)
+     d[i] = c[i];
+
+   /* Pad with spaces. I.e.
+      DATA a(1:2) /'a'/
+      intializes a(1:2) to 'a ' per the rules for assignment.
+      If init == NULL we don't need to do this, as we have
+      intialized the whole string to blanks above.  */
+
+   if (init != NULL)
+     for (; i <= end - start; i++)
+       d[i] = ' ';
+
+   return;
+ }
+
+ /* Assign the initial value RVALUE to  LVALUE's symbol->value. If the
+    LVALUE already has an initialization, we extend this, otherwise we
+    create a new one.  */

  void
  gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
  {
*************** gfc_assign_data_value (gfc_expr * lvalue
*** 122,133 ****
    mpz_t offset;

    ref = lvalue->ref;
    symbol = lvalue->symtree->n.sym;
    init = symbol->value;
    last_con = NULL;
    mpz_init_set_si (offset, 0);

!   for (ref = lvalue->ref; ref; ref = ref->next)
      {
        /* Use the existing initializer expression if it exists.  Otherwise
           create a new one.  */
--- 201,222 ----
    mpz_t offset;

    ref = lvalue->ref;
+   if (ref != NULL && ref->type == REF_SUBSTRING)
+     {
+       /* No need to go through the for (; ref; ref->next) loop, since
+        a single substring lvalue will only refer to a single
+        substring, and therefore ref->next == NULL.  */
+       assert (ref->next == NULL);
+       assign_substring_data_value (lvalue, rvalue);
+       return;
+     }
+
    symbol = lvalue->symtree->n.sym;
    init = symbol->value;
    last_con = NULL;
    mpz_init_set_si (offset, 0);

!   for (; ref; ref = ref->next)
      {
        /* Use the existing initializer expression if it exists.  Otherwise
           create a new one.  */
*************** gfc_assign_data_value (gfc_expr * lvalue
*** 199,207 ****
            }
          break;

!       case REF_SUBSTRING:
!         gfc_todo_error ("Substring reference in DATA statement");
!
        default:
          abort ();
        }
--- 288,295 ----
            }
          break;

!        /* case REF_SUBSTRING: dealt with separately above. */
!
        default:
          abort ();
        }
Index: testsuite/ChangeLog
===================================================================
RCS file: /cvs/gcc/gcc/gcc/testsuite/ChangeLog,v
retrieving revision 1.3803
diff -c -3 -p -r1.3803 ChangeLog
*** testsuite/ChangeLog 1 Jun 2004 15:12:19 -0000       1.3803
--- testsuite/ChangeLog 2 Jun 2004 11:36:36 -0000
***************
*** 1,3 ****
--- 1,8 ----
+ 2004-06-02  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
+
+       PR fortran/15557
+       * gfortran.fortran-torture/execute/data_3.f90: New testcase.
+
  2004-06-01  Richard Hederson  <rth@redhat.com>

        * g++.dg/template/dependent-expr4.C: Use __builtin_offsetof.
! Check initialization of character variables via the DATA statement
CHARACTER*4 a
CHARACTER*6 b
CHARACTER*2 c
CHARACTER*4 d(2)
CHARACTER*4 e

DATA a(1:2) /'aa'/
DATA a(3:4) /'b'/
DATA b(2:6), c /'AAA', '12345'/
DATA d /2*'1234'/
DATA e(4:4), e(1:3) /'45', '123A'/

IF (a.NE.'aab ') CALL abort()
IF (b.NE.' AAA   ') CALL abort()
IF (c.NE.'12') CALL abort()
IF (d(1).NE.d(2) .OR. d(1).NE.'1234') CALL abort()
IF (e.NE.'1234') CALL abort()
END