https://gcc.gnu.org/g:c50d263beff78ab1133ccff1de78a50ea4851d7e
commit r16-5803-gc50d263beff78ab1133ccff1de78a50ea4851d7e Author: Christopher Albert <[email protected]> Date: Tue Nov 25 00:13:03 2025 +0100 fortran: Honor array constructor type-spec during folding [PR107721] When an array constructor has an explicit type-spec, all elements must be converted to that type and character elements must be padded/truncated to the specified length. This was working for simple cases but failing when: 1. Elements were parenthesized: [integer :: ([1.0])] 2. Constructors were nested: [[integer :: [1.0]]] 3. Character constructors were used with concatenation operators: [character(16) :: 'a', 'b'] // '|' 4. Nested character constructors with concatenation: [character(16) :: ['a', 'b']] // '|' 5. Outer constructor without type-spec wrapping inner with type-spec: [[character(16) :: ['a', 'b']]] // '|' 6. Nested character constructors with different type-specs: [character(16) :: [character(2) :: 'abcd']] The root cause was twofold: First, parenthesized expressions like ([1.0]) create EXPR_OP nodes that were not being simplified before type conversion in check_constructor_type(), so type conversion was applied to the EXPR_OP rather than its contents. Second, character array constructors with explicit type-spec were not being resolved before CONCAT operations in eval_intrinsic(), so elements retained their original lengths instead of being padded to the type-spec length. Additionally, nested array constructors needed their type-spec propagated from the outer constructor. The fix adds: - Simplification of non-constant expressions in check_constructor_type() before attempting type conversion - Call to gfc_check_constructor_type() in eval_intrinsic() to ensure type-spec conversion happens before any operations on array constructors - Character array constructor resolution before CONCAT operations - Recursive type-spec propagation for nested array constructors. When a nested array constructor has its own explicit type-spec, it is resolved first to enforce its own length (truncation/padding) before propagating the outer type-spec and resolving again. - Detection of nested character constructors with explicit type-spec (via length_from_typespec) when the outer constructor has no type-spec PR fortran/107721 PR fortran/102417 gcc/fortran/ChangeLog: * arith.cc (eval_intrinsic): Call gfc_check_constructor_type on array constructor operands with explicit type-spec to ensure element type conversion before operations. Resolve character array constructors before CONCAT operations. (reduce_binary_ac, reduce_binary_ca, reduce_binary_aa): Preserve character length info in result arrays. * array.cc (check_constructor_type): Simplify non-constant expressions before type checking to handle parenthesized elements. Handle nested character array constructors with explicit type-spec when outer constructor has no type-spec. (gfc_resolve_character_array_constructor): Recursively propagate type-spec to nested array constructors. If the nested constructor has an explicit type-spec, resolve it first before propagating the outer type-spec. gcc/testsuite/ChangeLog: * gfortran.dg/array_constructor_typespec_1.f90: New test. Co-authored-by: Harald Anlauf <[email protected]> Signed-off-by: Christopher Albert <[email protected]> Diff: --- gcc/fortran/arith.cc | 35 +++ gcc/fortran/array.cc | 101 +++++-- .../gfortran.dg/array_constructor_typespec_1.f90 | 326 +++++++++++++++++++++ 3 files changed, 441 insertions(+), 21 deletions(-) diff --git a/gcc/fortran/arith.cc b/gcc/fortran/arith.cc index 82a8b6fb9951..142f1b092840 100644 --- a/gcc/fortran/arith.cc +++ b/gcc/fortran/arith.cc @@ -1565,6 +1565,8 @@ reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, &op1->where); r->shape = gfc_copy_shape (op1->shape, op1->rank); + if (c->expr->ts.type == BT_CHARACTER) + r->ts.u.cl = c->expr->ts.u.cl; } else { @@ -1572,6 +1574,8 @@ reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), r = gfc_get_array_expr (op1->ts.type, op1->ts.kind, &op1->where); r->shape = gfc_get_shape (op1->rank); + if (op1->ts.type == BT_CHARACTER) + r->ts.u.cl = op1->ts.u.cl; } r->rank = op1->rank; r->corank = op1->corank; @@ -1629,6 +1633,8 @@ reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, &op2->where); r->shape = gfc_copy_shape (op2->shape, op2->rank); + if (c->expr->ts.type == BT_CHARACTER) + r->ts.u.cl = c->expr->ts.u.cl; } else { @@ -1636,6 +1642,8 @@ reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), r = gfc_get_array_expr (op2->ts.type, op2->ts.kind, &op2->where); r->shape = gfc_get_shape (op2->rank); + if (op2->ts.type == BT_CHARACTER) + r->ts.u.cl = op2->ts.u.cl; } r->rank = op2->rank; r->corank = op2->corank; @@ -1697,11 +1705,15 @@ reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **), { /* Handle zero-sized arrays. */ r = gfc_get_array_expr (op1->ts.type, op1->ts.kind, &op1->where); + if (op1->ts.type == BT_CHARACTER) + r->ts.u.cl = op1->ts.u.cl; } else { r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind, &op1->where); + if (c->expr->ts.type == BT_CHARACTER) + r->ts.u.cl = c->expr->ts.u.cl; } r->shape = gfc_copy_shape (op1->shape, op1->rank); r->rank = op1->rank; @@ -1921,6 +1933,29 @@ eval_intrinsic (gfc_intrinsic_op op, || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2))) goto runtime; + /* For array constructors with explicit type-spec, ensure elements are + converted to the specified type before any operations. This handles + cases like [integer :: ([1.0])] ** 2 where parentheses would otherwise + cause the type-spec to be lost during constant folding. */ + if (op1->expr_type == EXPR_ARRAY && op1->ts.type != BT_UNKNOWN) + gfc_check_constructor_type (op1); + if (op2 != NULL && op2->expr_type == EXPR_ARRAY && op2->ts.type != BT_UNKNOWN) + gfc_check_constructor_type (op2); + + /* For CONCAT operations, also resolve character array constructors to + ensure elements are padded to the specified length before concatenation. + This ensures [character(16):: 'a','b'] // '|' pads to 16 chars first. */ + if (op == INTRINSIC_CONCAT) + { + if (op1->expr_type == EXPR_ARRAY && op1->ts.type == BT_CHARACTER + && op1->ts.u.cl && op1->ts.u.cl->length_from_typespec) + gfc_resolve_character_array_constructor (op1); + if (op2 != NULL && op2->expr_type == EXPR_ARRAY + && op2->ts.type == BT_CHARACTER + && op2->ts.u.cl && op2->ts.u.cl->length_from_typespec) + gfc_resolve_character_array_constructor (op2); + } + if (unary) rc = reduce_unary (eval.f2, op1, &result); else diff --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc index 57a7b134e4c2..359d743a632f 100644 --- a/gcc/fortran/array.cc +++ b/gcc/fortran/array.cc @@ -1549,10 +1549,37 @@ check_constructor_type (gfc_constructor_base base, bool convert) { e = c->expr; + /* Simplify non-constant expressions (like parenthesized arrays) so type + conversion can work on the simplified result. This handles cases like + [integer :: ([1.0])] where ([1.0]) is an EXPR_OP that needs to be + simplified to an EXPR_ARRAY before type conversion. */ + if (convert && e->expr_type != EXPR_CONSTANT + && e->expr_type != EXPR_ARRAY) + gfc_simplify_expr (e, 0); + if (e->expr_type == EXPR_ARRAY) { - if (!check_constructor_type (e->value.constructor, convert)) - return false; + /* If the outer constructor has no type-spec (convert=false) and + the nested array has an explicit type-spec, process it separately + so its elements get converted according to its type-spec. This + handles cases like [[character(16) :: ['a','b']]] where the outer + constructor has no type-spec but the inner one does. + gfc_check_constructor_type will also update the global + constructor_ts and cons_state which propagates the type info + to the outer constructor. + For character types, length_from_typespec indicates an explicit + type-spec was provided. */ + if (!convert && e->ts.type == BT_CHARACTER + && e->ts.u.cl && e->ts.u.cl->length_from_typespec) + { + if (!gfc_check_constructor_type (e)) + return false; + } + else + { + if (!check_constructor_type (e->value.constructor, convert)) + return false; + } continue; } @@ -2261,10 +2288,14 @@ gfc_resolve_character_array_constructor (gfc_expr *expr) { gfc_constructor *p; HOST_WIDE_INT found_length; + bool has_ts; gcc_assert (expr->expr_type == EXPR_ARRAY); gcc_assert (expr->ts.type == BT_CHARACTER); + /* Check if we have an explicit type-spec with length. */ + has_ts = expr->ts.u.cl && expr->ts.u.cl->length_from_typespec; + if (expr->ts.u.cl == NULL) { for (p = gfc_constructor_first (expr->value.constructor); @@ -2367,28 +2398,56 @@ got_charlen: if (found_length != -1) for (p = gfc_constructor_first (expr->value.constructor); p; p = gfc_constructor_next (p)) - if (p->expr->expr_type == EXPR_CONSTANT) - { - gfc_expr *cl = NULL; - HOST_WIDE_INT current_length = -1; - bool has_ts; + { + /* For non-constant expressions (like EXPR_OP from concatenation), + try to simplify them first so we can then pad/truncate. */ + if (p->expr->expr_type != EXPR_CONSTANT + && p->expr->ts.type == BT_CHARACTER) + gfc_simplify_expr (p->expr, 0); - if (p->expr->ts.u.cl && p->expr->ts.u.cl->length) + if (p->expr->expr_type == EXPR_CONSTANT) { - cl = p->expr->ts.u.cl->length; - gfc_extract_hwi (cl, ¤t_length); + gfc_expr *cl = NULL; + HOST_WIDE_INT current_length = -1; + + if (p->expr->ts.u.cl && p->expr->ts.u.cl->length) + { + cl = p->expr->ts.u.cl->length; + gfc_extract_hwi (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 (! cl + || (current_length != -1 && current_length != found_length)) + gfc_set_constant_character_len (found_length, p->expr, + has_ts ? -1 : found_length); } - - /* If gfc_extract_int above set current_length, we implicitly - know the type is BT_INTEGER and it's EXPR_CONSTANT. */ - - has_ts = expr->ts.u.cl->length_from_typespec; - - if (! cl - || (current_length != -1 && current_length != found_length)) - gfc_set_constant_character_len (found_length, p->expr, - has_ts ? -1 : found_length); - } + else if (p->expr->expr_type == EXPR_ARRAY) + { + /* For nested array constructors, propagate the type-spec and + recursively resolve. This handles cases like + [character(16) :: ['a','b']] // "|". The inner constructor + may have BT_UNKNOWN type initially. */ + if (p->expr->ts.type == BT_UNKNOWN + || p->expr->ts.type == BT_CHARACTER) + { + if (p->expr->ts.type == BT_CHARACTER + && p->expr->ts.u.cl + && p->expr->ts.u.cl->length_from_typespec) + { + /* If the inner array has an explicit type-spec, we must + honor it first (e.g. truncate/pad to its length), + before coercing it to the outer length. */ + gfc_resolve_character_array_constructor (p->expr); + } + + p->expr->ts = expr->ts; + gfc_resolve_character_array_constructor (p->expr); + } + } + } } return true; diff --git a/gcc/testsuite/gfortran.dg/array_constructor_typespec_1.f90 b/gcc/testsuite/gfortran.dg/array_constructor_typespec_1.f90 new file mode 100644 index 000000000000..1e5989fd802e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/array_constructor_typespec_1.f90 @@ -0,0 +1,326 @@ +! { dg-do run } +! PR fortran/107721 - array constructor type-spec lost with parentheses +! PR fortran/102417 - character array constructor type-spec lost +! +! Tests type-spec preservation in array constructors with parentheses, +! nested constructors, and CLASS(*) type verification for all intrinsic types. + +program array_constructor_typespec_1 + implicit none + integer :: i, iscalar + integer, dimension(2) :: iarr + real, dimension(2) :: rarr + real :: rscalar + complex, dimension(2) :: carr + complex :: cscalar + logical, dimension(2) :: larr + character(4), dimension(3) :: charr + character(8), dimension(2) :: charr8 + character(16), dimension(3) :: charr16 + character(16), dimension(2) :: charr16_2 + character(:), allocatable :: charr17(:) + character :: x = 'a', y = 'b' + class(*), allocatable :: res(:) + character(10), dimension(1) :: charr10 + character(4), dimension(1) :: charr4_1 + character(:), allocatable :: charr0(:) + character(4), dimension(0) :: empty4 + + ! INTEGER - runtime value checks + iarr = [integer :: [1.0], [2.0]] + if (any(iarr /= [1, 2])) stop 1 + iarr = [integer :: ([1.0]), ([2.0])] + if (any(iarr /= [1, 2])) stop 2 + iarr = [integer :: ((([1.0]))), [2.0]] + if (any(iarr /= [1, 2])) stop 3 + + ! REAL - runtime value checks + rarr = [real :: [2], [3]] + if (any(rarr /= [2.0, 3.0])) stop 4 + rarr = [real :: ([2]), ([3])] + if (any(rarr /= [2.0, 3.0])) stop 5 + rarr = [real :: ((([2]))), [3]] + if (any(rarr /= [2.0, 3.0])) stop 6 + + ! COMPLEX - runtime value checks + carr = [complex :: [3], [4]] + if (any(carr /= [(3.0, 0.0), (4.0, 0.0)])) stop 7 + carr = [complex :: ([3]), ([4])] + if (any(carr /= [(3.0, 0.0), (4.0, 0.0)])) stop 8 + carr = [complex :: ((([3]))), [4]] + if (any(carr /= [(3.0, 0.0), (4.0, 0.0)])) stop 9 + + ! LOGICAL - runtime value checks + larr = [logical :: [.true.], [.false.]] + if (any(larr .neqv. [.true., .false.])) stop 10 + larr = [logical :: ([.true.]), ([.false.])] + if (any(larr .neqv. [.true., .false.])) stop 11 + + ! CHARACTER - runtime value checks (PR 102417) + charr = [character(4) :: 'a', 'b', 'c'] + if (any(charr /= ['a ', 'b ', 'c '])) stop 12 + charr = [character(4) :: ('a'), 'b', 'c'] + if (any(charr /= ['a ', 'b ', 'c '])) stop 13 + charr = [[character(4) :: 'a', 'b', 'c']] + if (any(charr /= ['a ', 'b ', 'c '])) stop 14 + + ! CHARACTER with nested constructors - length 8 + charr8 = [character(8) :: 'x', 'y'] + if (charr8(1) /= 'x ') stop 15 + if (charr8(2) /= 'y ') stop 16 + + charr8 = [character(8) :: ['a', 'b']] + if (charr8(1) /= 'a ') stop 17 + if (charr8(2) /= 'b ') stop 18 + + ! Outer constructor without type-spec, inner with type-spec. + ! With proper type-spec propagation, no length mismatch warning is needed. + charr8 = [[character(8) :: ['a', 'b']]] + if (charr8(1) /= 'a ') stop 19 + if (charr8(2) /= 'b ') stop 20 + + ! Triple-nested constructor with type-spec in middle. + charr8 = [[[character(8) :: ['a', 'b']]]] + if (charr8(1) /= 'a ') stop 21 + if (charr8(2) /= 'b ') stop 22 + + charr8 = [character(8) :: (x), (y)] + if (charr8(1) /= 'a ') stop 23 + if (charr8(2) /= 'b ') stop 24 + + charr8 = [[character(8) :: (x), (y)]] + if (charr8(1) /= 'a ') stop 25 + if (charr8(2) /= 'b ') stop 26 + + ! CHARACTER concatenation with parentheses (PR 107721 comment 14) + charr16_2 = [character(16) :: 'a' // 'c', 'b' // 'de'] + if (charr16_2(1) /= 'ac ') stop 101 + if (charr16_2(2) /= 'bde ') stop 102 + + charr16_2 = [character(16) :: 'a' // 'c', ('b' // 'de')] + if (charr16_2(1) /= 'ac ') stop 103 + if (charr16_2(2) /= 'bde ') stop 104 + + charr16_2 = [character(16) :: ('a' // 'c'), 'b' // 'de'] + if (charr16_2(1) /= 'ac ') stop 105 + if (charr16_2(2) /= 'bde ') stop 106 + + ! CHARACTER concatenation after constructor - verify length 17 + charr17 = [character(16) :: 'a' // 'c', 'b' // 'de'] // '|' + if (len(charr17) /= 17) stop 107 + if (charr17(1) /= 'ac |') stop 108 + if (charr17(2) /= 'bde |') stop 109 + + charr17 = [character(16) :: 'a' // 'c', ('b' // 'de')] // '|' + if (len(charr17) /= 17) stop 110 + if (charr17(1) /= 'ac |') stop 111 + if (charr17(2) /= 'bde |') stop 112 + + charr17 = [character(16) :: ('a' // 'c'), 'b' // 'de'] // '|' + if (len(charr17) /= 17) stop 113 + if (charr17(1) /= 'ac |') stop 114 + if (charr17(2) /= 'bde |') stop 115 + + ! CHARACTER - longer length 16 + charr16 = [character(16) :: 'a', 'b', 'c'] + if (charr16(1) /= 'a ') stop 27 + if (charr16(2) /= 'b ') stop 28 + if (charr16(3) /= 'c ') stop 29 + + charr16 = [[character(16) :: 'a', 'b', 'c']] + if (charr16(1) /= 'a ') stop 30 + if (charr16(2) /= 'b ') stop 31 + if (charr16(3) /= 'c ') stop 32 + + ! CHARACTER - truncation cases + charr8 = [character(8) :: 'abcdefghij', 'klmnopqrst'] + if (charr8(1) /= 'abcdefgh') stop 33 + if (charr8(2) /= 'klmnopqr') stop 34 + + charr8 = [[character(8) :: 'abcdefghij', 'klmnopqrst']] + if (charr8(1) /= 'abcdefgh') stop 35 + if (charr8(2) /= 'klmnopqr') stop 36 + + ! Implied-do with parentheses + iarr = [integer :: (/(1.0*i, i=1, 2)/)] + if (any(iarr /= [1, 2])) stop 37 + iarr = [integer :: ((/(1.0*i, i=1, 2)/))] + if (any(iarr /= [1, 2])) stop 38 + + ! Type verification with CLASS(*) - ensure types are actually converted + res = [integer :: ([1.0])] + call verify_integer (res, 42) + deallocate (res) + + res = [integer :: ([1.0]), ([2.0])] + call verify_integer (res, 43) + deallocate (res) + + res = [real :: ([2]), [3]] + call verify_real (res, 44) + deallocate (res) + + res = [complex :: ([3])] + call verify_complex (res, 45) + deallocate (res) + + res = [logical :: ([.true.]), [.false.]] + call verify_logical (res, 46) + deallocate (res) + + ! Parenthesized constructors - verify result TYPE not just value + res = [integer :: ([1.0])] ** 2 + call verify_integer (res, 47) + deallocate (res) + + res = [real :: ([2]), [3]] ** 2 + call verify_real (res, 48) + deallocate (res) + + res = [complex :: ([3])] ** 2 + call verify_complex (res, 49) + deallocate (res) + + ! Harald's test cases from Comment #17 - scalar // constructor patterns + charr17 = '|' // [character(16) :: 'a' // 'c', 'b' // 'de'] + if (len(charr17) /= 17) stop 116 + if (charr17(1) /= '|ac ') stop 117 + if (charr17(2) /= '|bde ') stop 118 + + charr17 = '|' // [character(16) :: 'a' // 'c', ('b' // 'de')] + if (len(charr17) /= 17) stop 119 + if (charr17(1) /= '|ac ') stop 120 + if (charr17(2) /= '|bde ') stop 121 + + charr17 = '|' // [character(16) :: ('a' // 'c'), 'b' // 'de'] + if (len(charr17) /= 17) stop 122 + if (charr17(1) /= '|ac ') stop 123 + if (charr17(2) /= '|bde ') stop 124 + + ! Comment #11: Nested array constructor with concatenation + ! The inner ['a','b'] must be padded to length 16 before concat + charr17 = [character(16) :: ['a', 'b']] // '|' + if (len(charr17) /= 17) stop 125 + if (charr17(1) /= 'a |') stop 126 + if (charr17(2) /= 'b |') stop 127 + + ! Comment #18: Outer constructor without type-spec wrapping inner with + ! type-spec. The type-spec must be propagated when flattening. + charr17 = [[character(16) :: ['a', 'b']]] // '|' + if (len(charr17) /= 17) stop 128 + if (charr17(1) /= 'a |') stop 129 + if (charr17(2) /= 'b |') stop 130 + + charr17 = '|' // [[character(16) :: ['a', 'b']]] + if (len(charr17) /= 17) stop 131 + if (charr17(1) /= '|a ') stop 132 + if (charr17(2) /= '|b ') stop 133 + + ! Harald's new test cases from Comment #22 - nested truncation and padding + ! [ character(2) :: ['abcd','efgh'] ] should truncate to 'ab', 'ef' + ! Then [ character(16) :: ... ] should pad to 'ab ', 'ef ' + + charr16_2 = [ character(16) :: [ character(2) :: ['abcd','efgh'] ] ] + if (charr16_2(1) /= 'ab ') stop 134 + if (charr16_2(2) /= 'ef ') stop 135 + + charr17 = [ character(16) :: [ character(2) :: ['abcd','efgh'] ] ] // "|" + if (len(charr17) /= 17) stop 136 + if (charr17(1) /= 'ab |') stop 137 + if (charr17(2) /= 'ef |') stop 138 + + charr17 = "|" // [ character(16) :: [ character(2) :: ['abcd','efgh'] ] ] + if (len(charr17) /= 17) stop 139 + if (charr17(1) /= '|ab ') stop 140 + if (charr17(2) /= '|ef ') stop 141 + + charr16_2 = [ character(16) :: ([ character(2) :: ['abcd','efgh'] ])] + if (charr16_2(1) /= 'ab ') stop 142 + if (charr16_2(2) /= 'ef ') stop 143 + + charr17 = [ character(16) :: ([ character(2) :: ['abcd','efgh'] ])] // "|" + if (len(charr17) /= 17) stop 144 + if (charr17(1) /= 'ab |') stop 145 + if (charr17(2) /= 'ef |') stop 146 + + charr17 = "|" // [ character(16) :: ([ character(2) :: ['abcd','efgh'] ])] + if (len(charr17) /= 17) stop 147 + if (charr17(1) /= '|ab ') stop 148 + if (charr17(2) /= '|ef ') stop 149 + deallocate (charr17) + + ! Additional torture tests + ! Triple nesting with explicit types: 'abcde'(5) -> 'ab'(2) -> 'ab '(10) + charr10 = [character(10) :: [character(2) :: [character(5) :: 'abcde']]] + if (charr10(1) /= 'ab ') stop 150 + + ! Concatenation of constructors + ! 'a'(2) // 'b'(3) -> 'a b '(5) -> 'a b '(4) + charr4_1 = [character(4) :: [character(2) :: 'a'] // [character(3) :: 'b']] + if (charr4_1(1) /= 'a b ') stop 151 + + ! Zero length strings + ! Inner zero length: 'abc' -> ''(0) -> ' '(4) + charr4_1 = [character(4) :: [character(0) :: 'abc']] + if (charr4_1(1) /= ' ') stop 152 + + ! Outer zero length: 'abc' -> 'abc '(4) -> ''(0) + charr0 = [character(0) :: [character(4) :: 'abc']] + if (len(charr0) /= 0) stop 153 + if (charr0(1) /= '') stop 154 + deallocate (charr0) + + ! Empty array constructors + empty4 = [character(4) :: ] + if (size(empty4) /= 0) stop 155 + + empty4 = [character(4) :: [character(2) :: ]] + if (size(empty4) /= 0) stop 156 + +contains + + subroutine verify_integer (x, stopcode) + class(*), intent(in) :: x(:) + integer, intent(in) :: stopcode + select type (x) + type is (integer) + ! Correct type + class default + stop stopcode + end select + end subroutine verify_integer + + subroutine verify_real (x, stopcode) + class(*), intent(in) :: x(:) + integer, intent(in) :: stopcode + select type (x) + type is (real) + ! Correct type + class default + stop stopcode + end select + end subroutine verify_real + + subroutine verify_complex (x, stopcode) + class(*), intent(in) :: x(:) + integer, intent(in) :: stopcode + select type (x) + type is (complex) + ! Correct type + class default + stop stopcode + end select + end subroutine verify_complex + + subroutine verify_logical (x, stopcode) + class(*), intent(in) :: x(:) + integer, intent(in) :: stopcode + select type (x) + type is (logical) + ! Correct type + class default + stop stopcode + end select + end subroutine verify_logical + +end program array_constructor_typespec_1
