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)
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;
+}
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 */
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:
break;
case BT_CHARACTER:
+ case BT_HOLLERITH:
gfc_free (e->value.character.string);
break;
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:
break;
case BT_CHARACTER:
+ case BT_HOLLERITH:
s = gfc_getmem (p->value.character.length + 1);
q->value.character.string = s;
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)
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;
locus where;
+ /* True if it is converted from Hollerith constant. */
+ unsigned int from_H : 1;
+
union
{
int logical;
c = 'c';
break;
+ case BT_HOLLERITH:
+ c = 'h';
+ break;
+
default:
c = 'u';
break;
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++)
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)
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
case BT_CHARACTER:
p = "CHARACTER";
break;
+ case BT_HOLLERITH:
+ p = "HOLLERITH";
+ break;
case BT_DERIVED:
p = "DERIVED";
break;
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;
}
+/* 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. */
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;
}
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");
{
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);
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. */
}
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);
gfc_add_block_to_block (block, &se.pre);
gfc_add_block_to_block (postblock, &se.post);
-
}
+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
--- /dev/null
+ ! { 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 }
--- /dev/null
+! { 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 }
--- /dev/null
+ ! { 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 }
+
--- /dev/null
+ ! { 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
--- /dev/null
+! { 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 }
+
+
--- /dev/null
+! { 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 }
+
--- /dev/null
+! { 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
+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.
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);
projects / thirdparty / gcc.git / commitdiff
