This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Enable Hollerith constant and character arrayin format tag (take 3).
- 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: Wed, 29 Jun 2005 21:03:53 +0800 (CST)
- Subject: Enable Hollerith constant and character arrayin format tag (take 3).
- Domainkey-signature: a=rsa-sha1; q=dns; c=nofws; s=s1024; d=yahoo.com; h=Message-ID:Received:Date:From:Subject:To:MIME-Version:Content-Type:Content-Transfer-Encoding; b=AbnK0hE0X5NLZTTgjCRI3VRB2/ms7DVQQN+ug1vUx2+WQez34RUDN+redBPaIFxwRFZRS7mJE7vBUaL4ByLVxsnJC7WCtE+XJ63Sr+fX5tVCJWlNyjLZp303Oaa2QGMolQye8YtV3huLh8XBRfrrI41QL/StGzWMMnigVRV1iao= ;
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.
The original patch:
http://gcc.gnu.org/ml/fortran/2005-05/msg00280.html
http://gcc.gnu.org/ml/fortran/2005-03/msg00502.html
libgfortran Changelog:
2005-06-29 Feng Wang <fengwang@nudt.edu.cn>
PR fortran/16531
* io/transfer.c (formatted_transfer): Delete unused variable. Enable
FMT_A on other types for supporting Hollerith constants.
fortran Changelog:
2005-06-27 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.
Best Regards,
Feng Wang
--
Creative Compiler Research Group,
National University of Defense Technology, China.
__________________________________________________
赶快注册雅虎超大容量免费邮箱?
http://cn.mail.yahoo.com
? libgfortran.diff
? io/lib.diff
Index: io/transfer.c
===================================================================
RCS file: /cvs/gcc/gcc/libgfortran/io/transfer.c,v
retrieving revision 1.45
diff -c -3 -p -r1.45 transfer.c
*** io/transfer.c 28 Jun 2005 10:43:23 -0000 1.45
--- io/transfer.c 29 Jun 2005 12:32:12 -0000
*************** formatted_transfer (bt type, void *p, in
*** 439,445 ****
{
int pos ,m ;
fnode *f;
! int i, n;
int consume_data_flag;
/* Change a complex data item into a pair of reals. */
--- 439,445 ----
{
int pos ,m ;
fnode *f;
! int n;
int consume_data_flag;
/* Change a complex data item into a pair of reals. */
*************** 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 ----
Index: arith.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/arith.c,v
retrieving revision 1.29
diff -c -3 -p -r1.29 arith.c
*** arith.c 25 Jun 2005 00:40:33 -0000 1.29
--- arith.c 29 Jun 2005 10:39:18 -0000
*************** eval_intrinsic (gfc_intrinsic_op operato
*** 1582,1598 ****
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)
--- 1582,1600 ----
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_int2log (gfc_expr *src, int kind)
*** 2214,2216 ****
--- 2216,2374 ----
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.6
diff -c -3 -p -r1.6 arith.h
*** arith.h 25 Jun 2005 00:40:33 -0000 1.6
--- arith.h 29 Jun 2005 10:39:18 -0000
*************** gfc_expr *gfc_complex2complex (gfc_expr
*** 82,87 ****
--- 82,92 ----
gfc_expr *gfc_log2log (gfc_expr *, int);
gfc_expr *gfc_log2int (gfc_expr *, int);
gfc_expr *gfc_int2log (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.26
diff -c -3 -p -r1.26 expr.c
*** expr.c 25 Jun 2005 00:40:34 -0000 1.26
--- expr.c 29 Jun 2005 10:39:22 -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.73
diff -c -3 -p -r1.73 gfortran.h
*** gfortran.h 25 Jun 2005 00:40:34 -0000 1.73
--- gfortran.h 29 Jun 2005 10:39:25 -0000
*************** gfc_source_form;
*** 127,133 ****
typedef enum
{ BT_UNKNOWN = 1, BT_INTEGER, BT_REAL, BT_COMPLEX,
! BT_LOGICAL, BT_CHARACTER, BT_DERIVED, BT_PROCEDURE
}
bt;
--- 127,133 ----
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
*** 1069,1074 ****
--- 1069,1077 ----
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.17
diff -c -3 -p -r1.17 gfortran.texi
*** gfortran.texi 25 Jun 2005 00:40:34 -0000 1.17
--- gfortran.texi 29 Jun 2005 10:39:31 -0000
*************** of extensions, and @option{-std=legacy}
*** 634,639 ****
--- 634,640 ----
* Real array indices::
* Unary operators::
* Implicitly interconvert LOGICAL and INTEGER::
+ * Hollerith constants support::
@end menu
@node Old-style kind specifications
*************** converting from INTEGER to LOGICAL, the
*** 806,811 ****
--- 807,841 ----
i = .FALSE.
@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.51
diff -c -3 -p -r1.51 intrinsic.c
*** intrinsic.c 25 Jun 2005 00:40:34 -0000 1.51
--- intrinsic.c 29 Jun 2005 10:39:38 -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)
*** 2327,2332 ****
--- 2331,2361 ----
BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77);
}
+ if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0)
+ {
+ /* 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_STD_LEGACY);
+ /* 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_STD_LEGACY);
+ /* 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_STD_LEGACY);
+
+ /* Hollerith-Character conversions. */
+ add_conv (BT_HOLLERITH, gfc_default_character_kind, BT_CHARACTER,
+ gfc_default_character_kind, GFC_STD_LEGACY);
+
+ /* 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_STD_LEGACY);
+ }
+
/* 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
*** 2713,2718 ****
--- 2742,2757 ----
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.26
diff -c -3 -p -r1.26 io.c
*** io.c 25 Jun 2005 00:40:35 -0000 1.26
--- io.c 29 Jun 2005 10:39:41 -0000
*************** resolve_tag (const io_tag * tag, gfc_exp
*** 969,1001 ****
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
! 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 or %s", tag->name,
! &e->where, gfc_basic_typename (tag->type),
! gfc_basic_typename (BT_INTEGER));
! return FAILURE;
! }
}
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
--- 969,1031 ----
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
! if (e->ts.type != tag->type && 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;
}
if (tag == &tag_format)
{
! /* If e's rank is zero and e is not an element of an array, it should be
! of integer or character type. The integer variable should be
! ASSIGNED. */
! if (e->symtree == NULL || e->symtree->n.sym->as == NULL
! || e->symtree->n.sym->as->rank == 0)
! {
! if (e->ts.type != BT_CHARACTER && e->ts.type != BT_INTEGER)
! {
! gfc_error ("%s tag at %L must be of type %s or %s", tag->name,
! &e->where, gfc_basic_typename (BT_CHARACTER),
! gfc_basic_typename (BT_INTEGER));
! return FAILURE;
! }
! else if (e->ts.type == BT_INTEGER && e->expr_type == EXPR_VARIABLE)
! {
! 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;
! }
! else
! {
! /* if rank is nonzero, we allow the type to be character under
! GFC_STD_GNU and other type under GFC_STD_LEGACY. It may be
! assigned an Hollerith constant. */
! if (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;
! }
! else
! {
! if (gfc_notify_std (GFC_STD_LEGACY,
! "Extension: Non-character in FORMAT tag at %L",
! &e->where) == FAILURE)
! return FAILURE;
! }
! return SUCCESS;
}
}
else
Index: misc.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/misc.c,v
retrieving revision 1.9
diff -c -3 -p -r1.9 misc.c
*** misc.c 25 Jun 2005 00:40:35 -0000 1.9
--- misc.c 29 Jun 2005 10:39:41 -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.28
diff -c -3 -p -r1.28 primary.c
*** primary.c 25 Jun 2005 00:40:35 -0000 1.28
--- primary.c 29 Jun 2005 10:39:46 -0000
*************** match_integer_constant (gfc_expr ** resu
*** 228,233 ****
--- 228,302 ----
}
+ /* Match a Hollerith constant. */
+
+ static match
+ match_hollerith_constant (gfc_expr ** result)
+ {
+ locus old_loc;
+ gfc_expr * e = NULL;
+ 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_LEGACY,
+ "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_free_expr (e);
+ 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 ****
--- 1228,1237 ----
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.29
diff -c -3 -p -r1.29 simplify.c
*** simplify.c 25 Jun 2005 00:40:35 -0000 1.29
--- simplify.c 29 Jun 2005 10:39:49 -0000
*************** gfc_convert_constant (gfc_expr * e, bt t
*** 3774,3779 ****
--- 3774,3807 ----
}
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.28
diff -c -3 -p -r1.28 trans-const.c
*** trans-const.c 25 Jun 2005 00:40:36 -0000 1.28
--- trans-const.c 29 Jun 2005 10:39:49 -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.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 29 Jun 2005 10:39:52 -0000
*************** set_parameter_ref (stmtblock_t * block,
*** 364,369 ****
--- 364,419 ----
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
*** 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);
--- 450,462 ----
}
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);
-
}
--- 464,469 ----
! { dg-do run }
C The preprocessor must not mangle Hollerith constants
C which contain apostrophes.
integer i
character*4 j
data i /4hbla'/
write (j, '(4a)') i
if (j .ne. "bla'") call abort
end
! { dg-warning "Hollerith constant" "const" { target *-*-* } 6 }
! { dg-warning "Conversion" "conversion" { target *-*-* } 6 }
! { dg-do run }
! Program to test Hollerith constant.
Program test
implicit none
integer* 4 i
real r, x, y
parameter (r = 4hdead)
parameter (y = 4*r)
data i/5H12345/
x = 5H12345
x = sin(r)
x = x * r
x = x / r
x = x + r
x = x - r
end
! { dg-warning "Hollerith constant" "const" { target *-*-* } 7 }
! { dg-warning "Conversion" "conversion" { target *-*-* } 7 }
! { dg-warning "Hollerith constant" "const" { target *-*-* } 9 }
! { dg-warning "Conversion" "conversion" { target *-*-* } 9 }
! { dg-warning "Hollerith constant" "const" { target *-*-* } 10 }
! { dg-warning "Conversion" "conversion" { target *-*-* } 10 }
! { dg-do compile }
! { dg-options "-w" }
! Program to test invalid Hollerith constant.
Program test
implicit none
integer i
i = 0H ! { dg-error "at least one character" }
i = 4_8H1234 ! { dg-error "should be default" }
end