This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[fortran,patch]Enable Hollerith constant and character array in format tag (2nd).


I rewrite the patch I posted on:
http://gcc.gnu.org/ml/fortran/2005-03/msg00502.html

Add the document of Hollerith constants in 
gfortran.texi as the extention support of gfortran. In 
my implementation, the Hollerith constants can be used 
as the right hands in the DATA statement and ASSIGN 
statement, also as the arguments. The left hands can 
be of Integer, Real, Complex and Logical type. The 
constant will be padded or trancated to fit the size 
of left hand.

To deal with the calculatation of Hollerith constants, 
I leave it to the run-time. See eval_intrinsic() in 
arith.c and do_simplify() in intrinsics.c.

I find only one Hollerith constant test in g77 
testsuites named cpp2.F. I ported to gfortran and 
attached here. The other three tests attached check 
almost all the patch.

The patch is tested with no regression on i686.

Many thanks to Richard E Maine, Steven B, Steve Kargl, 
Paul B, etc. for discussion this topic on the list.

Best Regards,
Feng Wang

fortran/ChangeLog entry:
2005-05-24  Feng Wang  <fengwang@nudt.edu.cn>

	PR fortran/16531
	PR fortran/15966
	PR fortran/18781
	* arith.c (gfc_hollerith2int, 
gfc_hollerith2real,
	gfc_hollerith2complex, 
gfc_hollerith2character, gfc_hollerith2logical):
	New functions.
	(eval_intrinsic): Don't evaluate if Hollerith 
constant arguments exist.
	* arith.h (gfc_hollerith2int, 
gfc_hollerith2real,
	gfc_hollerith2complex, 
gfc_hollerith2character, gfc_hollerith2logical):
	Add prototypes.
	* expr.c (free_expr0): Free memery allocated 
for Hollerith constant.
	(gfc_copy_expr): Allocate and copy string if 
Expr is from Hollerith.
	(gfc_check_assign): Enable conversion from 
Hollerith to other.
	* gfortran.h (bt): Add BT_HOLLERITH.
	(gfc_expr): Add from_H flag.
	* intrinsic.c (gfc_type_letter): Return 'h' 
for BT_HOLLERITH.
	(add_conversions): Add conversions from 
Hollerith constant to other.
	(do_simplify): Don't simplify if  Hollerith 
constant arguments exist.
	* io.c (resolve_tag): Enable array in FORMAT 
tag under GFC_STD_GNU.
	* misc.c (gfc_basetype_name): 
Return "HOLLERITH" for BT_HOLLERITH.
	(gfc_type_name): Print "HOLLERITH" for 
BT_HOLLERITH.
	* primary.c (match_hollerith_constant): New 
function.
	(gfc_match_literal_constant): Add match 
Hollerith before Integer.
	* simplify.c (gfc_convert_constant): Add 
conversion from Hollerith
	to other.
	* trans-const.c (gfc_conv_constant_to_tree): 
Use VIEW_CONVERT_EXPR to
	convert Hollerith constant to tree.
	* trans-io.c (gfc_convert_array_to_string): 
Get array's address and
	length to set string expr.
	(set_string): Deal with array assigned 
Hollerith constant and character
	array.
	* gfortran.texi: Document Hollerith constants 
as extention support.

libgfortran/ChangeLog entry:
2005-05-24  Feng Wang  <fengwang@nudt.edu.cn>

	PR fortran/16531
	* io/transfer.c (formatted_transfer): Enable 
FMT_A on other types.

--
Creative Compiler Research Group,
National University of Defense Technology, China.
C The preprocessor must not mangle Hollerith constants
C which contain apostrophes.
      integer i
      character*4 j
      data i /4hbla'/ ! { dg-warning "Hollerith constant" }
      write (j, '(4a)') i
      if
! { dg-do run }
! PR15966, PR18781 & PR16531
implicit none
complex*16 x(2) 
complex*8 a(2,2)
character*4 z
character z1(4)
character*4 z2(2,2)
character*80 line
integer*4 i
logical*4 l
real*4 r
complex*8 c

data x /16Habcdefghijklmnop, 16Hqrstuvwxyz012345/! { dg-warning "Hollerith" } 
data a /8H(i3),abc,0,4H(i4),8H    (i9)/! { dg-warning "Hollerith constant" }
data z/4h(i5)/! { dg-warning "Hollerith constant" }
data z1/1h(,1hi,1h6,1h)/! { dg-warning "Hollerith constant" }
data z2/4h(i7),'xxxx','xxxx','xxxx'/! { dg-warning "Hollerith constant" }

