procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

For the 60th anniversary of Chinese people��s Anti-Japan war victory.

Browse source 
2005-07-07  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.

2005-07-07  Feng Wang  <fengwang@nudt.edu.cn>

	PR fortran/16531
	PR fortran/15966
	PR fortran/18781
	* gfortran.dg/hollerith.f90: New.
	* gfortran.dg/hollerith2.f90: New.
	* gfortran.dg/hollerith3.f90: New.
	* gfortran.dg/hollerith4.f90: New.
	* gfortran.dg/hollerith_f95.f90: New.
	* gfortran.dg/hollerith_legacy.f90: New.
	* gfortran.dg/g77/cpp4.F: New. Port from g77.

2005-07-07  Feng Wang  <fengwang@nudt.edu.cn>

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

From-SVN: r101688
This commit is contained in:
Feng Wang 2005-07-07 07:54:58 +00:00 • committed by Feng Wang
parent 378f73afe0
commit d3642f893a
21 changed files with 863 additions and 42 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

174
gcc/fortran/arith.c
View file

@ -1582,17 +1582,19 @@ eval_intrinsic (gfc_intrinsic_op operator,
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)))
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->expr_type != EXPR_CONSTANT
&& (op2->expr_type != EXPR_ARRAY
|| !gfc_is_constant_expr (op2)
|| !gfc_expanded_ac (op2)))
&& (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)
@ -2214,3 +2216,159 @@ gfc_int2log (gfc_expr *src, int kind)
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;
}

5
gcc/fortran/arith.h
View file

@ -82,6 +82,11 @@ gfc_expr *gfc_complex2complex (gfc_expr *, int);
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 */

22
gcc/fortran/expr.c
View file

@ -141,6 +141,12 @@ free_expr0 (gfc_expr * e)
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:
@ -152,6 +158,7 @@ free_expr0 (gfc_expr * e)
break;
case BT_CHARACTER:
case BT_HOLLERITH:
gfc_free (e->value.character.string);
break;
@ -393,6 +400,15 @@ gfc_copy_expr (gfc_expr * p)
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:
@ -414,6 +430,7 @@ gfc_copy_expr (gfc_expr * p)
break;
case BT_CHARACTER:
case BT_HOLLERITH:
s = gfc_getmem (p->value.character.length + 1);
q->value.character.string = s;
@ -1813,7 +1830,10 @@ gfc_check_assign (gfc_expr * lvalue, gfc_expr * rvalue, int conform)
if (!conform)
{
if (gfc_numeric_ts (&lvalue->ts) && gfc_numeric_ts (&rvalue->ts))
/* 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)

5
gcc/fortran/gfortran.h
View file

@ -127,7 +127,7 @@ gfc_source_form;
typedef enum
{ BT_UNKNOWN = 1, BT_INTEGER, BT_REAL, BT_COMPLEX,
BT_LOGICAL, BT_CHARACTER, BT_DERIVED, BT_PROCEDURE
BT_LOGICAL, BT_CHARACTER, BT_DERIVED, BT_PROCEDURE, BT_HOLLERITH
}
bt;
@ -1077,6 +1077,9 @@ typedef struct gfc_expr
locus where;
/* True if it is converted from Hollerith constant. */
unsigned int from_H : 1;
union
{
int logical;

39
gcc/fortran/intrinsic.c
View file

@ -79,6 +79,10 @@ gfc_type_letter (bt type)
c = 'c';
break;
case BT_HOLLERITH:
c = 'h';
break;
default:
c = 'u';
break;
@ -2327,6 +2331,31 @@ add_conversions (void)
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++)
@ -2713,6 +2742,16 @@ do_simplify (gfc_intrinsic_sym * specific, gfc_expr * e)
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)

68
gcc/fortran/io.c
View file

@ -969,33 +969,63 @@ resolve_tag (const io_tag * tag, gfc_expr * e)
if (gfc_resolve_expr (e) == FAILURE)
return FAILURE;
if (e->ts.type != tag->type)
if (e->ts.type != tag->type && tag != &tag_format)
{
/* 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;
}
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->rank != 1 && e->rank != 0)
/* 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)
{
gfc_error ("FORMAT tag at %L cannot be array of strings",
&e->where);
return FAILURE;
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;
}
/* Check assigned label. */
if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_INTEGER
&& e->symtree->n.sym->attr.assign != 1)
else
{
gfc_error ("Variable '%s' has not been assigned a format label at %L",
e->symtree->n.sym->name, &e->where);
return FAILURE;
/* 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

6
gcc/fortran/misc.c
View file

@ -159,6 +159,9 @@ gfc_basic_typename (bt type)
case BT_CHARACTER:
p = "CHARACTER";
break;
case BT_HOLLERITH:
p = "HOLLERITH";
break;
case BT_DERIVED:
p = "DERIVED";
break;
@ -207,6 +210,9 @@ gfc_typename (gfc_typespec * ts)
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;

73
gcc/fortran/primary.c
View file

@ -228,6 +228,75 @@ match_integer_constant (gfc_expr ** result, int signflag)
}
/* 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. */
@ -1159,6 +1228,10 @@ gfc_match_literal_constant (gfc_expr ** result, int signflag)
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;

28
gcc/fortran/simplify.c
View file

@ -3774,6 +3774,34 @@ gfc_convert_constant (gfc_expr * e, bt type, int kind)
}
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");

