diff mbox

[Fortran] PR 44352: Fix String-assigning ICE with statement functions

Message ID 4CFE7107.2070503@net-b.de
State New
Headers show

Commit Message

Tobias Burnus Dec. 7, 2010, 5:38 p.m. UTC 
On 12/07/2010 02:23 PM, Dominique Dhumieres wrote:
> The patch fixes the ICEs I get with the different avatars in pr44352.
> It passed my tests and the testsuite. However the test in comment#8
>
> +      dname(c) =   'h810 e=0.01         '
>
> gives the following error
> pr44352_2_db.f90:5:0: error: size of variable 'c.0' is too large

The problem was: If the variable "c" is never used (outside the 
statement function), the backend declaration for the string length of 
the dummy argument "c" is NULL_TREE. Solution: One needs to set the 
string length explicitly. (Note: In statement functions, the string 
length must be a constant.)

Additionally, during testing, I got an ICE for "dest" in the same way as 
I got one for "src" before. (Same solution: pointer check.) And  as one 
already does a gfc_build_addr_expr in gfc_trans_string_copy, I removed 
the the additional call from gfc_conv_statement_function.

Overview about the gfc_conv_statement_function changes:
- Moved "gfc_typenode_for_spec" into the if-else
- set fsym->ts.u.cl->backend_decl
- do not set "tmp" in the "if" branch but use temp_vars[n] directly.
(Plus several space-to-tab changes.)

Build on x86-64-linux.
OK for 4.4, 4.5 and the trunk?

Tobias

Comments

Paul Richard Thomas Dec. 7, 2010, 6:55 p.m. UTC | #1 
Tobias,

> Build on x86-64-linux.
> OK for 4.4, 4.5 and the trunk?
>

Yes, of course.  OK for 4.4-4.6

+	  arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
will do great things for deferred length characters :-)

Thanks

Paul
Tobias Burnus Dec. 7, 2010, 9:03 p.m. UTC | #2 
Paul Richard Thomas wrote:
>> Build on x86-64-linux.
>> OK for 4.4, 4.5 and the trunk
> Yes, of course.  OK for 4.4-4.6
Thanks. Trunk commit: Rev. 167569.

> +	  arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
> will do great things for deferred length characters :-)

:-)   Talking about allocatables: Maybe you should first add allocatable 
scalars before you continue to struggle on with deferred-length characters.

Regarding the code snipped above: one convenient thing about statement 
functions is:

"C423 (R420) The length specied for a character statement function or 
for a statement function dummy argument of type character shall be a 
constant expression."

Tobias
diff mbox

Patch

2010-12-07  Tobias Burnus  <burnus@net-b.de>

	PR fortran/44352
	* trans-expr.c (gfc_string_to_single_character): Return if not
	POINTER_TYPE_P.
	(gfc_trans_string_copy): gfc_build_addr_expr if src or dest is
	not a pointer.
	(gfc_trans_string_copy): Make sure the argument string type
	has a string length, fix indention, and remove not needed
	gfc_build_addr_expr.

2010-12-07  Tobias Burnus  <burnus@net-b.de>

	PR fortran/44352
	* gfortran.dg/string_4.f90: New.


diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 46f80f7..72a7c2c 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1438,9 +1438,9 @@  gfc_conv_expr_op (gfc_se * se, gfc_expr * expr)
 tree
 gfc_string_to_single_character (tree len, tree str, int kind)
 {
-  gcc_assert (POINTER_TYPE_P (TREE_TYPE (str)));
 
-  if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0)
+  if (!INTEGER_CST_P (len) || TREE_INT_CST_HIGH (len) != 0
+      || !POINTER_TYPE_P (TREE_TYPE (str)))
     return NULL_TREE;
 
   if (TREE_INT_CST_LOW (len) == 1)
@@ -3826,12 +3826,12 @@  gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest,
 			  fold_convert (size_type_node,
 					TYPE_SIZE_UNIT (chartype)));
 
-  if (dlength)
+  if (dlength && POINTER_TYPE_P (TREE_TYPE (dest)))
     dest = fold_convert (pvoid_type_node, dest);
   else
     dest = gfc_build_addr_expr (pvoid_type_node, dest);
 
-  if (slength)
+  if (slength && POINTER_TYPE_P (TREE_TYPE (src)))
     src = fold_convert (pvoid_type_node, src);
   else
     src = gfc_build_addr_expr (pvoid_type_node, src);