z2 (1,2) = 4h(i8)! { dg-warning "Hollerith constant" }
i = 4hHell ! { dg-warning "Hollerith constant" }
l = 4Ho wo ! { dg-warning "Hollerith constant" }
r = 4Hrld! ! { dg-warning "Hollerith constant" }
write (line, '(3A4)') i, l, r
if (line .ne. 'Hello world!') call abort

i = 2Hab  ! { dg-warning "Hollerith constant" }
r = 2Hab  ! { dg-warning "Hollerith constant" }
l = 2Hab  ! { dg-warning "Hollerith constant" }
c = 2Hab  ! { dg-warning "Hollerith constant" }
write (line, '(3A4, 8A)') i, l, r, c
if (line .ne. 'ab  ab  ab  ab      ') call abort

write( line, '(4A8, "!")' ) x
if (line .ne. 'abcdefghijklmnopqrstuvwxyz012345!') call abort

write (line, a) 3  ! { dg-warning "Extension: Non-character in FORMAT tag" }
if (line .ne. '  3') call abort
write (line, a (1,2)) 4  ! { dg-warning "Extension: Non-character in FORMAT" }
if (line .ne. '   4') call abort
write (line, z) 5
if (line .ne. '    5') call abort
write (line, z1) 6
if (line .ne. '     6') call abort
write (line, z2) 7 ! { dg-warning " Extension: Character array in FORMAT tag" }
if (line .ne. '      7') call abort
write (line, z2 (1,2)) 8
if (line .ne. '       8') call abort
write (line, '(16A)') z2
if (line .ne. '(i7)xxxx(i8)xxxx') call abort
call test (8h   hello) ! { dg-warning "Hollerith constant" }
end

subroutine test (h)
integer*8 h
character*80 line

write (line, '(8a)') h
if (line .ne. '   hello') call abort
end subroutine
       ! { dg-do run }
       ! Program to test Hollerith constant.
       Program test
       implicit none
       integer* 4 i
       real r, x, y
       parameter (r = 4hdead) ! { dg-warning "Hollerith constant" }
       parameter (y = 4*r)
       data i/5H12345/ ! { dg-warning "Hollerith constant" "too long" }
       x = 5H12345 ! { dg-warning "Hollerith constant" "too long" }
       x = sin(r)
       x = x * r
       x = x / r
       x = x + r
       x = x - r
       end

       ! { dg-do compile }
       ! Program to test invalid Hollerith constant.
       Program test
       implicit none
       integer i
       i = 0H ! { dg-error "Invalid" "at least one character" }
       i = 4_8H1234 ! { dg-error "Invalid" "should be default" }
       end
