[Patch Modified] re: Enable Hollerith constant and character arrayin format tag (take 3).

[Feng Wang <wf_cs at yahoo dot com>]

Handle allocatable array assiged Hollerith constant and more test.

Please remove the diff on trans-io.c in the patch:
http://gcc.gnu.org/ml/fortran/2005-06/msg00475.html
And use this diff attached.

Regression tested on i686-linux.

--- Feng Wang <wf_cs@yahoo.com>写道:

> 1. Change to enable this feature under GFC_STD_LEGACY.
> 2. Fix a bug when matching Hollerith constants.
> 3. More tests.
> 
> Tested on i686-linux with no regression.


Best Regards,
Feng Wang

--
Creative Compiler Research Group,
National University of Defense Technology, China.


	

	
		
___________________________________________________________ 
雅虎免费G邮箱－中国第一绝无垃圾邮件骚扰超大邮箱
http://cn.mail.yahoo.com/?id=77071

! { dg-do run }
! Test Hollerith constant assigned to allocatable array

integer, allocatable :: c (:,:)
character (len = 20) ch
allocate (c(1,2))

c(1,1) = 4H(A4)
c(1,2) = 4H(A5)

write (ch, "(2A4)") c
if (ch .ne. "(A4)(A5)") call abort()
write (ch, c) 'Hello'
if (ch .ne. "Hell") call abort()
write (ch, c (1,2)) 'Hello'
if (ch .ne. "Hello") call abort()
end

! { dg-warning "Hollerith constant" "const" { target *-*-* } 8 }
! { dg-warning "Conversion" "conversion" { target *-*-* } 8 }

! { dg-warning "Hollerith constant" "const" { target *-*-* } 9 }
! { dg-warning "Conversion" "conversion" { target *-*-* } 9 }

! { dg-warning "Non-character in FORMAT tag" "" { target *-*-* } 13 }

! { dg-warning "Non-character in FORMAT tag" "" { target *-*-* } 15 }


Index: trans-io.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-io.c,v
retrieving revision 1.37
diff -c -3 -p -r1.37 trans-io.c
*** trans-io.c	25 Jun 2005 00:40:36 -0000	1.37
--- trans-io.c	1 Jul 2005 09:43:38 -0000
*************** set_parameter_ref (stmtblock_t * block, 
*** 364,369 ****
--- 364,431 ----
    gfc_add_modify_expr (block, tmp, se.expr);
  }
  
+ /* Given an array expr, find its address and length to get a string. If the
+    array is full, the string's address is the address of array's first element
+    and the length is the size of the whole array. If it is an element, the
+    string's address is the element's address and the length is the rest size of
+    the array.
+ */
+ 
+ static void
+ gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
+ {
+   tree tmp;
+   tree array;
+   tree type;
+   tree size;
+   int rank;
+   gfc_symbol *sym;
+ 
+   sym = e->symtree->n.sym;
+   rank = sym->as->rank;
+ 
+   if (e->ref->u.ar.type == AR_FULL)
+     {
+       se->expr = gfc_get_symbol_decl (sym);
+       se->expr = gfc_conv_array_data (se->expr);
+     }
+   else
+     {
+       gfc_conv_expr (se, e);
+     }
+ 
+   array = sym->backend_decl;
+   type = TREE_TYPE (array);
+ 
+   if (GFC_ARRAY_TYPE_P (type))
+     size = GFC_TYPE_ARRAY_SIZE (type);
+   else
+     {
+       gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+       size = gfc_conv_array_stride (array, rank);
+       tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ 		gfc_conv_array_ubound (array, rank),
+ 		gfc_conv_array_lbound (array, rank));
+       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
+ 		gfc_index_one_node);
+       size = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, size);      
+     }
+ 
+   gcc_assert (size);
+ 
+   /* If it is an element, we need the its address and size of the rest.  */
+   if (e->ref->u.ar.type == AR_ELEMENT)
+     {
+       size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
+ 		TREE_OPERAND (se->expr, 1));
+       se->expr = gfc_build_addr_expr (NULL, se->expr);
+     }
+ 
+   tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
+   size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
+ 
+   se->string_length = fold_convert (gfc_charlen_type_node, size);
+ }
  
  /* Generate code to store a string and its length into the
     ioparm structure.  */
*************** set_string (stmtblock_t * block, stmtblo
*** 400,406 ****
      }
    else
      {
!       gfc_conv_expr (&se, e);
        gfc_conv_string_parameter (&se);
        gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
        gfc_add_modify_expr (&se.pre, len, se.string_length);
--- 462,474 ----
      }
    else
      {
!       /* General character.  */
!       if (e->ts.type == BT_CHARACTER && e->rank == 0)
! 	gfc_conv_expr (&se, e);
!       /* Array assigned Hollerith constant or character array.  */
!       else if (e->symtree && (e->symtree->n.sym->as->rank > 0))
! 	gfc_convert_array_to_string (&se, e);
! 
        gfc_conv_string_parameter (&se);
        gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
        gfc_add_modify_expr (&se.pre, len, se.string_length);
*************** set_string (stmtblock_t * block, stmtblo
*** 408,414 ****
  
    gfc_add_block_to_block (block, &se.pre);
    gfc_add_block_to_block (postblock, &se.post);
- 
  }
  
  
--- 476,481 ----