46
gcc/fortran/trans-const.c
View file

@ -274,30 +274,58 @@ gfc_conv_constant_to_tree (gfc_expr * expr)
{
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:
return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
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:
return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind);
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),
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:
{
tree real = gfc_conv_mpfr_to_tree (expr->value.complex.r,
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,
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);
}
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);

73
gcc/fortran/trans-io.c
View file

@ -364,6 +364,68 @@ set_parameter_ref (stmtblock_t * block, tree var, gfc_expr * e)
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 - 1;
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. */
@ -400,7 +462,15 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
}
else
{
gfc_conv_expr (&se, e);
/* 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);
else
gcc_unreachable ();
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);
@ -408,7 +478,6 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
gfc_add_block_to_block (block, &se.pre);
gfc_add_block_to_block (postblock, &se.post);
}

13
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,16 @@
2005-07-07 Feng Wang <fengwang@nudt.edu.cn>
PR fortran/16531
PR fortran/15966
PR fortran/18781
* gfortran.dg/hollerith.f90: New.
* gfortran.dg/hollerith2.f90: New.
* gfortran.dg/hollerith3.f90: New.
* gfortran.dg/hollerith4.f90: New.
* gfortran.dg/hollerith_f95.f90: New.
* gfortran.dg/hollerith_legacy.f90: New.
* gfortran.dg/g77/cpp4.F: New. Port from g77.
2005-07-07 Ziemowit Laski <zlaski@apple.com>
PR objc/22274

12
gcc/testsuite/gfortran.dg/g77/cpp4.F Normal file
View file

@ -0,0 +1,12 @@
! { 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 }

108
gcc/testsuite/gfortran.dg/hollerith.f90 Normal file
View file

@ -0,0 +1,108 @@
! { 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
character*8 c
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)
i = 4hHell
l = 4Ho wo
r = 4Hrld!
write (line, '(3A4)') i, l, r
if (line .ne. 'Hello world!') call abort
i = 2Hab
r = 2Hab
l = 2Hab
c = 2Hab
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
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
call test (8h hello)
end
subroutine test (h)
integer*8 h
character*80 line
write (line, '(8a)') h
if (line .ne. ' hello') call abort
end subroutine
! { dg-warning "Hollerith constant" "const" { target *-*-* } 15 }
! { dg-warning "Conversion" "conversion" { target *-*-* } 15 }
! { dg-warning "Hollerith constant" "const" { target *-*-* } 16 }
! { dg-warning "Conversion" "conversion" { target *-*-* } 16 }
! { dg-warning "Hollerith constant" "const" { target *-*-* } 17 }
! { dg-warning "Hollerith constant" "const" { target *-*-* } 18 }
! { dg-warning "Hollerith constant" "const" { target *-*-* } 19 }
! { dg-warning "Hollerith constant" "const" { target *-*-* } 21 }
! { dg-warning "Conversion" "conversion" { target *-*-* } 21 }
! { dg-warning "Hollerith constant" "const" { target *-*-* } 22 }
! { dg-warning "Conversion" "conversion" { target *-*-* } 22 }
! { dg-warning "Hollerith constant" "const" { target *-*-* } 23 }
! { dg-warning "Conversion" "conversion" { target *-*-* } 23 }
! { dg-warning "Hollerith constant" "const" { target *-*-* } 24 }
! { dg-warning "Conversion" "conversion" { target *-*-* } 24 }
! { dg-warning "Hollerith constant" "const" { target *-*-* } 27 }
! { dg-warning "Conversion" "conversion" { target *-*-* } 27 }
! { dg-warning "Hollerith constant" "const" { target *-*-* } 28 }
! { dg-warning "Conversion" "conversion" { target *-*-* } 28 }
! { dg-warning "Hollerith constant" "const" { target *-*-* } 29 }
! { dg-warning "Conversion" "conversion" { target *-*-* } 29 }
! { dg-warning "Hollerith constant" "const" { target *-*-* } 30 }
! { dg-warning "Conversion" "conversion" { target *-*-* } 30 }
! { dg-warning "Non-character in FORMAT tag" "" { target *-*-* } 37 }
! { dg-warning "Non-character in FORMAT tag" "" { target *-*-* } 39 }
! { dg-warning "Character array in FORMAT tag" "" { target *-*-* } 43 }
! { dg-warning "Character array in FORMAT tag" "" { target *-*-* } 45 }
! { dg-warning "Character array in FORMAT tag" "" { target *-*-* } 47 }
! { dg-warning "Hollerith constant" "" { target *-*-* } 51 }

26
gcc/testsuite/gfortran.dg/hollerith2.f90 Normal file
View file

@ -0,0 +1,26 @@
! { dg-do run }
! Program to test Hollerith constant.
Program test
implicit none
integer* 4 i,j
real r, x, y
parameter (i = 4h1234)
parameter (r = 4hdead)
parameter (y = 4*r)
parameter (j = selected_real_kind (i))
x = 4H1234
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 *-*-* } 8 }
! { dg-warning "Conversion" "conversion" { target *-*-* } 8 }
! { dg-warning "Hollerith constant" "const" { target *-*-* } 11 }
! { dg-warning "Conversion" "conversion" { target *-*-* } 11 }

9
gcc/testsuite/gfortran.dg/hollerith3.f90 Normal file
View file

@ -0,0 +1,9 @@
! { 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

29
gcc/testsuite/gfortran.dg/hollerith4.f90 Normal file
View file

@ -0,0 +1,29 @@
! { 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 }

100
gcc/testsuite/gfortran.dg/hollerith_f95.f90 Normal file
View file

@ -0,0 +1,100 @@
! { dg-do compile }
! { dg-options "-std=f95" }
! 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
character*8 c
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)
i = 4hHell
l = 4Ho wo
r = 4Hrld!
write (line, '(3A4)') i, l, r
if (line .ne. 'Hello world!') call abort
i = 2Hab
r = 2Hab
l = 2Hab
c = 2Hab
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
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
call test (8h hello)
end
subroutine test (h)
integer*8 h
character*80 line
write (line, '(8a)') h
if (line .ne. ' hello') call abort
end subroutine
! { dg-error "Hollerith constant" "const" { target *-*-* } 16 }
! { dg-error "Hollerith constant" "const" { target *-*-* } 17 }
! { dg-error "Hollerith constant" "const" { target *-*-* } 18 }
! { dg-error "Hollerith constant" "const" { target *-*-* } 19 }
! { dg-error "Hollerith constant" "const" { target *-*-* } 20 }
! { dg-error "Hollerith constant" "const" { target *-*-* } 22 }
! { dg-error "Hollerith constant" "const" { target *-*-* } 23 }
! { dg-error "Hollerith constant" "const" { target *-*-* } 24 }
! { dg-error "Hollerith constant" "const" { target *-*-* } 25 }
! { dg-error "Hollerith constant" "const" { target *-*-* } 28 }
! { dg-error "Hollerith constant" "const" { target *-*-* } 29 }
! { dg-error "Hollerith constant" "const" { target *-*-* } 30 }
! { dg-error "Hollerith constant" "const" { target *-*-* } 31 }
! { dg-error "Hollerith constant" "const" { target *-*-* } 52 }
! { dg-error "Non-character in FORMAT tag" "" { target *-*-* } 38 }
! { dg-error "Non-character in FORMAT tag" "" { target *-*-* } 40 }
! { dg-error "Character array in FORMAT tag" "" { target *-*-* } 44 }
! { dg-error "Character array in FORMAT tag" "" { target *-*-* } 46 }
! { dg-error "Character array in FORMAT tag" "" { target *-*-* } 48 }

61
gcc/testsuite/gfortran.dg/hollerith_legacy.f90 Normal file
View file

@ -0,0 +1,61 @@
! { dg-do compile }
! { dg-options "-std=legacy" }
! 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
character*8 c
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)
i = 4hHell
l = 4Ho wo
r = 4Hrld!
write (line, '(3A4)') i, l, r
if (line .ne. 'Hello world!') call abort
i = 2Hab
r = 2Hab
l = 2Hab
c = 2Hab
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
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
call test (8h hello)
end
subroutine test (h)
integer*8 h
character*80 line
write (line, '(8a)') h
if (line .ne. ' hello') call abort
end subroutine

6
libgfortran/ChangeLog
View file

@ -1,3 +1,9 @@
2005-07-07 Feng Wang <fengwang@nudt.edu.cn>
PR fortran/16531
* io/transfer.c (formatted_transfer): Enable FMT_A on other types to
support Hollerith constants.
2005-07-01 Andreas Jaeger <aj@suse.de>
* intrinsics/unpack_generic.c: Remove const from parameter.

2
libgfortran/io/transfer.c
View file

@ -524,8 +524,6 @@ formatted_transfer (bt type, void *p, int len)
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);