@@ -3906,35 +3906,42 @@  gfc_conv_statement_function (gfc_se * se, gfc_expr * expr)
       gcc_assert (fargs->sym->attr.dimension == 0);
       fsym = fargs->sym;
 
-      /* Create a temporary to hold the value.  */
-      type = gfc_typenode_for_spec (&fsym->ts);
-      temp_vars[n] = gfc_create_var (type, fsym->name);
-
       if (fsym->ts.type == BT_CHARACTER)
         {
 	  /* Copy string arguments.  */
-          tree arglen;
+	  tree arglen;
 
-          gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
+	  gcc_assert (fsym->ts.u.cl && fsym->ts.u.cl->length
 		      && fsym->ts.u.cl->length->expr_type == EXPR_CONSTANT);
 
-          arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
-          tmp = gfc_build_addr_expr (build_pointer_type (type),
-				     temp_vars[n]);
+	  /* Create a temporary to hold the value.  */
+          if (fsym->ts.u.cl->backend_decl == NULL_TREE)
+	     fsym->ts.u.cl->backend_decl
+		= gfc_conv_constant_to_tree (fsym->ts.u.cl->length);
 
-          gfc_conv_expr (&rse, args->expr);
-          gfc_conv_string_parameter (&rse);
-          gfc_add_block_to_block (&se->pre, &lse.pre);
-          gfc_add_block_to_block (&se->pre, &rse.pre);
+	  type = gfc_get_character_type (fsym->ts.kind, fsym->ts.u.cl);
+	  temp_vars[n] = gfc_create_var (type, fsym->name);
+
+	  arglen = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+
+	  gfc_conv_expr (&rse, args->expr);
+	  gfc_conv_string_parameter (&rse);
+	  gfc_add_block_to_block (&se->pre, &lse.pre);
+	  gfc_add_block_to_block (&se->pre, &rse.pre);
 
-	  gfc_trans_string_copy (&se->pre, arglen, tmp, fsym->ts.kind,
+	  gfc_trans_string_copy (&se->pre, arglen, temp_vars[n], fsym->ts.kind,
 				 rse.string_length, rse.expr, fsym->ts.kind);
-          gfc_add_block_to_block (&se->pre, &lse.post);
-          gfc_add_block_to_block (&se->pre, &rse.post);
+	  gfc_add_block_to_block (&se->pre, &lse.post);
+	  gfc_add_block_to_block (&se->pre, &rse.post);
         }
       else
         {
           /* For everything else, just evaluate the expression.  */
+
+	  /* Create a temporary to hold the value.  */
+	  type = gfc_typenode_for_spec (&fsym->ts);
+	  temp_vars[n] = gfc_create_var (type, fsym->name);
+
           gfc_conv_expr (&lse, args->expr);
 
           gfc_add_block_to_block (&se->pre, &lse.pre);
--- /dev/null	2010-12-07 08:01:46.759999991 +0100
+++ gcc/gcc/testsuite/gfortran.dg/string_4.f90	2010-12-07 16:51:05.000000000 +0100
@@ -0,0 +1,51 @@ 
+! { dg-do compile }
+! { dg-options "" }
+! (options to disable warnings about statement functions etc.)
+!
+! PR fortran/44352
+!
+! Contributed by Vittorio Zecca
+!
+
+      SUBROUTINE TEST1()
+      implicit real*8 (a-h,o-z)
+      character*32 ddname,stmtfnt1
+      stmtfnt1(x)=   'h810 e=0.01         '
+      ddname=stmtfnt1(0.d0)
+      if (ddname /= "h810 e=0.01") call abort()
+      END
+
+      SUBROUTINE TEST2()
+      implicit none
+      character(2)  :: ddname,stmtfnt2
+      real :: x
+      stmtfnt2(x)=   'x'
+      ddname=stmtfnt2(0.0)
+      if(ddname /= 'x') call abort()
+      END
+
+      SUBROUTINE TEST3()
+      implicit real*8 (a-h,o-z)
+      character*32 ddname,dname
+      character*2 :: c
+      dname(c) = 'h810 e=0.01         '
+      ddname=dname("w ")
+      if (ddname /= "h810 e=0.01") call abort()
+      END
+
+      SUBROUTINE TEST4()
+      implicit real*8 (a-h,o-z)
+      character*32 ddname,dname
+      character*2 :: c
+      dname(c) = 'h810 e=0.01         '
+      c = 'aa'
+      ddname=dname("w ")
+      if (ddname /= "h810 e=0.01") call abort()
+      if (c /= "aa") call abort()
+      END
+
+      call test1()
+      call test2()
+      call test3()
+      call test4()
+      end