This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[fortran, patch] Enable Hollerith constant and character array in format tag.
- From: Feng Wang <wf_cs at yahoo dot com>
- To: fortran at gcc dot gnu dot org, gcc-patches at gcc dot gnu dot org
- Date: Mon, 28 Mar 2005 22:17:33 +0800 (CST)
- Subject: [fortran, patch] Enable Hollerith constant and character array in format tag.
This patch implements Hollerith constant and enable array as format tag
including character array. I know that they are not mentened in Fortran 95
standard. But they are needed in many legacy codes. I marked them as
GFC_STD_GNU.
This patch fixes PR16531, PR15966 and PR18781. Tested on i686-linux and
ia64-linux.
Feng Wang
fortran/ChangeLog entry:
2005-03-28 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): New functions.
* arith.h (gfc_hollerith2int, gfc_hollerith2real,
gfc_hollerith2complex, gfc_hollerith2character): 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.
* 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.
libgfortran/ChangeLog entry:
2005-03-28 Feng Wang <fengwang@nudt.edu.cn>
PR fortran/16531
* io/transfer.c (formatted_transfer): Enable FMT_A on other types.
testsuite/ChangeLog entry:
2005-03-28 Feng Wang <fengwang@nudt.edu.cn>
PR fortran/16531
PR fortran/15966
PR fortran/18781
* gfortran.dg/hollerith.f90: New test.
_________________________________________________________
Do You Yahoo!?
150万曲MP3疯狂搜，带您闯入音乐殿堂
http://music.yisou.com/
美女明星应有尽有，搜遍美图、艳图和酷图
http://image.yisou.com
1G就是1000兆，雅虎电邮自助扩容！
http://cn.rd.yahoo.com/mail_cn/tag/1g/*http://cn.mail.yahoo.com/event/mail_1g/
! { dg-do run }
! { dg-options "-w" }
! 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
data x /16Habcdefghijklmnop, 16Hqrstuvwxyz012345/
data a /8H(i3),abc,0,4H(i4),8H (i9)/
data z/4h(i5)/
data z1/1h(,1hi,1h6,1h)/
data z2/4h(i7),'xxxx','xxxx','xxxx'/
z2 (1,2) = 4h(i8)
write( line, '(4A8, "!")' ) x
if (line .ne. 'abcdefghijklmnopqrstuvwxyz012345!') call abort
write (line, a) 3
if (line .ne. ' 3') call abort
write (line, a (1,2)) 4
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
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
end
Index: arith.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/arith.c,v
retrieving revision 1.25
diff -c -3 -p -r1.25 arith.c
*** arith.c 26 Mar 2005 18:33:53 -0000 1.25
--- arith.c 28 Mar 2005 13:26:47 -0000
*************** gfc_log2log (gfc_expr * src, int kind)
*** 2150,2152 ****
--- 2150,2262 ----
return result;
}
+
+ /* Convert Hollerith to integer. */
+
+ 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));
+ len = kind;
+ }
+ result->value.character.string = gfc_getmem (len + 1);
+ memcpy (result->value.character.string, src->value.character.string, len);
+ result->value.character.string[len] = '\0';
+ result->value.character.length = len;
+
+ return result;
+ }
+
+ /* Convert Hollerith to real. */
+
+ 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));
+ len = kind;
+ }
+ result->value.character.string = gfc_getmem (len + 1);
+ memcpy (result->value.character.string, src->value.character.string, len);
+ result->value.character.string[len] = '\0';
+ result->value.character.length = len;
+
+ return result;
+ }
+
+ /* Convert Hollerith to complex. */
+
+ 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;
+
+ if (len > kind*2)
+ {
+ gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
+ &src->where, gfc_typename(&result->ts));
+ len = kind*2;
+ }
+ result->value.character.string = gfc_getmem (len + 1);
+ memcpy (result->value.character.string, src->value.character.string, len);
+ result->value.character.string[len] = '\0';
+ result->value.character.length = len;
+
+ 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;
+ }
+
+
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 28 Mar 2005 13:26:47 -0000
*************** gfc_expr *gfc_complex2int (gfc_expr *, i
*** 80,85 ****
--- 80,89 ----
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);
#endif /* GFC_ARITH_H */
Index: expr.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/expr.c,v
retrieving revision 1.24
diff -c -3 -p -r1.24 expr.c
*** expr.c 4 Mar 2005 17:09:18 -0000 1.24
--- expr.c 28 Mar 2005 13:26:51 -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
*** 1812,1818 ****
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)
--- 1829,1838 ----
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.62
diff -c -3 -p -r1.62 gfortran.h
*** gfortran.h 22 Mar 2005 22:08:14 -0000 1.62
--- gfortran.h 28 Mar 2005 13:26:54 -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
*** 1060,1065 ****
--- 1060,1068 ----
locus where;
+ /* True if it is converted from Hollerith constant. */
+ unsigned int from_H : 1;
+
union
{
int logical;
Index: intrinsic.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/intrinsic.c,v
retrieving revision 1.45
diff -c -3 -p -r1.45 intrinsic.c
*** intrinsic.c 22 Mar 2005 22:08:14 -0000 1.45
--- intrinsic.c 28 Mar 2005 13:27:07 -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,2323 ----
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);
+
/* 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++)
Index: io.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/io.c,v
retrieving revision 1.20
diff -c -3 -p -r1.20 io.c
*** io.c 15 Mar 2005 02:52:37 -0000 1.20
--- io.c 28 Mar 2005 13:27:12 -0000
*************** resolve_tag (const io_tag * tag, gfc_exp
*** 964,972 ****
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;
--- 964,971 ----
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
*** 975,994 ****
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
{
--- 974,1009 ----
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 28 Mar 2005 13:27:12 -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.24
diff -c -3 -p -r1.24 primary.c
*** primary.c 5 Mar 2005 23:35:44 -0000 1.24
--- primary.c 28 Mar 2005 13:27:24 -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: must contain at least one ",
+ "character");
+ 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.20
diff -c -3 -p -r1.20 simplify.c
*** simplify.c 1 Mar 2005 00:41:17 -0000 1.20
--- simplify.c 28 Mar 2005 13:27:37 -0000
*************** gfc_convert_constant (gfc_expr * e, bt t
*** 3760,3765 ****
--- 3760,3789 ----
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;
+
+ 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.22
diff -c -3 -p -r1.22 trans-const.c
*** trans-const.c 5 Mar 2005 20:14:52 -0000 1.22
--- trans-const.c 28 Mar 2005 13:27:38 -0000
*************** gfc_conv_constant_to_tree (gfc_expr * ex
*** 300,324 ****
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,
--- 300,348 ----
switch (expr->ts.type)
{
case BT_INTEGER:
! /* If it is converted from Hollerith constant, we build string constant
! and VIEW_CONVERT to this type. */
! 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 it is converted from Hollerith constant, we build string constant
! and VIEW_CONVERT to this type. */
! 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:
return build_int_cst (gfc_get_logical_type (expr->ts.kind),
expr->value.logical);
case BT_COMPLEX:
! /* If it is converted from Hollerith constant, we build string constant
! and VIEW_CONVERT to this type. */
! 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:
return gfc_build_string_const (expr->value.character.length,
Index: trans-io.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-io.c,v
retrieving revision 1.34
diff -c -3 -p -r1.34 trans-io.c
*** trans-io.c 15 Mar 2005 02:52:37 -0000 1.34
--- trans-io.c 28 Mar 2005 13:27:43 -0000
*************** set_parameter_ref (stmtblock_t * block,
*** 382,387 ****
--- 382,438 ----
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 = size;
+ }
+
/* Generate code to store a string and its length into the
ioparm structure. */
*************** set_string (stmtblock_t * block, stmtblo
*** 407,413 ****
{
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));
--- 458,464 ----
{
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
*** 417,431 ****
}
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);
}
gfc_add_block_to_block (block, &se.pre);
gfc_add_block_to_block (postblock, &se.post);
-
}
--- 468,488 ----
}
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,
! fold_convert (TREE_TYPE (len), se.string_length));
}
gfc_add_block_to_block (block, &se.pre);
gfc_add_block_to_block (postblock, &se.post);
}
? libgfortran.diff
Index: io/transfer.c
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/io/transfer.c,v
retrieving revision 1.33
diff -c -3 -p -r1.33 transfer.c
*** io/transfer.c 25 Mar 2005 13:35:29 -0000 1.33
--- io/transfer.c 28 Mar 2005 13:39:16 -0000
*************** formatted_transfer (bt type, void *p, in
*** 505,512 ****
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);
--- 505,510 ----