diff options
| -rw-r--r-- | gcc/fortran/arith.c | 174 | ||||
| -rw-r--r-- | gcc/fortran/arith.h | 5 | ||||
| -rw-r--r-- | gcc/fortran/expr.c | 22 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 5 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.c | 39 | ||||
| -rw-r--r-- | gcc/fortran/io.c | 68 | ||||
| -rw-r--r-- | gcc/fortran/misc.c | 6 | ||||
| -rw-r--r-- | gcc/fortran/primary.c | 73 | ||||
| -rw-r--r-- | gcc/fortran/simplify.c | 28 | ||||
| -rw-r--r-- | gcc/fortran/trans-const.c | 46 | ||||
| -rw-r--r-- | gcc/fortran/trans-io.c | 73 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 13 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/g77/cpp4.F | 12 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/hollerith.f90 | 108 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/hollerith2.f90 | 26 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/hollerith3.f90 | 9 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/hollerith4.f90 | 29 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/hollerith_f95.f90 | 100 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/hollerith_legacy.f90 | 61 | ||||
| -rw-r--r-- | libgfortran/ChangeLog | 6 | ||||
| -rw-r--r-- | libgfortran/io/transfer.c | 2 |
21 files changed, 863 insertions, 42 deletions
diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c index c85366e..4443f33 100644 --- a/gcc/fortran/arith.c +++ b/gcc/fortran/arith.c @@ -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; +} diff --git a/gcc/fortran/arith.h b/gcc/fortran/arith.h index ed2fd4e..385fbff 100644 --- a/gcc/fortran/arith.h +++ b/gcc/fortran/arith.h @@ -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 */ diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index fe4c746..a3a24b5 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -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) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 07a3f2c..71b6c19 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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; diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 05452c2..67d95df 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -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) diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index ef51308..abfeead 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -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 diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c index 2a4301f..dc6a34b 100644 --- a/gcc/fortran/misc.c +++ b/gcc/fortran/misc.c @@ -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; diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index e14ab92..1f8305b 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -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; diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 5df7a4c..72d03ea 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -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"); diff --git a/gcc/fortran/trans-const.c b/gcc/fortran/trans-const.c index 121740c..ae7c271 100644 --- a/gcc/fortran/trans-const.c +++ b/gcc/fortran/trans-const.c @@ -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); diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index 6680449..4b6caa6 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -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); - } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index d8efcde..57e7e08 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -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 diff --git a/gcc/testsuite/gfortran.dg/g77/cpp4.F b/gcc/testsuite/gfortran.dg/g77/cpp4.F new file mode 100644 index 0000000..0dd5c99 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/g77/cpp4.F @@ -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 } diff --git a/gcc/testsuite/gfortran.dg/hollerith.f90 b/gcc/testsuite/gfortran.dg/hollerith.f90 new file mode 100644 index 0000000..e273cee --- /dev/null +++ b/gcc/testsuite/gfortran.dg/hollerith.f90 @@ -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 } diff --git a/gcc/testsuite/gfortran.dg/hollerith2.f90 b/gcc/testsuite/gfortran.dg/hollerith2.f90 new file mode 100644 index 0000000..773b79b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/hollerith2.f90 @@ -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 } + diff --git a/gcc/testsuite/gfortran.dg/hollerith3.f90 b/gcc/testsuite/gfortran.dg/hollerith3.f90 new file mode 100644 index 0000000..b283f5f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/hollerith3.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/hollerith4.f90 b/gcc/testsuite/gfortran.dg/hollerith4.f90 new file mode 100644 index 0000000..b890185 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/hollerith4.f90 @@ -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 } + + diff --git a/gcc/testsuite/gfortran.dg/hollerith_f95.f90 b/gcc/testsuite/gfortran.dg/hollerith_f95.f90 new file mode 100644 index 0000000..c7e4d58 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/hollerith_f95.f90 @@ -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 } + diff --git a/gcc/testsuite/gfortran.dg/hollerith_legacy.f90 b/gcc/testsuite/gfortran.dg/hollerith_legacy.f90 new file mode 100644 index 0000000..561430c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/hollerith_legacy.f90 @@ -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 diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 42b78ee..242bd3c 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -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. diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index 6a4a15e..bcba218 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -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); |