? lib.diff
Index: transfer.c
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/io/transfer.c,v
retrieving revision 1.41
diff -c -3 -p -r1.41 transfer.c
*** transfer.c	17 May 2005 16:54:51 -0000	1.41
--- transfer.c	24 May 2005 14:41:10 -0000
*************** formatted_transfer (bt type, void *p, in
*** 524,531 ****
  	case FMT_A:
  	  if (n == 0)
  	    goto need_data;
- 	  if (require_type (BT_CHARACTER, type, f))
- 	    return;
  
  	  if (g.mode == READING)
  	    read_a (f, p, len);
--- 524,529 ----
? hollerith_v10.diff
? hollerith_v8.diff
? hollerith_v9.diff
Index: arith.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/arith.c,v
retrieving revision 1.26
diff -c -3 -p -r1.26 arith.c
*** arith.c	14 Apr 2005 16:29:31 -0000	1.26
--- arith.c	24 May 2005 12:54:17 -0000
*************** eval_intrinsic (gfc_intrinsic_op operato
*** 1549,1565 ****
    if (operator == INTRINSIC_POWER && op2->ts.type != BT_INTEGER)
      goto runtime;
  
!   if (op1->expr_type != EXPR_CONSTANT
!       && (op1->expr_type != EXPR_ARRAY
! 	  || !gfc_is_constant_expr (op1)
! 	  || !gfc_expanded_ac (op1)))
      goto runtime;
  
    if (op2 != NULL
!       && op2->expr_type != EXPR_CONSTANT
!       && (op2->expr_type != EXPR_ARRAY
! 	  || !gfc_is_constant_expr (op2)
! 	  || !gfc_expanded_ac (op2)))
      goto runtime;
  
    if (unary)
--- 1549,1567 ----
    if (operator == INTRINSIC_POWER && op2->ts.type != BT_INTEGER)
      goto runtime;
  
!   if (op1->from_H
!       || (op1->expr_type != EXPR_CONSTANT
! 	  && (op1->expr_type != EXPR_ARRAY
! 	    || !gfc_is_constant_expr (op1)
! 	    || !gfc_expanded_ac (op1))))
      goto runtime;
  
    if (op2 != NULL
!       && (op2->from_H
! 	|| (op2->expr_type != EXPR_CONSTANT
! 	  && (op2->expr_type != EXPR_ARRAY
! 	    || !gfc_is_constant_expr (op2)
! 	    || !gfc_expanded_ac (op2)))))
      goto runtime;
  
    if (unary)
*************** gfc_log2log (gfc_expr * src, int kind)
*** 2158,2160 ****
--- 2160,2319 ----
  
    return result;
  }
+ 
+ /* Convert Hollerith to integer. The constant will be padded or truncated.  */
+ 
+ gfc_expr *
+ gfc_hollerith2int (gfc_expr * src, int kind)
+ {
+   gfc_expr *result;
+   int len;
+ 
+   len = src->value.character.length;
+ 
+   result = gfc_get_expr ();
+   result->expr_type = EXPR_CONSTANT;
+   result->ts.type = BT_INTEGER;
+   result->ts.kind = kind;
+   result->where = src->where;
+   result->from_H = 1;
+ 
+   if (len > kind)
+     {
+       gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
+ 		&src->where, gfc_typename(&result->ts));
+     }
+   result->value.character.string = gfc_getmem (kind + 1);
+   memcpy (result->value.character.string, src->value.character.string,
+ 	MIN (kind, len));
+ 
+   if (len < kind)
+     memset (&result->value.character.string[len], ' ', kind - len);
+ 
+   result->value.character.string[kind] = '\0'; /* For debugger */
+   result->value.character.length = kind;
+ 
+   return result;
+ }
+ 
+ /* Convert Hollerith to real. The constant will be padded or truncated.  */
+ 
+ gfc_expr *
+ gfc_hollerith2real (gfc_expr * src, int kind)
+ {
+   gfc_expr *result;
+   int len;
+ 
+   len = src->value.character.length;
+ 
+   result = gfc_get_expr ();
+   result->expr_type = EXPR_CONSTANT;
+   result->ts.type = BT_REAL;
+   result->ts.kind = kind;
+   result->where = src->where;
+   result->from_H = 1;
+ 
+   if (len > kind)
+     {
+       gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
+ 		&src->where, gfc_typename(&result->ts));
+     }
+   result->value.character.string = gfc_getmem (kind + 1);
+   memcpy (result->value.character.string, src->value.character.string,
+ 	MIN (kind, len));
+ 
+   if (len < kind)
+     memset (&result->value.character.string[len], ' ', kind - len);
+ 
+   result->value.character.string[kind] = '\0'; /* For debugger */
+   result->value.character.length = kind;
+ 
+   return result;
+ }
+ 
+ /* Convert Hollerith to complex. The constant will be padded or truncated.  */
+ 
+ gfc_expr *
+ gfc_hollerith2complex (gfc_expr * src, int kind)
+ {
+   gfc_expr *result;
+   int len;
+ 
+   len = src->value.character.length;
+ 
+   result = gfc_get_expr ();
+   result->expr_type = EXPR_CONSTANT;
+   result->ts.type = BT_COMPLEX;
+   result->ts.kind = kind;
+   result->where = src->where;
+   result->from_H = 1;
+ 
+   kind = kind * 2;
+ 
+   if (len > kind)
+     {
+       gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
+ 		&src->where, gfc_typename(&result->ts));
+     }
+   result->value.character.string = gfc_getmem (kind + 1);
+   memcpy (result->value.character.string, src->value.character.string,
+ 	MIN (kind, len));
+ 
+   if (len < kind)
+     memset (&result->value.character.string[len], ' ', kind - len);
+ 
+   result->value.character.string[kind] = '\0'; /* For debugger */
+   result->value.character.length = kind;
+ 
+   return result;
+ }
+ 
+ /* Convert Hollerith to character. */
+ 
+ gfc_expr *
+ gfc_hollerith2character (gfc_expr * src, int kind)
+ {
+   gfc_expr *result;
+ 
+   result = gfc_copy_expr (src);
+   result->ts.type = BT_CHARACTER;
+   result->ts.kind = kind;
+   result->from_H = 1;
+ 
+   return result;
+ }
+ 
+ /* Convert Hollerith to logical. The constant will be padded or truncated.  */
+ 
+ gfc_expr *
+ gfc_hollerith2logical (gfc_expr * src, int kind)
+ {
+   gfc_expr *result;
+   int len;
+ 
+   len = src->value.character.length;
+ 
+   result = gfc_get_expr ();
+   result->expr_type = EXPR_CONSTANT;
+   result->ts.type = BT_LOGICAL;
+   result->ts.kind = kind;
+   result->where = src->where;
+   result->from_H = 1;
+ 
+   if (len > kind)
+     {
+       gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
+ 		&src->where, gfc_typename(&result->ts));
+     }
+   result->value.character.string = gfc_getmem (kind + 1);
+   memcpy (result->value.character.string, src->value.character.string,
+ 	MIN (kind, len));
+ 
+   if (len < kind)
+     memset (&result->value.character.string[len], ' ', kind - len);
+ 
+   result->value.character.string[kind] = '\0'; /* For debugger */
+   result->value.character.length = kind;
+ 
+   return result;
+ }
Index: arith.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/arith.h,v
retrieving revision 1.4
diff -c -3 -p -r1.4 arith.h
*** arith.h	6 Aug 2004 20:36:04 -0000	1.4
--- arith.h	24 May 2005 12:54:17 -0000
*************** gfc_expr *gfc_complex2int (gfc_expr *, i
*** 80,85 ****
--- 80,90 ----
  gfc_expr *gfc_complex2real (gfc_expr *, int);
  gfc_expr *gfc_complex2complex (gfc_expr *, int);
  gfc_expr *gfc_log2log (gfc_expr *, int);
+ gfc_expr *gfc_hollerith2int (gfc_expr *, int);
+ gfc_expr *gfc_hollerith2real (gfc_expr *, int);
+ gfc_expr *gfc_hollerith2complex (gfc_expr *, int);
+ gfc_expr *gfc_hollerith2character (gfc_expr *, int);
+ gfc_expr *gfc_hollerith2logical (gfc_expr *, int);
  
  #endif /* GFC_ARITH_H  */
  
Index: expr.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/expr.c,v
retrieving revision 1.25
diff -c -3 -p -r1.25 expr.c
*** expr.c	6 Apr 2005 18:03:04 -0000	1.25
--- expr.c	24 May 2005 12:54:19 -0000
*************** free_expr0 (gfc_expr * e)
*** 141,146 ****
--- 141,152 ----
    switch (e->expr_type)
      {
      case EXPR_CONSTANT:
+       if (e->from_H)
+ 	{
+ 	  gfc_free (e->value.character.string);
+ 	  break;
+ 	}
+ 
        switch (e->ts.type)
  	{
  	case BT_INTEGER:
*************** free_expr0 (gfc_expr * e)
*** 152,157 ****
--- 158,164 ----
  	  break;
  
  	case BT_CHARACTER:
+ 	case BT_HOLLERITH:
  	  gfc_free (e->value.character.string);
  	  break;
  
*************** gfc_copy_expr (gfc_expr * p)
*** 393,398 ****
--- 400,414 ----
        break;
  
      case EXPR_CONSTANT:
+       if (p->from_H)
+ 	{
+ 	  s = gfc_getmem (p->value.character.length + 1);
+ 	  q->value.character.string = s;
+ 
+ 	  memcpy (s, p->value.character.string,
+ 		  p->value.character.length + 1);
+ 	  break;
+ 	}
        switch (q->ts.type)
  	{
  	case BT_INTEGER:
*************** gfc_copy_expr (gfc_expr * p)
*** 414,419 ****
--- 430,436 ----
  	  break;
  
  	case BT_CHARACTER:
+ 	case BT_HOLLERITH:
  	  s = gfc_getmem (p->value.character.length + 1);
  	  q->value.character.string = s;
  
*************** gfc_check_assign (gfc_expr * lvalue, gfc
*** 1813,1819 ****
  
    if (!conform)
      {
!       if (gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
  	return SUCCESS;
  
        if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
--- 1830,1839 ----
  
    if (!conform)
      {
!       /* Numeric can be converted to any other numeric. And Hollerith can be
! 	 converted to any other type.  */
!       if ((gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
! 	|| rvalue->ts.type == BT_HOLLERITH)
  	return SUCCESS;
  
        if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
Index: gfortran.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/gfortran.h,v
retrieving revision 1.69
diff -c -3 -p -r1.69 gfortran.h
*** gfortran.h	10 May 2005 22:06:43 -0000	1.69
--- gfortran.h	24 May 2005 12:54:22 -0000
*************** gfc_source_form;
*** 126,132 ****
  
  typedef enum
  { BT_UNKNOWN = 1, BT_INTEGER, BT_REAL, BT_COMPLEX,
!   BT_LOGICAL, BT_CHARACTER, BT_DERIVED, BT_PROCEDURE
  }
  bt;
  
--- 126,132 ----
  
  typedef enum
  { BT_UNKNOWN = 1, BT_INTEGER, BT_REAL, BT_COMPLEX,
!   BT_LOGICAL, BT_CHARACTER, BT_DERIVED, BT_PROCEDURE, BT_HOLLERITH
  }
  bt;
  
*************** typedef struct gfc_expr
*** 1065,1070 ****
--- 1065,1073 ----
  
    locus where;
  
+   /* True if it is converted from Hollerith constant.  */
+   unsigned int from_H : 1;
+ 
    union
    {
      int logical;
Index: gfortran.texi
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/gfortran.texi,v
retrieving revision 1.13
diff -c -3 -p -r1.13 gfortran.texi
*** gfortran.texi	23 May 2005 03:20:19 -0000	1.13
--- gfortran.texi	24 May 2005 12:54:29 -0000
*************** meaning.
*** 630,635 ****
--- 630,636 ----
  * Hexadecimal constants::
  * Real array indices::
  * Unary operators::
+ * Hollerith constants support::
  @end menu
  
  @node Old-style kind specifications
*************** operators without the need for parenthes
*** 786,791 ****
--- 787,821 ----
         X = Y * -Z
  @end smallexample
  
+ @node Hollerith constants support
+ @section Hollerith constants support
+ @cindex Hollerith constants
+ 
+ A Hollerith constant is a string of characters preceded by the letter @samp{H}
+ or @samp{h}, and there must be an literal, unsigned, nonzero default integer
+ constant indicating the number of characters in the string. Hollerith constants
+ are stored as byte strings, one character per byte.
+ 
+ @command{gfortran} supports Hollerith constants. They can be used as the right
+ hands in the @code{DATA} statement and @code{ASSIGN} statement, also as the
+ arguments. The left hands can be of Integer, Real, Complex and Logical type.
+ The constant will be padded or trancated to fit the size of left hand.
+ 
+ Valid Hollerith constants examples:
+ @smallexample
+ complex*16 x(2)
+ data x /16Habcdefghijklmnop, 16Hqrstuvwxyz012345/
+ call foo (4H abc)
+ x(1) = 16Habcdefghijklmnop
+ @end smallexample
+ 
+ Invalid Hollerith constants examples:
+ @smallexample
+ integer*4 a
+ a = 8H12345678 ! The Hollerith constant is too long. It will be truncated.
+ a = 0H         ! At least one character needed.
+ @end smallexample
+ 
  @include intrinsic.texi
  @c ---------------------------------------------------------------------
  @c Contributing
Index: intrinsic.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/intrinsic.c,v
retrieving revision 1.46
diff -c -3 -p -r1.46 intrinsic.c
*** intrinsic.c	25 Apr 2005 00:08:59 -0000	1.46
--- intrinsic.c	24 May 2005 12:54:33 -0000
*************** gfc_type_letter (bt type)
*** 79,84 ****
--- 79,88 ----
        c = 'c';
        break;
  
+     case BT_HOLLERITH:
+       c = 'h';
+       break;
+ 
      default:
        c = 'u';
        break;
*************** add_conversions (void)
*** 2297,2302 ****
--- 2301,2328 ----
  		  BT_INTEGER, gfc_integer_kinds[i].kind, gfc_convert_constant);
        }
  
+   /* Hollerith-Integer conversions.  */
+   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
+     add_conv (BT_HOLLERITH, gfc_default_character_kind,
+ 		  BT_INTEGER, gfc_integer_kinds[i].kind, gfc_convert_constant);
+   /* Hollerith-Real conversions.  */
+   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+     add_conv (BT_HOLLERITH, gfc_default_character_kind,
+ 		  BT_REAL, gfc_real_kinds[i].kind, gfc_convert_constant);
+   /* Hollerith-Complex conversions.  */
+   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
+     add_conv (BT_HOLLERITH, gfc_default_character_kind,
+ 		  BT_COMPLEX, gfc_real_kinds[i].kind, gfc_convert_constant);
+ 
+   /* Hollerith-Character conversions.  */
+   add_conv (BT_HOLLERITH, gfc_default_character_kind, BT_CHARACTER,
+ 		  gfc_default_character_kind, gfc_convert_constant);
+ 
+   /* Hollerith-Logical conversions.  */
+   for (i = 0; gfc_logical_kinds[i].kind != 0; i++)
+     add_conv (BT_HOLLERITH, gfc_default_character_kind,
+ 		  BT_LOGICAL, gfc_logical_kinds[i].kind, gfc_convert_constant);
+  
    /* Real/Complex - Real/Complex conversions.  */
    for (i = 0; gfc_real_kinds[i].kind != 0; i++)
      for (j = 0; gfc_real_kinds[j].kind != 0; j++)
*************** do_simplify (gfc_intrinsic_sym * specifi
*** 2672,2677 ****
--- 2698,2713 ----
    gfc_expr *result, *a1, *a2, *a3, *a4, *a5;
    gfc_actual_arglist *arg;
  
+   /* Check the arguments if there are Hollerith constants. We deal with
+      them at run-time.  */
+   for (arg = e->value.function.actual; arg != NULL; arg = arg->next)
+     {
+       if (arg->expr && arg->expr->from_H)
+ 	{
+ 	  result = NULL;
+ 	  goto finish;
+ 	}
+     }
    /* Max and min require special handling due to the variable number
       of args.  */
    if (specific->simplify.f1 == gfc_simplify_min)
Index: io.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/io.c,v
retrieving revision 1.22
diff -c -3 -p -r1.22 io.c
*** io.c	11 May 2005 22:32:02 -0000	1.22
--- io.c	24 May 2005 12:54:35 -0000
*************** resolve_tag (const io_tag * tag, gfc_exp
*** 967,975 ****
  
    if (e->ts.type != tag->type)
      {
!       /* Format label can be integer varibale.  */
!       if (tag != &tag_format || e->ts.type != BT_INTEGER)
!         {
            gfc_error ("%s tag at %L must be of type %s", tag->name, &e->where,
  		     gfc_basic_typename (tag->type));
            return FAILURE;
--- 967,974 ----
  
    if (e->ts.type != tag->type)
      {
!       if (tag != &tag_format)
! 	{
            gfc_error ("%s tag at %L must be of type %s", tag->name, &e->where,
  		     gfc_basic_typename (tag->type));
            return FAILURE;
*************** resolve_tag (const io_tag * tag, gfc_exp
*** 978,997 ****
  
    if (tag == &tag_format)
      {
!       if (e->rank != 1 && e->rank != 0)
  	{
! 	  gfc_error ("FORMAT tag at %L cannot be array of strings",
! 		     &e->where);
! 	  return FAILURE;
  	}
!       /* Check assigned label.  */
        if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_INTEGER
! 		&& e->symtree->n.sym->attr.assign != 1)
  	{
! 	  gfc_error ("Variable '%s' has not been assigned a format label at %L",
! 			e->symtree->n.sym->name, &e->where);
  	  return FAILURE;
- 	}
      }
    else
      {
--- 977,1012 ----
  
    if (tag == &tag_format)
      {
!       if (e->rank != 1 && e->rank != 0 && e->ts.type == BT_CHARACTER)
  	{
! 	  if (gfc_notify_std (GFC_STD_GNU,
! 		"Extension: Character array in FORMAT tag at %L", &e->where)
! 	    == FAILURE)
! 	    return FAILURE;
! 	  return SUCCESS;
  	}
!       /* Check assigned variable.  */
        if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_INTEGER
! 		&& e->rank == 0)
  	{
! 	  if (gfc_notify_std (GFC_STD_F95_DEL,
! 		"Obsolete: ASSIGNED variable in FORMAT tag at %L", &e->where)
! 	      == FAILURE)
! 	    return FAILURE;
! 	  if (e->symtree->n.sym->attr.assign != 1)
! 	    {
! 	      gfc_error ("Variable '%s' at %L has not been assigned a format "
! 		"label", e->symtree->n.sym->name, &e->where);
! 	      return FAILURE;
! 	    }
! 	  return SUCCESS;
! 	}
!       /* Check variable or array assigned Hollerith constant maybe.  */
!       if (e->ts.type != BT_CHARACTER
! 	&& gfc_notify_std (GFC_STD_GNU,
! 		 "Extension: Non-character in FORMAT tag at %L", &e->where)
! 	      == FAILURE)
  	  return FAILURE;
      }
    else
      {
Index: misc.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/misc.c,v
retrieving revision 1.8
diff -c -3 -p -r1.8 misc.c
*** misc.c	18 Jan 2005 12:11:53 -0000	1.8
--- misc.c	24 May 2005 12:54:36 -0000
*************** gfc_basic_typename (bt type)
*** 159,164 ****
--- 159,167 ----
      case BT_CHARACTER:
        p = "CHARACTER";
        break;
+     case BT_HOLLERITH:
+       p = "HOLLERITH";
+       break;
      case BT_DERIVED:
        p = "DERIVED";
        break;
*************** gfc_typename (gfc_typespec * ts)
*** 207,212 ****
--- 210,218 ----
      case BT_CHARACTER:
        sprintf (buffer, "CHARACTER(%d)", ts->kind);
        break;
+     case BT_HOLLERITH:
+       sprintf (buffer, "HOLLERITH");
+       break;
      case BT_DERIVED:
        sprintf (buffer, "TYPE(%s)", ts->derived->name);
        break;
Index: primary.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/primary.c,v
retrieving revision 1.25
diff -c -3 -p -r1.25 primary.c
*** primary.c	25 Apr 2005 00:08:59 -0000	1.25
--- primary.c	24 May 2005 12:54:38 -0000
*************** match_integer_constant (gfc_expr ** resu
*** 228,233 ****
--- 228,301 ----
  }
  
  
+ /* Match a Hollerith constant.  */
+ 
+ static match
+ match_hollerith_constant (gfc_expr ** result)
+ {
+   locus old_loc;
+   gfc_expr *e;
+   const char * msg;
+   char * buffer;
+   unsigned int num;
+   unsigned int i;  
+ 
+   old_loc = gfc_current_locus;
+   gfc_gobble_whitespace ();
+ 
+   if (match_integer_constant (&e, 0) == MATCH_YES
+ 	&& gfc_match_char ('h') == MATCH_YES)
+     {
+       if (gfc_notify_std (GFC_STD_GNU,
+ 		"Extention: Hollerith constant at %C")
+ 		== FAILURE)
+ 	goto cleanup;
+ 
+       msg = gfc_extract_int (e, &num);
+       if (msg != NULL)
+ 	{
+ 	  gfc_error (msg);
+ 	  goto cleanup;
+ 	}
+       if (num == 0)
+ 	{
+ 	  gfc_error ("Invalid Hollerith constant: %L must contain at least one "
+ 			"character", &old_loc);
+ 	  goto cleanup;
+ 	}
+       if (e->ts.kind != gfc_default_integer_kind)
+ 	{
+ 	  gfc_error ("Invalid Hollerith constant: Interger kind at %L "
+ 		"should be default", &old_loc);
+ 	  goto cleanup;
+ 	}
+       else
+ 	{
+ 	  buffer = (char *)gfc_getmem (sizeof(char)*num+1);
+ 	  for (i = 0; i < num; i++)
+ 	    {
+ 	      buffer[i] = gfc_next_char_literal (1);
+ 	    }
+ 	  gfc_free_expr (e);
+ 	  e = gfc_constant_result (BT_HOLLERITH,
+ 		gfc_default_character_kind, &gfc_current_locus);
+ 	  e->value.character.string = gfc_getmem (num+1);
+ 	  memcpy (e->value.character.string, buffer, num);
+ 	  e->value.character.length = num;
+ 	  *result = e;
+ 	  return MATCH_YES;
+ 	}
+     }
+  
+   gfc_current_locus = old_loc;
+   return MATCH_NO;
+ 
+ cleanup:
+   gfc_free_expr (e);
+   return MATCH_ERROR;
+ }
+ 
+ 
  /* Match a binary, octal or hexadecimal constant that can be found in
     a DATA statement.  */
  
*************** gfc_match_literal_constant (gfc_expr ** 
*** 1159,1164 ****
--- 1227,1236 ----
    if (m != MATCH_NO)
      return m;
  
+   m = match_hollerith_constant (result);
+   if (m != MATCH_NO)
+     return m;
+ 
    m = match_integer_constant (result, signflag);
    if (m != MATCH_NO)
      return m;
Index: simplify.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/simplify.c,v
retrieving revision 1.25
diff -c -3 -p -r1.25 simplify.c
*** simplify.c	14 Apr 2005 16:29:31 -0000	1.25
--- simplify.c	24 May 2005 12:54:43 -0000
*************** gfc_convert_constant (gfc_expr * e, bt t
*** 3705,3710 ****
--- 3705,3738 ----
        f = gfc_log2log;
        break;
  
+     case BT_HOLLERITH:
+       switch (type)
+ 	{
+ 	case BT_INTEGER:
+ 	  f = gfc_hollerith2int;
+ 	  break;
+ 
+ 	case BT_REAL:
+ 	  f = gfc_hollerith2real;
+ 	  break;
+ 
+ 	case BT_COMPLEX:
+ 	  f = gfc_hollerith2complex;
+ 	  break;
+ 
+ 	case BT_CHARACTER:
+ 	  f = gfc_hollerith2character;
+ 	  break;
+ 
+ 	case BT_LOGICAL:
+ 	  f = gfc_hollerith2logical;
+ 	  break;
+ 
+ 	default:
+ 	  goto oops;
+ 	}
+       break;
+ 
      default:
      oops:
        gfc_internal_error ("gfc_convert_constant(): Unexpected type");
Index: trans-const.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-const.c,v
retrieving revision 1.27
diff -c -3 -p -r1.27 trans-const.c
*** trans-const.c	18 May 2005 09:54:21 -0000	1.27
--- trans-const.c	24 May 2005 12:54:43 -0000
*************** gfc_conv_constant_to_tree (gfc_expr * ex
*** 274,303 ****
  {
    gcc_assert (expr->expr_type == EXPR_CONSTANT);
  
    switch (expr->ts.type)
      {
      case BT_INTEGER:
!       return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
  
      case BT_REAL:
!       return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind);
  
      case BT_LOGICAL:
!       return build_int_cst (gfc_get_logical_type (expr->ts.kind),
  			    expr->value.logical);
  
      case BT_COMPLEX:
!       {
! 	tree real = gfc_conv_mpfr_to_tree (expr->value.complex.r,
  					  expr->ts.kind);
! 	tree imag = gfc_conv_mpfr_to_tree (expr->value.complex.i,
  					  expr->ts.kind);
  
! 	return build_complex (gfc_typenode_for_spec (&expr->ts),
! 			      real, imag);
!       }
  
      case BT_CHARACTER:
        return gfc_build_string_const (expr->value.character.length,
  				     expr->value.character.string);
  
--- 274,331 ----
  {
    gcc_assert (expr->expr_type == EXPR_CONSTANT);
  
+   /* If it is converted from Hollerith constant, we build string constant
+      and VIEW_CONVERT to its type.  */
+  
    switch (expr->ts.type)
      {
      case BT_INTEGER:
!       if (expr->from_H)
! 	return build1 (VIEW_CONVERT_EXPR,
! 			gfc_get_int_type (expr->ts.kind),
! 			gfc_build_string_const (expr->value.character.length,
! 				expr->value.character.string));
!       else
! 	return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
  
      case BT_REAL:
!       if (expr->from_H)
! 	return build1 (VIEW_CONVERT_EXPR,
! 			gfc_get_real_type (expr->ts.kind),
! 			gfc_build_string_const (expr->value.character.length,
! 				expr->value.character.string));
!       else
! 	return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind);
  
      case BT_LOGICAL:
!       if (expr->from_H)
! 	return build1 (VIEW_CONVERT_EXPR,
! 			gfc_get_logical_type (expr->ts.kind),
! 			gfc_build_string_const (expr->value.character.length,
! 				expr->value.character.string));
!       else
! 	return build_int_cst (gfc_get_logical_type (expr->ts.kind),
  			    expr->value.logical);
  
      case BT_COMPLEX:
!       if (expr->from_H)
! 	return build1 (VIEW_CONVERT_EXPR,
! 			gfc_get_complex_type (expr->ts.kind),
! 			gfc_build_string_const (expr->value.character.length,
! 				expr->value.character.string));
!       else
! 	{
! 	  tree real = gfc_conv_mpfr_to_tree (expr->value.complex.r,
  					  expr->ts.kind);
! 	  tree imag = gfc_conv_mpfr_to_tree (expr->value.complex.i,
  					  expr->ts.kind);
  
! 	  return build_complex (gfc_typenode_for_spec (&expr->ts),
! 				real, imag);
! 	}
  
      case BT_CHARACTER:
+     case BT_HOLLERITH:
        return gfc_build_string_const (expr->value.character.length,
  				     expr->value.character.string);
  
Index: trans-io.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-io.c,v
retrieving revision 1.36
diff -c -3 -p -r1.36 trans-io.c
*** trans-io.c	15 May 2005 02:45:29 -0000	1.36
--- trans-io.c	24 May 2005 12:54:46 -0000
*************** set_parameter_ref (stmtblock_t * block, 
*** 364,369 ****
--- 364,420 ----
    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;
+   gfc_array_spec *as;
+   gfc_symbol *sym;
+ 
+   sym = e->symtree->n.sym;
+   as = sym->as;
+ 
+   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);
+   gcc_assert (GFC_ARRAY_TYPE_P (type));
+ 
+   size = GFC_TYPE_ARRAY_SIZE (type);
+   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 (build (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 (build (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
*** 389,395 ****
      {
        gfc_conv_label_variable (&se, e);
        msg =
!         gfc_build_cstring_const ("Assigned label is not a format label");
        tmp = GFC_DECL_STRING_LEN (se.expr);
        tmp = build2 (LE_EXPR, boolean_type_node,
  		    tmp, convert (TREE_TYPE (tmp), integer_minus_one_node));
--- 440,446 ----
      {
        gfc_conv_label_variable (&se, e);
        msg =
! 	gfc_build_cstring_const ("Assigned label is not a format label");
        tmp = GFC_DECL_STRING_LEN (se.expr);
        tmp = build2 (LE_EXPR, boolean_type_node,
  		    tmp, convert (TREE_TYPE (tmp), integer_minus_one_node));
*************** 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);
--- 451,463 ----
      }
    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);
- 
  }
  
  
--- 465,470 ----

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]