[Bug fortran/31608] wrong types in character array/scalar binop

["pault at gcc dot gnu dot org" <gcc-bugzilla at gcc dot gnu dot org>]

------- Comment #28 from pault at gcc dot gnu dot org  2007-10-10 15:44 -------
The patch below fixes the lot.  It was not necessary in the end to touch
trans-intrinsic.c.  Once the appropriate, offending bit of trans-array.c was
fixed, all the casting occurred correctly.  The fixes to iresolve.c deal with
the various ICEing testcases in the comments below and are partially based on
FX's input.

This now compiles an runs correctly.

  character(len=1) :: string = "z"
  integer :: i(1) = (/100/)
  print *, Up("abc")
  print *, transfer(((transfer(string,"x",1))), "x",1)
  print *, transfer(char(i), "x")
  print *, Upper ("abcdefg")
 contains
  Character (len=20) Function Up (string)
    Character(len=*) string
    character(1) :: chr
    Up = transfer(achar(iachar(transfer(string,chr,1))), "x")
    return
  end function Up
  Character (len=20) Function Upper (string)
    Character(len=*) string
    Upper =                                                                &
     transfer(merge(transfer(string,"x",len(string)),    &
       string, .true.), "x")
    return
  end function Upper
end

and the code in achar, which Richard flagged up has become:

            char char.6;

            char.6 = (*(char[0:][1:1] *) atmp.3.data)[S.5][1]{lb: 1 sz: 1};
            (*(char[0:][1:1] *) atmp.4.data)[S.5][1]{lb: 1 sz: 1} = char.6;

The patch even regtests but I will check tonto and cp2k before submitting.

Cheers

Paul

Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c   (révision 129121)
--- gcc/fortran/trans-array.c   (copie de travail)
*************** gfc_conv_expr_descriptor (gfc_se * se, g
*** 4711,4717 ****
        gfc_add_block_to_block (&block, &rse.pre);
        gfc_add_block_to_block (&block, &lse.pre);

!       gfc_add_modify_expr (&block, lse.expr, rse.expr);

        /* Finish the copying loops.  */
        gfc_trans_scalarizing_loops (&loop, &block);
--- 4711,4725 ----
        gfc_add_block_to_block (&block, &rse.pre);
        gfc_add_block_to_block (&block, &lse.pre);

!       if (TREE_CODE (rse.expr) != INDIRECT_REF)
!       {
!         lse.string_length = rse.string_length;
!         tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true,
!                                 expr->expr_type == EXPR_VARIABLE);
!         gfc_add_expr_to_block (&block, tmp);
!       }
!       else
!       gfc_add_modify_expr (&block, lse.expr, rse.expr);

        /* Finish the copying loops.  */
        gfc_trans_scalarizing_loops (&loop, &block);
Index: gcc/fortran/iresolve.c
===================================================================
*** gcc/fortran/iresolve.c      (révision 129121)
--- gcc/fortran/iresolve.c      (copie de travail)
*************** gfc_get_string (const char *format, ...)
*** 62,75 ****
  static void
  check_charlen_present (gfc_expr *source)
  {
!   if (source->expr_type == EXPR_CONSTANT && source->ts.cl == NULL)
      {
        source->ts.cl = gfc_get_charlen ();
        source->ts.cl->next = gfc_current_ns->cl_list;
        gfc_current_ns->cl_list = source->ts.cl;
        source->ts.cl->length = gfc_int_expr (source->value.character.length);
        source->rank = 0;
      }
  }

  /* Helper function for resolving the "mask" argument.  */
--- 62,85 ----
  static void
  check_charlen_present (gfc_expr *source)
  {
!   if (source->ts.cl == NULL)
      {
        source->ts.cl = gfc_get_charlen ();
        source->ts.cl->next = gfc_current_ns->cl_list;
        gfc_current_ns->cl_list = source->ts.cl;
+     }
+
+   if (source->expr_type == EXPR_CONSTANT)
+     {
        source->ts.cl->length = gfc_int_expr (source->value.character.length);
        source->rank = 0;
      }
+   else if (source->expr_type == EXPR_ARRAY)
+     {
+       source->ts.cl->length =
+       gfc_int_expr (source->value.constructor->expr->value.character.length);
+       source->rank = 1;
+     }
  }

  /* Helper function for resolving the "mask" argument.  */
*************** gfc_resolve_access (gfc_expr *f, gfc_exp
*** 132,139 ****
  }


! void
! gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
  {
    f->ts.type = BT_CHARACTER;
    f->ts.kind = (kind == NULL)
--- 142,150 ----
  }


! static void
! gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind,
!                       const char *name)
  {
    f->ts.type = BT_CHARACTER;
    f->ts.kind = (kind == NULL)
*************** gfc_resolve_achar (gfc_expr *f, gfc_expr
*** 143,155 ****
    gfc_current_ns->cl_list = f->ts.cl;
    f->ts.cl->length = gfc_int_expr (1);

!   f->value.function.name = gfc_get_string ("__achar_%d_%c%d", f->ts.kind,
                                           gfc_type_letter (x->ts.type),
                                           x->ts.kind);
  }


  void
  gfc_resolve_acos (gfc_expr *f, gfc_expr *x)
  {
    f->ts = x->ts;
--- 154,173 ----
    gfc_current_ns->cl_list = f->ts.cl;
    f->ts.cl->length = gfc_int_expr (1);

!   f->value.function.name = gfc_get_string (name, f->ts.kind,
                                           gfc_type_letter (x->ts.type),
                                           x->ts.kind);
  }


  void
+ gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
+ {
+   gfc_resolve_char_achar (f, x, kind, "__achar_%d_%c%d");
+ }
+
+
+ void
  gfc_resolve_acos (gfc_expr *f, gfc_expr *x)
  {
    f->ts = x->ts;
*************** gfc_resolve_ceiling (gfc_expr *f, gfc_ex
*** 379,390 ****
  void
  gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
  {
!   f->ts.type = BT_CHARACTER;
!   f->ts.kind = (kind == NULL)
!            ? gfc_default_character_kind : mpz_get_si (kind->value.integer);
!   f->value.function.name
!     = gfc_get_string ("__char_%d_%c%d", f->ts.kind,
!                     gfc_type_letter (a->ts.type), a->ts.kind);
  }


--- 397,403 ----
  void
  gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
  {
!   gfc_resolve_char_achar (f, a, kind, "__char_%d_%c%d");
  }


*************** gfc_resolve_transfer (gfc_expr *f, gfc_e
*** 2269,2274 ****
--- 2282,2290 ----
  {
    /* TODO: Make this do something meaningful.  */
    static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
+
+   if (mold->ts.type == BT_CHARACTER && !mold->ts.cl->length)
+     mold->ts.cl->length = gfc_int_expr (mold->value.character.length);

    f->ts = mold->ts;


-- 

pault at gcc dot gnu dot org changed:

           What    |Removed                     |Added
----------------------------------------------------------------------------
         AssignedTo|unassigned at gcc dot gnu   |pault at gcc dot gnu dot org
                   |dot org                     |
             Status|NEW                         |ASSIGNED
   Last reconfirmed|2007-10-05 17:41:43         |2007-10-10 15:45:00
               date|                            |


http://gcc.gnu.org/bugzilla/show_bug.cgi?id=31608