+2008-04-16 Daniel Kraft <d@domob.eu>
+
+ PR fortran/27997
+ * gfortran.h: Added field "length_from_typespec" to gfc_charlength.
+ * aray.c (gfc_match_array_constructor): Added code to parse typespec.
+ (check_element_type, check_constructor_type, gfc_check_constructor_type):
+ Extended to support explicit typespec on constructor.
+ (gfc_resolve_character_array_constructor): Pad strings correctly for
+ explicit, constant character length.
+ * trans-array.c: New static global variable "typespec_chararray_ctor"
+ (gfc_trans_array_constructor): New code to support explicit but dynamic
+ character lengths.
+
2008-05-16 Jerry DeLisle <jvdelisle@gcc.gnu.org>
- PR fortran/34325
- * decl.c (match_attr_spec): Check for matching pairs of parenthesis.
- * expr.c (gfc_specification_expr): Supplement the error message with the
- type that was found.
- * resolve.c (gfc_resolve_index): Likewise.
- * match.c (gfc_match_parens): Clarify error message with "at or before".
- (gfc_match_do): Check for matching pairs of parenthesis.
+ PR fortran/34325
+ * decl.c (match_attr_spec): Check for matching pairs of parenthesis.
+ * expr.c (gfc_specification_expr): Supplement the error message with the
+ type that was found.
+ * resolve.c (gfc_resolve_index): Likewise.
+ * match.c (gfc_match_parens): Clarify error message with "at or before".
+ (gfc_match_do): Check for matching pairs of parenthesis.
2008-05-16 Tobias Burnus <burnus@net-b.de
{
gfc_constructor *head, *tail, *new;
gfc_expr *expr;
+ gfc_typespec ts;
locus where;
match m;
const char *end_delim;
+ bool seen_ts;
if (gfc_match (" (/") == MATCH_NO)
{
where = gfc_current_locus;
head = tail = NULL;
+ seen_ts = false;
+
+ /* Try to match an optional "type-spec ::" */
+ if (gfc_match_type_spec (&ts, 0) == MATCH_YES)
+ {
+ seen_ts = (gfc_match (" ::") == MATCH_YES);
+
+ if (seen_ts)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Array constructor "
+ "including type specification at %C") == FAILURE)
+ goto cleanup;
+ }
+ }
+
+ if (! seen_ts)
+ gfc_current_locus = where;
if (gfc_match (end_delim) == MATCH_YES)
{
- gfc_error ("Empty array constructor at %C is not allowed");
- goto cleanup;
+ if (seen_ts)
+ goto done;
+ else
+ {
+ gfc_error ("Empty array constructor at %C is not allowed");
+ goto cleanup;
+ }
}
for (;;)
if (gfc_match (end_delim) == MATCH_NO)
goto syntax;
+done:
expr = gfc_get_expr ();
expr->expr_type = EXPR_ARRAY;
expr->value.constructor = head;
/* Size must be calculated at resolution time. */
+ if (seen_ts)
+ expr->ts = ts;
+ else
+ expr->ts.type = BT_UNKNOWN;
+
+ if (expr->ts.cl)
+ expr->ts.cl->length_from_typespec = seen_ts;
+
expr->where = where;
expr->rank = 1;
cons_state;
static int
-check_element_type (gfc_expr *expr)
+check_element_type (gfc_expr *expr, bool convert)
{
if (cons_state == CONS_BAD)
return 0; /* Suppress further errors */
if (gfc_compare_types (&constructor_ts, &expr->ts))
return 0;
+ if (convert)
+ return gfc_convert_type (expr, &constructor_ts, 1) == SUCCESS ? 0 : 1;
+
gfc_error ("Element in %s array constructor at %L is %s",
gfc_typename (&constructor_ts), &expr->where,
gfc_typename (&expr->ts));
/* Recursive work function for gfc_check_constructor_type(). */
static try
-check_constructor_type (gfc_constructor *c)
+check_constructor_type (gfc_constructor *c, bool convert)
{
gfc_expr *e;
if (e->expr_type == EXPR_ARRAY)
{
- if (check_constructor_type (e->value.constructor) == FAILURE)
+ if (check_constructor_type (e->value.constructor, convert) == FAILURE)
return FAILURE;
continue;
}
- if (check_element_type (e))
+ if (check_element_type (e, convert))
return FAILURE;
}
{
try t;
- cons_state = CONS_START;
- gfc_clear_ts (&constructor_ts);
+ if (e->ts.type != BT_UNKNOWN)
+ {
+ cons_state = CONS_GOOD;
+ constructor_ts = e->ts;
+ }
+ else
+ {
+ cons_state = CONS_START;
+ gfc_clear_ts (&constructor_ts);
+ }
- t = check_constructor_type (e->value.constructor);
+ /* If e->ts.type != BT_UNKNOWN, the array constructor included a
+ typespec, and we will now convert the values on the fly. */
+ t = check_constructor_type (e->value.constructor, e->ts.type != BT_UNKNOWN);
if (t == SUCCESS && e->ts.type == BT_UNKNOWN)
e->ts = constructor_ts;
/* Resolve character array constructor. If it is a constant character array and
not specified character length, update character length to the maximum of
- its element constructors' length. */
+ its element constructors' length. For arrays with fixed length, pad the
+ elements as necessary with needed_length. */
void
gfc_resolve_character_array_constructor (gfc_expr *expr)
{
gfc_constructor *p;
int max_length;
+ bool generated_length;
gcc_assert (expr->expr_type == EXPR_ARRAY);
gcc_assert (expr->ts.type == BT_CHARACTER);
got_charlen:
+ generated_length = false;
if (expr->ts.cl->length == NULL)
{
/* Find the maximum length of the elements. Do nothing for variable
{
/* Update the character length of the array constructor. */
expr->ts.cl->length = gfc_int_expr (max_length);
- /* Update the element constructors. */
- for (p = expr->value.constructor; p; p = p->next)
- if (p->expr->expr_type == EXPR_CONSTANT)
- gfc_set_constant_character_len (max_length, p->expr, true);
+ generated_length = true;
+ /* Real update follows below. */
}
}
+ else
+ {
+ /* We've got a character length specified. It should be an integer,
+ otherwise an error is signalled elsewhere. */
+ gcc_assert (expr->ts.cl->length);
+
+ /* If we've got a constant character length, pad according to this.
+ gfc_extract_int does check for BT_INTEGER and EXPR_CONSTANT and sets
+ max_length only if they pass. */
+ gfc_extract_int (expr->ts.cl->length, &max_length);
+ }
+
+ /* Found a length to update to, do it for all element strings shorter than
+ the target length. */
+ if (max_length != -1)
+ {
+ for (p = expr->value.constructor; p; p = p->next)
+ if (p->expr->expr_type == EXPR_CONSTANT)
+ {
+ gfc_expr *cl = NULL;
+ int current_length = -1;
+
+ if (p->expr->ts.cl && p->expr->ts.cl->length)
+ {
+ cl = p->expr->ts.cl->length;
+ gfc_extract_int (cl, ¤t_length);
+ }
+
+ /* If gfc_extract_int above set current_length, we implicitly
+ know the type is BT_INTEGER and it's EXPR_CONSTANT. */
+
+ if (generated_length || ! cl
+ || (current_length != -1 && current_length < max_length))
+ gfc_set_constant_character_len (max_length, p->expr, true);
+ }
+ }
}
{
struct gfc_expr *length;
struct gfc_charlen *next;
+ bool length_from_typespec; /* Length from explicit array ctor typespec? */
tree backend_decl;
int resolved;
}
-/* Assign an element of an array constructor. */
+/* Variables needed for bounds-checking. */
static bool first_len;
static tree first_len_val;
+static bool typespec_chararray_ctor;
static void
gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc,
se->string_length,
se->expr);
}
- if (flag_bounds_check)
+ if (flag_bounds_check && !typespec_chararray_ctor)
{
if (first_len)
{
tree loopfrom;
bool dynamic;
- if (flag_bounds_check && ss->expr->ts.type == BT_CHARACTER)
+ /* Do bounds-checking here and in gfc_trans_array_ctor_element only if no
+ typespec was given for the array constructor. */
+ typespec_chararray_ctor = (ss->expr->ts.cl
+ && ss->expr->ts.cl->length_from_typespec);
+
+ if (flag_bounds_check && ss->expr->ts.type == BT_CHARACTER
+ && !typespec_chararray_ctor)
{
first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
first_len = true;
c = ss->expr->value.constructor;
if (ss->expr->ts.type == BT_CHARACTER)
{
- bool const_string = get_array_ctor_strlen (&loop->pre, c, &ss->string_length);
+ bool const_string;
+
+ /* get_array_ctor_strlen walks the elements of the constructor, if a
+ typespec was given, we already know the string length and want the one
+ specified there. */
+ if (typespec_chararray_ctor && ss->expr->ts.cl->length
+ && ss->expr->ts.cl->length->expr_type != EXPR_CONSTANT)
+ {
+ gfc_se length_se;
+
+ const_string = false;
+ gfc_init_se (&length_se, NULL);
+ gfc_conv_expr_type (&length_se, ss->expr->ts.cl->length,
+ gfc_charlen_type_node);
+ ss->string_length = length_se.expr;
+ gfc_add_block_to_block (&loop->pre, &length_se.pre);
+ gfc_add_block_to_block (&loop->post, &length_se.post);
+ }
+ else
+ const_string = get_array_ctor_strlen (&loop->pre, c,
+ &ss->string_length);
/* Complex character array constructors should have been taken care of
and not end up here. */
+2008-04-16 Daniel Kraft <d@domob.eu>
+
+ PR fortran/27997
+ * gfortran.dg/array_constructor_type_1.f03: New test
+ * gfortran.dg/array_constructor_type_2.f03: New test
+ * gfortran.dg/array_constructor_type_3.f03: New test
+ * gfortran.dg/array_constructor_type_4.f03: New test
+ * gfortran.dg/array_constructor_type_5.f03: New test
+ * gfortran.dg/array_constructor_type_6.f03: New test
+ * gfortran.dg/array_constructor_type_7.f03: New test
+ * gfortran.dg/array_constructor_type_8.f03: New test
+ * gfortran.dg/array_constructor_type_9.f: New test
+ * gfortran.dg/array_constructor_type_10.f03: New test
+ * gfortran.dg/array_constructor_type_11.f03: New test
+ * gfortran.dg/array_constructor_type_12.f03: New test
+ * gfortran.dg/array_constructor_type_13.f90: New test
+ * gfortran.dg/array_constructor_type_14.f03: New test
+ * gfortran.dg/array_constructor_type_15.f03: New test
+ * gfortran.dg/array_constructor_type_16.f03: New test
+ * gfortran.dg/array_constructor_type_17.f03: New test
+ * gfortran.dg/array_constructor_type_18.f03: New test
+
2008-05-16 Uros Bizjak <ubizjak@gmail.com>
PR target/36246
--- /dev/null
+! { dg-do run }
+!
+! PR fortran/27997
+!
+! Simple array constructor with typespec.
+!
+PROGRAM test
+ IMPLICIT NONE
+ INTEGER :: array(5)
+
+ array = (/ INTEGER :: 18, 12, 31, 3, 42.4 /)
+
+ IF (array(1) /= 18 .OR. array(2) /= 12 .OR. &
+ array(3) /= 31 .OR. array(4) /= 3 .OR. array(5) /= 42) THEN
+ CALL abort()
+ END IF
+END PROGRAM test
--- /dev/null
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+!
+! PR fortran/27997
+!
+! Array constructor with typespec and dynamic
+! character length.
+!
+PROGRAM test
+ CALL foo(8, "short", "short")
+ CALL foo(2, "lenghty", "le")
+CONTAINS
+ SUBROUTINE foo (n, s, shouldBe)
+ CHARACTER(len=*) :: s
+ CHARACTER(len=*) :: shouldBe
+ CHARACTER(len=16) :: arr(2)
+ INTEGER :: n
+ arr = [ character(len=n) :: s, s ]
+ IF (arr(1) /= shouldBe .OR. arr(2) /= shouldBe) THEN
+ CALL abort ()
+ END IF
+ END SUBROUTINE foo
+END PROGRAM test
--- /dev/null
+! { dg-do run }
+!
+! PR fortran/27997
+!
+! Empty array constructor with typespec.
+!
+ integer :: i(3)
+ i(3:2) = (/ integer :: /)
+ if (len((/ character(5) :: /)) /= 5) call abort()
+ if (kind((/ integer(8) :: /)) /= 8) call abort()
+end
--- /dev/null
+! { dg-do run }
+!
+! PR fortran/27997
+!
+! Array constructor with typespec.
+!
+real :: a(3)
+integer :: j(3)
+a = (/ integer :: 1.4, 2.2, 3.33 /)
+j = (/ 1.4, 2.2, 3.33 /)
+if( any(a /= j )) call abort()
+end
--- /dev/null
+! { dg-do compile }
+! { dg-options "-std=f95" }
+!
+! PR fortran/27997
+!
+! Array constructor with typespec
+! should be rejected for Fortran 95.
+!
+real :: a(3)
+integer :: j(3)
+a = (/ integer :: 1.4, 2.2, 3.33 /) ! { dg-error "Fortran 2003" }
+j = (/ 1.4, 2.2, 3.33 /)
+if( any(a /= j )) call abort()
+end
--- /dev/null
+! { dg-do run }
+! PR fortran/27997
+!
+! Array constructor with typespec
+! for derived types.
+
+PROGRAM test
+ IMPLICIT NONE
+
+ TYPE foo
+ INTEGER :: i
+ REAL :: x
+ END TYPE foo
+
+ TYPE(foo), PARAMETER :: x = foo(42, 42.)
+
+ TYPE(foo), DIMENSION(2) :: arr
+
+ arr = (/ TYPE(foo) :: x, foo(0, 1.) /)
+ IF (arr(1)%i /= 42 .OR. arr(1)%x /= 42. .OR. &
+ arr(2)%i /= 0 .OR. arr(2)%x /= 1.) THEN
+ CALL abort()
+ END IF
+END PROGRAM test
--- /dev/null
+! { dg-do compile }
+! PR fortran/27997
+!
+! Array constructor with typespec
+! for derived types, failing conversion.
+
+PROGRAM test
+ IMPLICIT NONE
+
+ TYPE foo
+ INTEGER :: i
+ REAL :: x
+ END TYPE foo
+
+ TYPE bar
+ LOGICAL :: logos
+ END TYPE bar
+
+ TYPE(foo), PARAMETER :: x = foo(42, 42.)
+
+ WRITE (*,*) (/ TYPE(foo) :: x, foo(0, 1.), bar(.TRUE.) /) ! { dg-error "convert TYPE" }
+END PROGRAM test
--- /dev/null
+! { dg-do run }
+! PR fortran/27997
+!
+! Nested array constructors with typespec.
+
+PROGRAM test
+ IMPLICIT NONE
+
+ INTEGER(KIND=8) :: arr(3)
+ CHARACTER(len=6) :: carr(3)
+
+ arr = (/ INTEGER(KIND=8) :: 4, [ INTEGER(KIND=4) :: 42, 12 ] /)
+ IF (arr(1) /= 4 .OR. arr(2) /= 42 .OR. arr(3) /= 12) CALL abort()
+ arr = (/ INTEGER(KIND=8) :: [ INTEGER(KIND=4) :: 4, 42, 12 ] /)
+ IF (arr(1) /= 4 .OR. arr(2) /= 42 .OR. arr(3) /= 12) CALL abort()
+ arr = (/ INTEGER(KIND=8) :: [ INTEGER(KIND=4) :: 4, 42 ], 12 /)
+ IF (arr(1) /= 4 .OR. arr(2) /= 42 .OR. arr(3) /= 12) CALL abort()
+ arr = (/ INTEGER(KIND=8) :: [ INTEGER(KIND=4) :: ], 4, 42, 12 /)
+ IF (arr(1) /= 4 .OR. arr(2) /= 42 .OR. arr(3) /= 12) CALL abort()
+
+ carr = [ CHARACTER(len=6) :: "foo", [ CHARACTER(len=4) :: "foobar", "xyz" ] ]
+ IF (carr(1) /= "foo" .OR. carr(2) /= "foob" .OR. carr(3) /= "xyz") THEN
+ CALL abort()
+ END IF
+END PROGRAM test
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fno-range-check -Wconversion" }
+! PR fortran/27997
+!
+! Range check on array-constructors with typespec.
+
+PROGRAM test
+ IMPLICIT NONE
+
+ INTEGER(KIND=4) :: arr(1)
+ arr = (/ INTEGER(KIND=4) :: HUGE(0_8) /) ! { dg-warning "Conversion from" }
+END PROGRAM test
--- /dev/null
+! { dg-do compile }
+! { dg-options "-frange-check" }
+! PR fortran/27997
+!
+! Range check on array-constructors with typespec.
+
+PROGRAM test
+ IMPLICIT NONE
+
+ INTEGER(KIND=4) :: arr(1)
+ arr = (/ INTEGER(KIND=4) :: HUGE(0_8) /) ! { dg-error "overflow converting" }
+END PROGRAM test
--- /dev/null
+! { dg-do run }
+!
+! PR fortran/27997
+!
+! Array constructor with typespec, length parameter.
+!
+program test
+ implicit none
+ character(15) :: a(3)
+ a = (/ character(len=7) :: 'Takata', 'Tanaka', 'Hayashi' /)
+ if ( len([ character(len=7) :: ]) /= 7) call abort()
+ if ( size([ integer :: ]) /= 0) call abort()
+ if( a(1) /= 'Takata' .or. a(1)(7:7) /= achar(32) &
+ .or. a(1)(15:15) /= achar(32) &
+ .or. a(2) /= 'Tanaka' .or. a(2)(7:7) /= achar(32) &
+ .or. a(2)(15:15) /= achar(32) &
+ .or. a(3) /= 'Hayashi' .or. a(3)(8:8) /= achar(32) &
+ .or. a(3)(15:15) /= achar(32))&
+ call abort()
+end program test
--- /dev/null
+! { dg-do run }
+!
+! PR fortran/27997
+!
+! Test empty array constructor with typespec.
+!
+PROGRAM test
+ IMPLICIT NONE
+ INTEGER :: array(2)
+
+ array = (/ 5, [INTEGER ::], 6 /)
+
+ IF (array(1) /= 5 .OR. array(2) /= 6) THEN
+ CALL abort()
+ END IF
+END PROGRAM test
--- /dev/null
+! { dg-do run }
+!
+! PR fortran/27997
+!
+! Ensure that :: is present when a typespec is deduced.
+!
+PROGRAM test
+ INTEGER :: array(1)
+ INTEGER = 42
+
+ array = [ INTEGER ]
+ IF (array(1) /= 42) THEN
+ CALL abort()
+ END IF
+END PROGRAM test
--- /dev/null
+! { dg-do run }
+!
+! PR fortran/27997
+!
+! Array constructor with typespec and small length value.
+!
+program test
+ implicit none
+ character(15) :: a(3)
+ a = (/ character(len=3) :: 'Takata', 'Tanaka', 'Hayashi' /)
+ if( a(1) /= 'Tak' .or. a(1)(4:4) /= achar(32) &
+ .or. a(1)(15:15) /= achar(32) &
+ .or. a(2) /= 'Tan' .or. a(2)(4:4) /= achar(32) &
+ .or. a(2)(15:15) /= achar(32) &
+ .or. a(3) /= 'Hay' .or. a(3)(4:4) /= achar(32) &
+ .or. a(3)(15:15) /= achar(32))&
+ call abort()
+end program test
--- /dev/null
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+!
+! PR fortran/27997
+!
+! Array constructor with typespec.
+!
+program test
+ character(15) :: a(3)
+ character(10), volatile :: b(3)
+ b(1) = 'Takata'
+ b(2) = 'Tanaka'
+ b(3) = 'Hayashi'
+
+ a = (/ character(len=7) :: trim(b(1)), trim(b(2)), trim(b(3)) /)
+ if (a(1) /= 'Takata' .or. a(2) /= 'Tanaka' .or. a(3) /= 'Hayashi') then
+ call abort ()
+ end if
+
+ a = (/ character(len=2) :: trim(b(1)), trim(b(2)), trim(b(3)) /)
+ if (a(1) /= 'Ta' .or. a(2) /= 'Ta' .or. a(3) /= 'Ha') then
+ call abort ()
+ end if
+
+ a = (/ character(len=8) :: trim(b(1)), trim(b(2)), trim(b(3)) /)
+ if (a(1) /= 'Takata' .or. a(2) /= 'Tanaka' .or. a(3) /= 'Hayashi') then
+ call abort ()
+ end if
+
+end program test
--- /dev/null
+! { dg-do run }
+! { dg-options "-fbounds-check" }
+!
+! PR fortran/27997
+!
+! Array constructor with typespec and dynamic
+! character length.
+!
+PROGRAM test
+ CALL foo(8, "short", "test", "short")
+ CALL foo(2, "lenghty", "te", "le")
+CONTAINS
+ SUBROUTINE foo (n, s, a1, a2)
+ CHARACTER(len=*) :: s
+ CHARACTER(len=*) :: a1, a2
+ CHARACTER(len=n) :: arr(2)
+ INTEGER :: n
+ arr = [ character(len=n) :: 'test', s ]
+ IF (arr(1) /= a1 .OR. arr(2) /= a2) THEN
+ CALL abort ()
+ END IF
+ END SUBROUTINE foo
+END PROGRAM test
--- /dev/null
+! { dg-do run }
+!
+! PR fortran/27997
+!
+! Array constructor with typespec, check for regression
+!
+program test
+ implicit none
+ type :: real_info
+ integer :: kind
+ end type real_info
+ type (real_info) :: real_infos(1) = (/ real_info (4) /)
+end program test
--- /dev/null
+! { dg-do run }
+!
+! PR fortran/27997
+!
+! Array constructor with typespec, check for regression
+! with fixed form.
+!
+ integer :: a(2), realabc, real_abc2
+ a = [ realabc, real_abc2 ]
+ end
projects / gcc.git / commitdiff