diff --git a/Fortran/gfortran/regression/abort_shouldfail.f90 b/Fortran/gfortran/regression/abort_shouldfail.f90 --- /dev/null +++ b/Fortran/gfortran/regression/abort_shouldfail.f90 @@ -0,0 +1,5 @@ +! { dg-do run } +! { dg-shouldfail "Program aborted." } +program main + call abort +end program main diff --git a/Fortran/gfortran/regression/abstract_type_1.f90 b/Fortran/gfortran/regression/abstract_type_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/abstract_type_1.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-std=f95" } + +! Abstract Types. +! Check that ABSTRACT is rejected for F95. + +MODULE m + + TYPE, ABSTRACT :: t ! { dg-error "Fortran 2003" } + INTEGER :: x + END TYPE t ! { dg-error "END MODULE" } + +END MODULE m diff --git a/Fortran/gfortran/regression/abstract_type_2.f03 b/Fortran/gfortran/regression/abstract_type_2.f03 --- /dev/null +++ b/Fortran/gfortran/regression/abstract_type_2.f03 @@ -0,0 +1,13 @@ +! { dg-do compile } + +! Abstract Types. +! Check for parser errors. + +MODULE m + IMPLICIT NONE + + TYPE, ABSTRACT, EXTENDS(abst_t), ABSTRACT :: error_t ! { dg-error "Duplicate ABSTRACT attribute" } + INTEGER :: y + END TYPE error_t ! { dg-error "END MODULE" } + +END MODULE m diff --git a/Fortran/gfortran/regression/abstract_type_3.f03 b/Fortran/gfortran/regression/abstract_type_3.f03 --- /dev/null +++ b/Fortran/gfortran/regression/abstract_type_3.f03 @@ -0,0 +1,51 @@ +! { dg-do compile } + +! Abstract Types. +! Check for errors when using abstract types in an inappropriate way. + +MODULE m + USE ISO_C_BINDING + IMPLICIT NONE + + TYPE, ABSTRACT, BIND(C) :: bindc_t ! { dg-error "must not be ABSTRACT" } + INTEGER(C_INT) :: x + END TYPE bindc_t + + TYPE, ABSTRACT :: sequence_t ! { dg-error "must not be ABSTRACT" } + SEQUENCE + INTEGER :: x + END TYPE sequence_t + + TYPE, ABSTRACT :: abst_t + INTEGER :: x = 0 + END TYPE abst_t + + TYPE, EXTENDS(abst_t) :: concrete_t + INTEGER :: y = 1 + END TYPE concrete_t + + TYPE :: myt + TYPE(abst_t) :: comp ! { dg-error "is of the ABSTRACT type 'abst_t'" } + END TYPE myt + + ! This should be ok. + TYPE, ABSTRACT, EXTENDS(concrete_t) :: again_abst_t + INTEGER :: z = 2 + END TYPE again_abst_t + +CONTAINS + + TYPE(abst_t) FUNCTION func () ! { dg-error "of the ABSTRACT type 'abst_t'" } + END FUNCTION func + + SUBROUTINE sub (arg) ! { dg-error "is of the ABSTRACT type 'again_abst_t'" } + IMPLICIT NONE + TYPE(again_abst_t) :: arg + arg = again_abst_t () ! { dg-error "Cannot construct ABSTRACT type 'again_abst_t'" } + END SUBROUTINE sub + + SUBROUTINE impl () + IMPLICIT TYPE(abst_t) (a-z) ! { dg-error "ABSTRACT type 'abst_t' used" } + END SUBROUTINE impl + +END MODULE m diff --git a/Fortran/gfortran/regression/abstract_type_4.f03 b/Fortran/gfortran/regression/abstract_type_4.f03 --- /dev/null +++ b/Fortran/gfortran/regression/abstract_type_4.f03 @@ -0,0 +1,28 @@ +! { dg-do compile } + +! Abstract Types. +! Check for module file IO. + +MODULE m + IMPLICIT NONE + + TYPE, ABSTRACT :: abst_t + INTEGER :: x + END TYPE abst_t + + TYPE, EXTENDS(abst_t) :: concrete_t + INTEGER :: y + END TYPE concrete_t + +END MODULE m + +PROGRAM main + USE m + IMPLICIT NONE + + TYPE(abst_t) :: abst ! { dg-error "is of the ABSTRACT type 'abst_t'" } + TYPE(concrete_t) :: conc + + ! See if constructing the extending type works. + conc = concrete_t (1, 2) +END PROGRAM main diff --git a/Fortran/gfortran/regression/abstract_type_5.f03 b/Fortran/gfortran/regression/abstract_type_5.f03 --- /dev/null +++ b/Fortran/gfortran/regression/abstract_type_5.f03 @@ -0,0 +1,45 @@ +! { dg-do compile } + +! Abstract Types. +! Check for correct handling of abstract-typed base object references. + +MODULE m + IMPLICIT NONE + + TYPE, ABSTRACT :: abstract_t + INTEGER :: i + CONTAINS + PROCEDURE, NOPASS :: proc + PROCEDURE, NOPASS :: func + END TYPE abstract_t + + TYPE, EXTENDS(abstract_t) :: concrete_t + END TYPE concrete_t + +CONTAINS + + SUBROUTINE proc () + IMPLICIT NONE + ! Do nothing + END SUBROUTINE proc + + INTEGER FUNCTION func () + IMPLICIT NONE + func = 1234 + END FUNCTION func + + SUBROUTINE test () + IMPLICIT NONE + TYPE(concrete_t) :: obj + + ! These are ok. + obj%abstract_t%i = 42 + CALL obj%proc () + PRINT *, obj%func () + + ! These are errors (even though the procedures are not DEFERRED!). + CALL obj%abstract_t%proc () ! { dg-error "is of ABSTRACT type" } + PRINT *, obj%abstract_t%func () ! { dg-error "is of ABSTRACT type" } + END SUBROUTINE test + +END MODULE m diff --git a/Fortran/gfortran/regression/abstract_type_6.f03 b/Fortran/gfortran/regression/abstract_type_6.f03 --- /dev/null +++ b/Fortran/gfortran/regression/abstract_type_6.f03 @@ -0,0 +1,52 @@ +! { dg-do compile } +! Test the fix for PR43266, in which an ICE followed correct error messages. +! +! Contributed by Tobias Burnus +! Reported in http://groups.google.ca/group/comp.lang.fortran/browse_thread/thread/f5ec99089ea72b79 +! +!---------------- +! library code + +module m +TYPE, ABSTRACT :: top +CONTAINS + PROCEDURE(xxx), DEFERRED :: proc_a ! { dg-error "must be explicit" } + ! some useful default behavior + PROCEDURE :: proc_c => top_c ! { dg-error "must be a module procedure" } +END TYPE top + +! Concrete middle class with useful behavior +TYPE, EXTENDS(top) :: middle +CONTAINS + ! do nothing, empty proc just to make middle concrete + PROCEDURE :: proc_a => dummy_middle_a ! { dg-error "must be a module procedure" } + ! some useful default behavior + PROCEDURE :: proc_b => middle_b ! { dg-error "must be a module procedure" } +END TYPE middle + +!---------------- +! client code + +TYPE, EXTENDS(middle) :: bottom +CONTAINS + ! useful proc to satisfy deferred procedure in top. Because we've + ! extended middle we wouldn't get told off if we forgot this. + PROCEDURE :: proc_a => bottom_a ! { dg-error "must be a module procedure" } + ! calls middle%proc_b and then provides extra behavior + PROCEDURE :: proc_b => bottom_b + ! calls top_c and then provides extra behavior + PROCEDURE :: proc_c => bottom_c +END TYPE bottom +contains +SUBROUTINE bottom_b(obj) + CLASS(Bottom) :: obj + CALL obj%middle%proc_b ! { dg-error "should be a SUBROUTINE" } + ! other stuff +END SUBROUTINE bottom_b + +SUBROUTINE bottom_c(obj) + CLASS(Bottom) :: obj + CALL top_c(obj) ! { dg-error "Explicit interface required" } + ! other stuff +END SUBROUTINE bottom_c +end module diff --git a/Fortran/gfortran/regression/abstract_type_7.f03 b/Fortran/gfortran/regression/abstract_type_7.f03 --- /dev/null +++ b/Fortran/gfortran/regression/abstract_type_7.f03 @@ -0,0 +1,17 @@ +! { dg-do compile } +! +! PR 44213: ICE when extending abstract type +! +! Contributed by Hans-Werner Boschmann + +module ice_module + type :: a_type + end type a_type + + type,extends(a_type),abstract :: b_type + end type b_type + + type,extends(b_type) :: c_type + end type c_type +end module ice_module + diff --git a/Fortran/gfortran/regression/abstract_type_8.f03 b/Fortran/gfortran/regression/abstract_type_8.f03 --- /dev/null +++ b/Fortran/gfortran/regression/abstract_type_8.f03 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! PR 44616: [OOP] ICE if CLASS(foo) is used before its definition +! +! Contributed by bd satish + +module factory_pattern +implicit none + +type First_Factory + character(len=20) :: factory_type + class(Connection), pointer :: connection_type + contains +end type First_Factory + +type, abstract :: Connection + contains + procedure(generic_desc), deferred :: description +end type Connection + +abstract interface + subroutine generic_desc(self) + import ! Required, cf. PR 44614 + class(Connection) :: self + end subroutine generic_desc +end interface +end module factory_pattern diff --git a/Fortran/gfortran/regression/abstract_type_9.f90 b/Fortran/gfortran/regression/abstract_type_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/abstract_type_9.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! +! PR 43207: [OOP] invalid (pointer) assignment to and from abstract non-polymorphic expressions +! +! Contributed by Tobias Burnus + + implicit none + type, abstract :: parent + integer :: i + end type + type, extends(parent) :: child + class(parent), pointer :: comp + end type + + type(child), target :: c1 + class(child), allocatable :: c2 + class(parent), pointer :: cp + + c1%parent = c1%parent ! { dg-error "Nonpolymorphic reference to abstract type" } + c2%parent = c1%parent ! { dg-error "Nonpolymorphic reference to abstract type" } + + cp => c1%comp + cp => c1%parent ! { dg-error "Nonpolymorphic reference to abstract type" } + + call sub(c1%comp) + call sub(c1%parent) ! { dg-error "Nonpolymorphic reference to abstract type" } + +contains + + subroutine sub(arg) + class(parent) :: arg + end subroutine + +end diff --git a/Fortran/gfortran/regression/access_spec_1.f90 b/Fortran/gfortran/regression/access_spec_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/access_spec_1.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-require-visibility "" } +! PR fortran/31472 +! Access specifications: Valid Fortran 2003 code +module mod + implicit none + private + integer, public :: i + integer, private :: z + integer :: j, x + private :: j + public :: x + type, public :: bar + PRIVATE + integer, public :: y ! Fortran 2003 + integer, private :: z ! Fortran 2003 + end type +end module diff --git a/Fortran/gfortran/regression/access_spec_2.f90 b/Fortran/gfortran/regression/access_spec_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/access_spec_2.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! PR fortran/31472 +! Access specifications: Invalid Fortran 95 code + +module test + implicit none + integer, public :: x + public :: x ! { dg-error "was already specified" } + private :: x ! { dg-error "was already specified" } +end module test + +module mod + implicit none + private + type, public :: bar + PRIVATE + integer, public :: y ! { dg-error "Fortran 2003: Attribute PUBLIC" } + integer, public :: z ! { dg-error "Fortran 2003: Attribute PUBLIC" } + end type ! { dg-error "Derived type definition at" } +contains + subroutine foo + integer :: x + private :: x ! { dg-error "only allowed in the specification part of a module" } + type, private :: t ! { dg-error "only be PRIVATE in the specification part of a module" } + integer :: z + end type t ! { dg-error "Expecting END SUBROUTINE statement" } + type :: ttt + integer,public :: z ! { dg-error "not allowed outside of the specification part of a module" } + end type ttt ! { dg-error "Derived type definition at" } + end subroutine +end module + +program x + implicit none + integer :: i + public :: i ! { dg-error "only allowed in the specification part of a module" } + integer,public :: j ! { dg-error "not allowed outside of the specification part of a module" } +end program x diff --git a/Fortran/gfortran/regression/access_spec_3.f90 b/Fortran/gfortran/regression/access_spec_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/access_spec_3.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! +! Tests the fix for PR36454, where the PUBLIC declaration for +! aint and bint was rejected because the access was already set. +! +! Contributed by Thomas Orgis + +module base + integer :: baseint +end module + +module a + use base, ONLY: aint => baseint +end module + +module b + use base, ONLY: bint => baseint +end module + +module c + use a + use b + private + public :: aint, bint +end module + +program user + use c, ONLY: aint, bint + + aint = 3 + bint = 8 + write(*,*) aint +end program diff --git a/Fortran/gfortran/regression/achar_1.f90 b/Fortran/gfortran/regression/achar_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/achar_1.f90 @@ -0,0 +1,8 @@ +! { dg-do run } +! achar() should work with all supported integer kinds. +program bug6 + integer(1) :: i = 65 + character a + a = achar(i) + if (a /= 'A') STOP 1 +end program bug6 diff --git a/Fortran/gfortran/regression/achar_2.f90 b/Fortran/gfortran/regression/achar_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/achar_2.f90 @@ -0,0 +1,2031 @@ +! { dg-do run } +! PR 30389 - we now treat ACHAR equivalent to CHAR (except for +! out of range-values) and IACHAR equivalent to ICHAR. +program main + integer :: i + character(len=1) :: c + if (iachar(achar(1)) /= 1) STOP 1 + if (iachar ("")/= 1) STOP 2 + if (achar (1) /= "") STOP 3 + if ("" /= achar ( ichar ( ""))) STOP 4 + i = 1 + c = "" + if (achar(i) /= "") STOP 5 + if (iachar(c) /= iachar("")) STOP 6 + if (iachar(achar(2)) /= 2) STOP 7 + if (iachar ("")/= 2) STOP 8 + if (achar (2) /= "") STOP 9 + if ("" /= achar ( ichar ( ""))) STOP 10 + i = 2 + c = "" + if (achar(i) /= "") STOP 11 + if (iachar(c) /= iachar("")) STOP 12 + if (iachar(achar(3)) /= 3) STOP 13 + if (iachar ("")/= 3) STOP 14 + if (achar (3) /= "") STOP 15 + if ("" /= achar ( ichar ( ""))) STOP 16 + i = 3 + c = "" + if (achar(i) /= "") STOP 17 + if (iachar(c) /= iachar("")) STOP 18 + if (iachar(achar(4)) /= 4) STOP 19 + if (iachar ("")/= 4) STOP 20 + if (achar (4) /= "") STOP 21 + if ("" /= achar ( ichar ( ""))) STOP 22 + i = 4 + c = "" + if (achar(i) /= "") STOP 23 + if (iachar(c) /= iachar("")) STOP 24 + if (iachar(achar(5)) /= 5) STOP 25 + if (iachar ("")/= 5) STOP 26 + if (achar (5) /= "") STOP 27 + if ("" /= achar ( ichar ( ""))) STOP 28 + i = 5 + c = "" + if (achar(i) /= "") STOP 29 + if (iachar(c) /= iachar("")) STOP 30 + if (iachar(achar(6)) /= 6) STOP 31 + if (iachar ("")/= 6) STOP 32 + if (achar (6) /= "") STOP 33 + if ("" /= achar ( ichar ( ""))) STOP 34 + i = 6 + c = "" + if (achar(i) /= "") STOP 35 + if (iachar(c) /= iachar("")) STOP 36 + if (iachar(achar(7)) /= 7) STOP 37 + if (iachar ("")/= 7) STOP 38 + if (achar (7) /= "") STOP 39 + if ("" /= achar ( ichar ( ""))) STOP 40 + i = 7 + c = "" + if (achar(i) /= "") STOP 41 + if (iachar(c) /= iachar("")) STOP 42 + if (iachar(achar(8)) /= 8) STOP 43 + if (iachar ("")/= 8) STOP 44 + if (achar (8) /= "") STOP 45 + if ("" /= achar ( ichar ( ""))) STOP 46 + i = 8 + c = "" + if (achar(i) /= "") STOP 47 + if (iachar(c) /= iachar("")) STOP 48 + if (iachar(achar(9)) /= 9) STOP 49 + if (iachar (" ")/= 9) STOP 50 + if (achar (9) /= " ") STOP 51 + if (" " /= achar ( ichar ( " "))) STOP 52 + i = 9 + c = " " + if (achar(i) /= " ") STOP 53 + if (iachar(c) /= iachar(" ")) STOP 54 + if (iachar(achar(10)) /= 10) STOP 55 + if (iachar(achar(11)) /= 11) STOP 56 + if (iachar (" ")/= 11) STOP 57 + if (achar (11) /= " ") STOP 58 + if (" " /= achar ( ichar ( " "))) STOP 59 + i = 11 + c = " " + if (achar(i) /= " ") STOP 60 + if (iachar(c) /= iachar(" ")) STOP 61 + if (iachar(achar(12)) /= 12) STOP 62 + if (iachar (" ")/= 12) STOP 63 + if (achar (12) /= " ") STOP 64 + if (" " /= achar ( ichar ( " "))) STOP 65 + i = 12 + c = " " + if (achar(i) /= " ") STOP 66 + if (iachar(c) /= iachar(" ")) STOP 67 + if (iachar(achar(13)) /= 13) STOP 68 + if (iachar(achar(14)) /= 14) STOP 69 + if (iachar ("")/= 14) STOP 70 + if (achar (14) /= "") STOP 71 + if ("" /= achar ( ichar ( ""))) STOP 72 + i = 14 + c = "" + if (achar(i) /= "") STOP 73 + if (iachar(c) /= iachar("")) STOP 74 + if (iachar(achar(15)) /= 15) STOP 75 + if (iachar ("")/= 15) STOP 76 + if (achar (15) /= "") STOP 77 + if ("" /= achar ( ichar ( ""))) STOP 78 + i = 15 + c = "" + if (achar(i) /= "") STOP 79 + if (iachar(c) /= iachar("")) STOP 80 + if (iachar(achar(16)) /= 16) STOP 81 + if (iachar ("")/= 16) STOP 82 + if (achar (16) /= "") STOP 83 + if ("" /= achar ( ichar ( ""))) STOP 84 + i = 16 + c = "" + if (achar(i) /= "") STOP 85 + if (iachar(c) /= iachar("")) STOP 86 + if (iachar(achar(17)) /= 17) STOP 87 + if (iachar ("")/= 17) STOP 88 + if (achar (17) /= "") STOP 89 + if ("" /= achar ( ichar ( ""))) STOP 90 + i = 17 + c = "" + if (achar(i) /= "") STOP 91 + if (iachar(c) /= iachar("")) STOP 92 + if (iachar(achar(18)) /= 18) STOP 93 + if (iachar ("")/= 18) STOP 94 + if (achar (18) /= "") STOP 95 + if ("" /= achar ( ichar ( ""))) STOP 96 + i = 18 + c = "" + if (achar(i) /= "") STOP 97 + if (iachar(c) /= iachar("")) STOP 98 + if (iachar(achar(19)) /= 19) STOP 99 + if (iachar ("")/= 19) STOP 100 + if (achar (19) /= "") STOP 101 + if ("" /= achar ( ichar ( ""))) STOP 102 + i = 19 + c = "" + if (achar(i) /= "") STOP 103 + if (iachar(c) /= iachar("")) STOP 104 + if (iachar(achar(20)) /= 20) STOP 105 + if (iachar ("")/= 20) STOP 106 + if (achar (20) /= "") STOP 107 + if ("" /= achar ( ichar ( ""))) STOP 108 + i = 20 + c = "" + if (achar(i) /= "") STOP 109 + if (iachar(c) /= iachar("")) STOP 110 + if (iachar(achar(21)) /= 21) STOP 111 + if (iachar ("")/= 21) STOP 112 + if (achar (21) /= "") STOP 113 + if ("" /= achar ( ichar ( ""))) STOP 114 + i = 21 + c = "" + if (achar(i) /= "") STOP 115 + if (iachar(c) /= iachar("")) STOP 116 + if (iachar(achar(22)) /= 22) STOP 117 + if (iachar ("")/= 22) STOP 118 + if (achar (22) /= "") STOP 119 + if ("" /= achar ( ichar ( ""))) STOP 120 + i = 22 + c = "" + if (achar(i) /= "") STOP 121 + if (iachar(c) /= iachar("")) STOP 122 + if (iachar(achar(23)) /= 23) STOP 123 + if (iachar ("")/= 23) STOP 124 + if (achar (23) /= "") STOP 125 + if ("" /= achar ( ichar ( ""))) STOP 126 + i = 23 + c = "" + if (achar(i) /= "") STOP 127 + if (iachar(c) /= iachar("")) STOP 128 + if (iachar(achar(24)) /= 24) STOP 129 + if (iachar ("")/= 24) STOP 130 + if (achar (24) /= "") STOP 131 + if ("" /= achar ( ichar ( ""))) STOP 132 + i = 24 + c = "" + if (achar(i) /= "") STOP 133 + if (iachar(c) /= iachar("")) STOP 134 + if (iachar(achar(25)) /= 25) STOP 135 + if (iachar ("")/= 25) STOP 136 + if (achar (25) /= "") STOP 137 + if ("" /= achar ( ichar ( ""))) STOP 138 + i = 25 + c = "" + if (achar(i) /= "") STOP 139 + if (iachar(c) /= iachar("")) STOP 140 + if (iachar(achar(26)) /= 26) STOP 141 + if (iachar(achar(27)) /= 27) STOP 142 + if (iachar ("")/= 27) STOP 143 + if (achar (27) /= "") STOP 144 + if ("" /= achar ( ichar ( ""))) STOP 145 + i = 27 + c = "" + if (achar(i) /= "") STOP 146 + if (iachar(c) /= iachar("")) STOP 147 + if (iachar(achar(28)) /= 28) STOP 148 + if (iachar ("")/= 28) STOP 149 + if (achar (28) /= "") STOP 150 + if ("" /= achar ( ichar ( ""))) STOP 151 + i = 28 + c = "" + if (achar(i) /= "") STOP 152 + if (iachar(c) /= iachar("")) STOP 153 + if (iachar(achar(29)) /= 29) STOP 154 + if (iachar ("")/= 29) STOP 155 + if (achar (29) /= "") STOP 156 + if ("" /= achar ( ichar ( ""))) STOP 157 + i = 29 + c = "" + if (achar(i) /= "") STOP 158 + if (iachar(c) /= iachar("")) STOP 159 + if (iachar(achar(30)) /= 30) STOP 160 + if (iachar ("")/= 30) STOP 161 + if (achar (30) /= "") STOP 162 + if ("" /= achar ( ichar ( ""))) STOP 163 + i = 30 + c = "" + if (achar(i) /= "") STOP 164 + if (iachar(c) /= iachar("")) STOP 165 + if (iachar(achar(31)) /= 31) STOP 166 + if (iachar ("")/= 31) STOP 167 + if (achar (31) /= "") STOP 168 + if ("" /= achar ( ichar ( ""))) STOP 169 + i = 31 + c = "" + if (achar(i) /= "") STOP 170 + if (iachar(c) /= iachar("")) STOP 171 + if (iachar(achar(32)) /= 32) STOP 172 + if (iachar (" ")/= 32) STOP 173 + if (achar (32) /= " ") STOP 174 + if (" " /= achar ( ichar ( " "))) STOP 175 + i = 32 + c = " " + if (achar(i) /= " ") STOP 176 + if (iachar(c) /= iachar(" ")) STOP 177 + if (iachar(achar(33)) /= 33) STOP 178 + if (iachar ("!")/= 33) STOP 179 + if (achar (33) /= "!") STOP 180 + if ("!" /= achar ( ichar ( "!"))) STOP 181 + i = 33 + c = "!" + if (achar(i) /= "!") STOP 182 + if (iachar(c) /= iachar("!")) STOP 183 + if (iachar(achar(34)) /= 34) STOP 184 + if (iachar ('"')/= 34) STOP 185 + if (achar (34) /= '"') STOP 186 + if ('"' /= achar ( ichar ( '"'))) STOP 187 + i = 34 + c = '"' + if (achar(i) /= '"') STOP 188 + if (iachar(c) /= iachar('"')) STOP 189 + if (iachar(achar(35)) /= 35) STOP 190 + if (iachar ("#")/= 35) STOP 191 + if (achar (35) /= "#") STOP 192 + if ("#" /= achar ( ichar ( "#"))) STOP 193 + i = 35 + c = "#" + if (achar(i) /= "#") STOP 194 + if (iachar(c) /= iachar("#")) STOP 195 + if (iachar(achar(36)) /= 36) STOP 196 + if (iachar ("$")/= 36) STOP 197 + if (achar (36) /= "$") STOP 198 + if ("$" /= achar ( ichar ( "$"))) STOP 199 + i = 36 + c = "$" + if (achar(i) /= "$") STOP 200 + if (iachar(c) /= iachar("$")) STOP 201 + if (iachar(achar(37)) /= 37) STOP 202 + if (iachar ("%")/= 37) STOP 203 + if (achar (37) /= "%") STOP 204 + if ("%" /= achar ( ichar ( "%"))) STOP 205 + i = 37 + c = "%" + if (achar(i) /= "%") STOP 206 + if (iachar(c) /= iachar("%")) STOP 207 + if (iachar(achar(38)) /= 38) STOP 208 + if (iachar ("&")/= 38) STOP 209 + if (achar (38) /= "&") STOP 210 + if ("&" /= achar ( ichar ( "&"))) STOP 211 + i = 38 + c = "&" + if (achar(i) /= "&") STOP 212 + if (iachar(c) /= iachar("&")) STOP 213 + if (iachar(achar(39)) /= 39) STOP 214 + if (iachar ("'")/= 39) STOP 215 + if (achar (39) /= "'") STOP 216 + if ("'" /= achar ( ichar ( "'"))) STOP 217 + i = 39 + c = "'" + if (achar(i) /= "'") STOP 218 + if (iachar(c) /= iachar("'")) STOP 219 + if (iachar(achar(40)) /= 40) STOP 220 + if (iachar ("(")/= 40) STOP 221 + if (achar (40) /= "(") STOP 222 + if ("(" /= achar ( ichar ( "("))) STOP 223 + i = 40 + c = "(" + if (achar(i) /= "(") STOP 224 + if (iachar(c) /= iachar("(")) STOP 225 + if (iachar(achar(41)) /= 41) STOP 226 + if (iachar (")")/= 41) STOP 227 + if (achar (41) /= ")") STOP 228 + if (")" /= achar ( ichar ( ")"))) STOP 229 + i = 41 + c = ")" + if (achar(i) /= ")") STOP 230 + if (iachar(c) /= iachar(")")) STOP 231 + if (iachar(achar(42)) /= 42) STOP 232 + if (iachar ("*")/= 42) STOP 233 + if (achar (42) /= "*") STOP 234 + if ("*" /= achar ( ichar ( "*"))) STOP 235 + i = 42 + c = "*" + if (achar(i) /= "*") STOP 236 + if (iachar(c) /= iachar("*")) STOP 237 + if (iachar(achar(43)) /= 43) STOP 238 + if (iachar ("+")/= 43) STOP 239 + if (achar (43) /= "+") STOP 240 + if ("+" /= achar ( ichar ( "+"))) STOP 241 + i = 43 + c = "+" + if (achar(i) /= "+") STOP 242 + if (iachar(c) /= iachar("+")) STOP 243 + if (iachar(achar(44)) /= 44) STOP 244 + if (iachar (",")/= 44) STOP 245 + if (achar (44) /= ",") STOP 246 + if ("," /= achar ( ichar ( ","))) STOP 247 + i = 44 + c = "," + if (achar(i) /= ",") STOP 248 + if (iachar(c) /= iachar(",")) STOP 249 + if (iachar(achar(45)) /= 45) STOP 250 + if (iachar ("-")/= 45) STOP 251 + if (achar (45) /= "-") STOP 252 + if ("-" /= achar ( ichar ( "-"))) STOP 253 + i = 45 + c = "-" + if (achar(i) /= "-") STOP 254 + if (iachar(c) /= iachar("-")) STOP 255 + if (iachar(achar(46)) /= 46) STOP 256 + if (iachar (".")/= 46) STOP 257 + if (achar (46) /= ".") STOP 258 + if ("." /= achar ( ichar ( "."))) STOP 259 + i = 46 + c = "." + if (achar(i) /= ".") STOP 260 + if (iachar(c) /= iachar(".")) STOP 261 + if (iachar(achar(47)) /= 47) STOP 262 + if (iachar ("/")/= 47) STOP 263 + if (achar (47) /= "/") STOP 264 + if ("/" /= achar ( ichar ( "/"))) STOP 265 + i = 47 + c = "/" + if (achar(i) /= "/") STOP 266 + if (iachar(c) /= iachar("/")) STOP 267 + if (iachar(achar(48)) /= 48) STOP 268 + if (iachar ("0")/= 48) STOP 269 + if (achar (48) /= "0") STOP 270 + if ("0" /= achar ( ichar ( "0"))) STOP 271 + i = 48 + c = "0" + if (achar(i) /= "0") STOP 272 + if (iachar(c) /= iachar("0")) STOP 273 + if (iachar(achar(49)) /= 49) STOP 274 + if (iachar ("1")/= 49) STOP 275 + if (achar (49) /= "1") STOP 276 + if ("1" /= achar ( ichar ( "1"))) STOP 277 + i = 49 + c = "1" + if (achar(i) /= "1") STOP 278 + if (iachar(c) /= iachar("1")) STOP 279 + if (iachar(achar(50)) /= 50) STOP 280 + if (iachar ("2")/= 50) STOP 281 + if (achar (50) /= "2") STOP 282 + if ("2" /= achar ( ichar ( "2"))) STOP 283 + i = 50 + c = "2" + if (achar(i) /= "2") STOP 284 + if (iachar(c) /= iachar("2")) STOP 285 + if (iachar(achar(51)) /= 51) STOP 286 + if (iachar ("3")/= 51) STOP 287 + if (achar (51) /= "3") STOP 288 + if ("3" /= achar ( ichar ( "3"))) STOP 289 + i = 51 + c = "3" + if (achar(i) /= "3") STOP 290 + if (iachar(c) /= iachar("3")) STOP 291 + if (iachar(achar(52)) /= 52) STOP 292 + if (iachar ("4")/= 52) STOP 293 + if (achar (52) /= "4") STOP 294 + if ("4" /= achar ( ichar ( "4"))) STOP 295 + i = 52 + c = "4" + if (achar(i) /= "4") STOP 296 + if (iachar(c) /= iachar("4")) STOP 297 + if (iachar(achar(53)) /= 53) STOP 298 + if (iachar ("5")/= 53) STOP 299 + if (achar (53) /= "5") STOP 300 + if ("5" /= achar ( ichar ( "5"))) STOP 301 + i = 53 + c = "5" + if (achar(i) /= "5") STOP 302 + if (iachar(c) /= iachar("5")) STOP 303 + if (iachar(achar(54)) /= 54) STOP 304 + if (iachar ("6")/= 54) STOP 305 + if (achar (54) /= "6") STOP 306 + if ("6" /= achar ( ichar ( "6"))) STOP 307 + i = 54 + c = "6" + if (achar(i) /= "6") STOP 308 + if (iachar(c) /= iachar("6")) STOP 309 + if (iachar(achar(55)) /= 55) STOP 310 + if (iachar ("7")/= 55) STOP 311 + if (achar (55) /= "7") STOP 312 + if ("7" /= achar ( ichar ( "7"))) STOP 313 + i = 55 + c = "7" + if (achar(i) /= "7") STOP 314 + if (iachar(c) /= iachar("7")) STOP 315 + if (iachar(achar(56)) /= 56) STOP 316 + if (iachar ("8")/= 56) STOP 317 + if (achar (56) /= "8") STOP 318 + if ("8" /= achar ( ichar ( "8"))) STOP 319 + i = 56 + c = "8" + if (achar(i) /= "8") STOP 320 + if (iachar(c) /= iachar("8")) STOP 321 + if (iachar(achar(57)) /= 57) STOP 322 + if (iachar ("9")/= 57) STOP 323 + if (achar (57) /= "9") STOP 324 + if ("9" /= achar ( ichar ( "9"))) STOP 325 + i = 57 + c = "9" + if (achar(i) /= "9") STOP 326 + if (iachar(c) /= iachar("9")) STOP 327 + if (iachar(achar(58)) /= 58) STOP 328 + if (iachar (":")/= 58) STOP 329 + if (achar (58) /= ":") STOP 330 + if (":" /= achar ( ichar ( ":"))) STOP 331 + i = 58 + c = ":" + if (achar(i) /= ":") STOP 332 + if (iachar(c) /= iachar(":")) STOP 333 + if (iachar(achar(59)) /= 59) STOP 334 + if (iachar (";")/= 59) STOP 335 + if (achar (59) /= ";") STOP 336 + if (";" /= achar ( ichar ( ";"))) STOP 337 + i = 59 + c = ";" + if (achar(i) /= ";") STOP 338 + if (iachar(c) /= iachar(";")) STOP 339 + if (iachar(achar(60)) /= 60) STOP 340 + if (iachar ("<")/= 60) STOP 341 + if (achar (60) /= "<") STOP 342 + if ("<" /= achar ( ichar ( "<"))) STOP 343 + i = 60 + c = "<" + if (achar(i) /= "<") STOP 344 + if (iachar(c) /= iachar("<")) STOP 345 + if (iachar(achar(61)) /= 61) STOP 346 + if (iachar ("=")/= 61) STOP 347 + if (achar (61) /= "=") STOP 348 + if ("=" /= achar ( ichar ( "="))) STOP 349 + i = 61 + c = "=" + if (achar(i) /= "=") STOP 350 + if (iachar(c) /= iachar("=")) STOP 351 + if (iachar(achar(62)) /= 62) STOP 352 + if (iachar (">")/= 62) STOP 353 + if (achar (62) /= ">") STOP 354 + if (">" /= achar ( ichar ( ">"))) STOP 355 + i = 62 + c = ">" + if (achar(i) /= ">") STOP 356 + if (iachar(c) /= iachar(">")) STOP 357 + if (iachar(achar(63)) /= 63) STOP 358 + if (iachar ("?")/= 63) STOP 359 + if (achar (63) /= "?") STOP 360 + if ("?" /= achar ( ichar ( "?"))) STOP 361 + i = 63 + c = "?" + if (achar(i) /= "?") STOP 362 + if (iachar(c) /= iachar("?")) STOP 363 + if (iachar(achar(64)) /= 64) STOP 364 + if (iachar ("@")/= 64) STOP 365 + if (achar (64) /= "@") STOP 366 + if ("@" /= achar ( ichar ( "@"))) STOP 367 + i = 64 + c = "@" + if (achar(i) /= "@") STOP 368 + if (iachar(c) /= iachar("@")) STOP 369 + if (iachar(achar(65)) /= 65) STOP 370 + if (iachar ("A")/= 65) STOP 371 + if (achar (65) /= "A") STOP 372 + if ("A" /= achar ( ichar ( "A"))) STOP 373 + i = 65 + c = "A" + if (achar(i) /= "A") STOP 374 + if (iachar(c) /= iachar("A")) STOP 375 + if (iachar(achar(66)) /= 66) STOP 376 + if (iachar ("B")/= 66) STOP 377 + if (achar (66) /= "B") STOP 378 + if ("B" /= achar ( ichar ( "B"))) STOP 379 + i = 66 + c = "B" + if (achar(i) /= "B") STOP 380 + if (iachar(c) /= iachar("B")) STOP 381 + if (iachar(achar(67)) /= 67) STOP 382 + if (iachar ("C")/= 67) STOP 383 + if (achar (67) /= "C") STOP 384 + if ("C" /= achar ( ichar ( "C"))) STOP 385 + i = 67 + c = "C" + if (achar(i) /= "C") STOP 386 + if (iachar(c) /= iachar("C")) STOP 387 + if (iachar(achar(68)) /= 68) STOP 388 + if (iachar ("D")/= 68) STOP 389 + if (achar (68) /= "D") STOP 390 + if ("D" /= achar ( ichar ( "D"))) STOP 391 + i = 68 + c = "D" + if (achar(i) /= "D") STOP 392 + if (iachar(c) /= iachar("D")) STOP 393 + if (iachar(achar(69)) /= 69) STOP 394 + if (iachar ("E")/= 69) STOP 395 + if (achar (69) /= "E") STOP 396 + if ("E" /= achar ( ichar ( "E"))) STOP 397 + i = 69 + c = "E" + if (achar(i) /= "E") STOP 398 + if (iachar(c) /= iachar("E")) STOP 399 + if (iachar(achar(70)) /= 70) STOP 400 + if (iachar ("F")/= 70) STOP 401 + if (achar (70) /= "F") STOP 402 + if ("F" /= achar ( ichar ( "F"))) STOP 403 + i = 70 + c = "F" + if (achar(i) /= "F") STOP 404 + if (iachar(c) /= iachar("F")) STOP 405 + if (iachar(achar(71)) /= 71) STOP 406 + if (iachar ("G")/= 71) STOP 407 + if (achar (71) /= "G") STOP 408 + if ("G" /= achar ( ichar ( "G"))) STOP 409 + i = 71 + c = "G" + if (achar(i) /= "G") STOP 410 + if (iachar(c) /= iachar("G")) STOP 411 + if (iachar(achar(72)) /= 72) STOP 412 + if (iachar ("H")/= 72) STOP 413 + if (achar (72) /= "H") STOP 414 + if ("H" /= achar ( ichar ( "H"))) STOP 415 + i = 72 + c = "H" + if (achar(i) /= "H") STOP 416 + if (iachar(c) /= iachar("H")) STOP 417 + if (iachar(achar(73)) /= 73) STOP 418 + if (iachar ("I")/= 73) STOP 419 + if (achar (73) /= "I") STOP 420 + if ("I" /= achar ( ichar ( "I"))) STOP 421 + i = 73 + c = "I" + if (achar(i) /= "I") STOP 422 + if (iachar(c) /= iachar("I")) STOP 423 + if (iachar(achar(74)) /= 74) STOP 424 + if (iachar ("J")/= 74) STOP 425 + if (achar (74) /= "J") STOP 426 + if ("J" /= achar ( ichar ( "J"))) STOP 427 + i = 74 + c = "J" + if (achar(i) /= "J") STOP 428 + if (iachar(c) /= iachar("J")) STOP 429 + if (iachar(achar(75)) /= 75) STOP 430 + if (iachar ("K")/= 75) STOP 431 + if (achar (75) /= "K") STOP 432 + if ("K" /= achar ( ichar ( "K"))) STOP 433 + i = 75 + c = "K" + if (achar(i) /= "K") STOP 434 + if (iachar(c) /= iachar("K")) STOP 435 + if (iachar(achar(76)) /= 76) STOP 436 + if (iachar ("L")/= 76) STOP 437 + if (achar (76) /= "L") STOP 438 + if ("L" /= achar ( ichar ( "L"))) STOP 439 + i = 76 + c = "L" + if (achar(i) /= "L") STOP 440 + if (iachar(c) /= iachar("L")) STOP 441 + if (iachar(achar(77)) /= 77) STOP 442 + if (iachar ("M")/= 77) STOP 443 + if (achar (77) /= "M") STOP 444 + if ("M" /= achar ( ichar ( "M"))) STOP 445 + i = 77 + c = "M" + if (achar(i) /= "M") STOP 446 + if (iachar(c) /= iachar("M")) STOP 447 + if (iachar(achar(78)) /= 78) STOP 448 + if (iachar ("N")/= 78) STOP 449 + if (achar (78) /= "N") STOP 450 + if ("N" /= achar ( ichar ( "N"))) STOP 451 + i = 78 + c = "N" + if (achar(i) /= "N") STOP 452 + if (iachar(c) /= iachar("N")) STOP 453 + if (iachar(achar(79)) /= 79) STOP 454 + if (iachar ("O")/= 79) STOP 455 + if (achar (79) /= "O") STOP 456 + if ("O" /= achar ( ichar ( "O"))) STOP 457 + i = 79 + c = "O" + if (achar(i) /= "O") STOP 458 + if (iachar(c) /= iachar("O")) STOP 459 + if (iachar(achar(80)) /= 80) STOP 460 + if (iachar ("P")/= 80) STOP 461 + if (achar (80) /= "P") STOP 462 + if ("P" /= achar ( ichar ( "P"))) STOP 463 + i = 80 + c = "P" + if (achar(i) /= "P") STOP 464 + if (iachar(c) /= iachar("P")) STOP 465 + if (iachar(achar(81)) /= 81) STOP 466 + if (iachar ("Q")/= 81) STOP 467 + if (achar (81) /= "Q") STOP 468 + if ("Q" /= achar ( ichar ( "Q"))) STOP 469 + i = 81 + c = "Q" + if (achar(i) /= "Q") STOP 470 + if (iachar(c) /= iachar("Q")) STOP 471 + if (iachar(achar(82)) /= 82) STOP 472 + if (iachar ("R")/= 82) STOP 473 + if (achar (82) /= "R") STOP 474 + if ("R" /= achar ( ichar ( "R"))) STOP 475 + i = 82 + c = "R" + if (achar(i) /= "R") STOP 476 + if (iachar(c) /= iachar("R")) STOP 477 + if (iachar(achar(83)) /= 83) STOP 478 + if (iachar ("S")/= 83) STOP 479 + if (achar (83) /= "S") STOP 480 + if ("S" /= achar ( ichar ( "S"))) STOP 481 + i = 83 + c = "S" + if (achar(i) /= "S") STOP 482 + if (iachar(c) /= iachar("S")) STOP 483 + if (iachar(achar(84)) /= 84) STOP 484 + if (iachar ("T")/= 84) STOP 485 + if (achar (84) /= "T") STOP 486 + if ("T" /= achar ( ichar ( "T"))) STOP 487 + i = 84 + c = "T" + if (achar(i) /= "T") STOP 488 + if (iachar(c) /= iachar("T")) STOP 489 + if (iachar(achar(85)) /= 85) STOP 490 + if (iachar ("U")/= 85) STOP 491 + if (achar (85) /= "U") STOP 492 + if ("U" /= achar ( ichar ( "U"))) STOP 493 + i = 85 + c = "U" + if (achar(i) /= "U") STOP 494 + if (iachar(c) /= iachar("U")) STOP 495 + if (iachar(achar(86)) /= 86) STOP 496 + if (iachar ("V")/= 86) STOP 497 + if (achar (86) /= "V") STOP 498 + if ("V" /= achar ( ichar ( "V"))) STOP 499 + i = 86 + c = "V" + if (achar(i) /= "V") STOP 500 + if (iachar(c) /= iachar("V")) STOP 501 + if (iachar(achar(87)) /= 87) STOP 502 + if (iachar ("W")/= 87) STOP 503 + if (achar (87) /= "W") STOP 504 + if ("W" /= achar ( ichar ( "W"))) STOP 505 + i = 87 + c = "W" + if (achar(i) /= "W") STOP 506 + if (iachar(c) /= iachar("W")) STOP 507 + if (iachar(achar(88)) /= 88) STOP 508 + if (iachar ("X")/= 88) STOP 509 + if (achar (88) /= "X") STOP 510 + if ("X" /= achar ( ichar ( "X"))) STOP 511 + i = 88 + c = "X" + if (achar(i) /= "X") STOP 512 + if (iachar(c) /= iachar("X")) STOP 513 + if (iachar(achar(89)) /= 89) STOP 514 + if (iachar ("Y")/= 89) STOP 515 + if (achar (89) /= "Y") STOP 516 + if ("Y" /= achar ( ichar ( "Y"))) STOP 517 + i = 89 + c = "Y" + if (achar(i) /= "Y") STOP 518 + if (iachar(c) /= iachar("Y")) STOP 519 + if (iachar(achar(90)) /= 90) STOP 520 + if (iachar ("Z")/= 90) STOP 521 + if (achar (90) /= "Z") STOP 522 + if ("Z" /= achar ( ichar ( "Z"))) STOP 523 + i = 90 + c = "Z" + if (achar(i) /= "Z") STOP 524 + if (iachar(c) /= iachar("Z")) STOP 525 + if (iachar(achar(91)) /= 91) STOP 526 + if (iachar ("[")/= 91) STOP 527 + if (achar (91) /= "[") STOP 528 + if ("[" /= achar ( ichar ( "["))) STOP 529 + i = 91 + c = "[" + if (achar(i) /= "[") STOP 530 + if (iachar(c) /= iachar("[")) STOP 531 + if (iachar(achar(92)) /= 92) STOP 532 + if (iachar ("\")/= 92) STOP 533 + if (achar (92) /= "\") STOP 534 + if ("\" /= achar ( ichar ( "\"))) STOP 535 + i = 92 + c = "\" + if (achar(i) /= "\") STOP 536 + if (iachar(c) /= iachar("\")) STOP 537 + if (iachar(achar(93)) /= 93) STOP 538 + if (iachar ("]")/= 93) STOP 539 + if (achar (93) /= "]") STOP 540 + if ("]" /= achar ( ichar ( "]"))) STOP 541 + i = 93 + c = "]" + if (achar(i) /= "]") STOP 542 + if (iachar(c) /= iachar("]")) STOP 543 + if (iachar(achar(94)) /= 94) STOP 544 + if (iachar ("^")/= 94) STOP 545 + if (achar (94) /= "^") STOP 546 + if ("^" /= achar ( ichar ( "^"))) STOP 547 + i = 94 + c = "^" + if (achar(i) /= "^") STOP 548 + if (iachar(c) /= iachar("^")) STOP 549 + if (iachar(achar(95)) /= 95) STOP 550 + if (iachar ("_")/= 95) STOP 551 + if (achar (95) /= "_") STOP 552 + if ("_" /= achar ( ichar ( "_"))) STOP 553 + i = 95 + c = "_" + if (achar(i) /= "_") STOP 554 + if (iachar(c) /= iachar("_")) STOP 555 + if (iachar(achar(96)) /= 96) STOP 556 + if (iachar ("`")/= 96) STOP 557 + if (achar (96) /= "`") STOP 558 + if ("`" /= achar ( ichar ( "`"))) STOP 559 + i = 96 + c = "`" + if (achar(i) /= "`") STOP 560 + if (iachar(c) /= iachar("`")) STOP 561 + if (iachar(achar(97)) /= 97) STOP 562 + if (iachar ("a")/= 97) STOP 563 + if (achar (97) /= "a") STOP 564 + if ("a" /= achar ( ichar ( "a"))) STOP 565 + i = 97 + c = "a" + if (achar(i) /= "a") STOP 566 + if (iachar(c) /= iachar("a")) STOP 567 + if (iachar(achar(98)) /= 98) STOP 568 + if (iachar ("b")/= 98) STOP 569 + if (achar (98) /= "b") STOP 570 + if ("b" /= achar ( ichar ( "b"))) STOP 571 + i = 98 + c = "b" + if (achar(i) /= "b") STOP 572 + if (iachar(c) /= iachar("b")) STOP 573 + if (iachar(achar(99)) /= 99) STOP 574 + if (iachar ("c")/= 99) STOP 575 + if (achar (99) /= "c") STOP 576 + if ("c" /= achar ( ichar ( "c"))) STOP 577 + i = 99 + c = "c" + if (achar(i) /= "c") STOP 578 + if (iachar(c) /= iachar("c")) STOP 579 + if (iachar(achar(100)) /= 100) STOP 580 + if (iachar ("d")/= 100) STOP 581 + if (achar (100) /= "d") STOP 582 + if ("d" /= achar ( ichar ( "d"))) STOP 583 + i = 100 + c = "d" + if (achar(i) /= "d") STOP 584 + if (iachar(c) /= iachar("d")) STOP 585 + if (iachar(achar(101)) /= 101) STOP 586 + if (iachar ("e")/= 101) STOP 587 + if (achar (101) /= "e") STOP 588 + if ("e" /= achar ( ichar ( "e"))) STOP 589 + i = 101 + c = "e" + if (achar(i) /= "e") STOP 590 + if (iachar(c) /= iachar("e")) STOP 591 + if (iachar(achar(102)) /= 102) STOP 592 + if (iachar ("f")/= 102) STOP 593 + if (achar (102) /= "f") STOP 594 + if ("f" /= achar ( ichar ( "f"))) STOP 595 + i = 102 + c = "f" + if (achar(i) /= "f") STOP 596 + if (iachar(c) /= iachar("f")) STOP 597 + if (iachar(achar(103)) /= 103) STOP 598 + if (iachar ("g")/= 103) STOP 599 + if (achar (103) /= "g") STOP 600 + if ("g" /= achar ( ichar ( "g"))) STOP 601 + i = 103 + c = "g" + if (achar(i) /= "g") STOP 602 + if (iachar(c) /= iachar("g")) STOP 603 + if (iachar(achar(104)) /= 104) STOP 604 + if (iachar ("h")/= 104) STOP 605 + if (achar (104) /= "h") STOP 606 + if ("h" /= achar ( ichar ( "h"))) STOP 607 + i = 104 + c = "h" + if (achar(i) /= "h") STOP 608 + if (iachar(c) /= iachar("h")) STOP 609 + if (iachar(achar(105)) /= 105) STOP 610 + if (iachar ("i")/= 105) STOP 611 + if (achar (105) /= "i") STOP 612 + if ("i" /= achar ( ichar ( "i"))) STOP 613 + i = 105 + c = "i" + if (achar(i) /= "i") STOP 614 + if (iachar(c) /= iachar("i")) STOP 615 + if (iachar(achar(106)) /= 106) STOP 616 + if (iachar ("j")/= 106) STOP 617 + if (achar (106) /= "j") STOP 618 + if ("j" /= achar ( ichar ( "j"))) STOP 619 + i = 106 + c = "j" + if (achar(i) /= "j") STOP 620 + if (iachar(c) /= iachar("j")) STOP 621 + if (iachar(achar(107)) /= 107) STOP 622 + if (iachar ("k")/= 107) STOP 623 + if (achar (107) /= "k") STOP 624 + if ("k" /= achar ( ichar ( "k"))) STOP 625 + i = 107 + c = "k" + if (achar(i) /= "k") STOP 626 + if (iachar(c) /= iachar("k")) STOP 627 + if (iachar(achar(108)) /= 108) STOP 628 + if (iachar ("l")/= 108) STOP 629 + if (achar (108) /= "l") STOP 630 + if ("l" /= achar ( ichar ( "l"))) STOP 631 + i = 108 + c = "l" + if (achar(i) /= "l") STOP 632 + if (iachar(c) /= iachar("l")) STOP 633 + if (iachar(achar(109)) /= 109) STOP 634 + if (iachar ("m")/= 109) STOP 635 + if (achar (109) /= "m") STOP 636 + if ("m" /= achar ( ichar ( "m"))) STOP 637 + i = 109 + c = "m" + if (achar(i) /= "m") STOP 638 + if (iachar(c) /= iachar("m")) STOP 639 + if (iachar(achar(110)) /= 110) STOP 640 + if (iachar ("n")/= 110) STOP 641 + if (achar (110) /= "n") STOP 642 + if ("n" /= achar ( ichar ( "n"))) STOP 643 + i = 110 + c = "n" + if (achar(i) /= "n") STOP 644 + if (iachar(c) /= iachar("n")) STOP 645 + if (iachar(achar(111)) /= 111) STOP 646 + if (iachar ("o")/= 111) STOP 647 + if (achar (111) /= "o") STOP 648 + if ("o" /= achar ( ichar ( "o"))) STOP 649 + i = 111 + c = "o" + if (achar(i) /= "o") STOP 650 + if (iachar(c) /= iachar("o")) STOP 651 + if (iachar(achar(112)) /= 112) STOP 652 + if (iachar ("p")/= 112) STOP 653 + if (achar (112) /= "p") STOP 654 + if ("p" /= achar ( ichar ( "p"))) STOP 655 + i = 112 + c = "p" + if (achar(i) /= "p") STOP 656 + if (iachar(c) /= iachar("p")) STOP 657 + if (iachar(achar(113)) /= 113) STOP 658 + if (iachar ("q")/= 113) STOP 659 + if (achar (113) /= "q") STOP 660 + if ("q" /= achar ( ichar ( "q"))) STOP 661 + i = 113 + c = "q" + if (achar(i) /= "q") STOP 662 + if (iachar(c) /= iachar("q")) STOP 663 + if (iachar(achar(114)) /= 114) STOP 664 + if (iachar ("r")/= 114) STOP 665 + if (achar (114) /= "r") STOP 666 + if ("r" /= achar ( ichar ( "r"))) STOP 667 + i = 114 + c = "r" + if (achar(i) /= "r") STOP 668 + if (iachar(c) /= iachar("r")) STOP 669 + if (iachar(achar(115)) /= 115) STOP 670 + if (iachar ("s")/= 115) STOP 671 + if (achar (115) /= "s") STOP 672 + if ("s" /= achar ( ichar ( "s"))) STOP 673 + i = 115 + c = "s" + if (achar(i) /= "s") STOP 674 + if (iachar(c) /= iachar("s")) STOP 675 + if (iachar(achar(116)) /= 116) STOP 676 + if (iachar ("t")/= 116) STOP 677 + if (achar (116) /= "t") STOP 678 + if ("t" /= achar ( ichar ( "t"))) STOP 679 + i = 116 + c = "t" + if (achar(i) /= "t") STOP 680 + if (iachar(c) /= iachar("t")) STOP 681 + if (iachar(achar(117)) /= 117) STOP 682 + if (iachar ("u")/= 117) STOP 683 + if (achar (117) /= "u") STOP 684 + if ("u" /= achar ( ichar ( "u"))) STOP 685 + i = 117 + c = "u" + if (achar(i) /= "u") STOP 686 + if (iachar(c) /= iachar("u")) STOP 687 + if (iachar(achar(118)) /= 118) STOP 688 + if (iachar ("v")/= 118) STOP 689 + if (achar (118) /= "v") STOP 690 + if ("v" /= achar ( ichar ( "v"))) STOP 691 + i = 118 + c = "v" + if (achar(i) /= "v") STOP 692 + if (iachar(c) /= iachar("v")) STOP 693 + if (iachar(achar(119)) /= 119) STOP 694 + if (iachar ("w")/= 119) STOP 695 + if (achar (119) /= "w") STOP 696 + if ("w" /= achar ( ichar ( "w"))) STOP 697 + i = 119 + c = "w" + if (achar(i) /= "w") STOP 698 + if (iachar(c) /= iachar("w")) STOP 699 + if (iachar(achar(120)) /= 120) STOP 700 + if (iachar ("x")/= 120) STOP 701 + if (achar (120) /= "x") STOP 702 + if ("x" /= achar ( ichar ( "x"))) STOP 703 + i = 120 + c = "x" + if (achar(i) /= "x") STOP 704 + if (iachar(c) /= iachar("x")) STOP 705 + if (iachar(achar(121)) /= 121) STOP 706 + if (iachar ("y")/= 121) STOP 707 + if (achar (121) /= "y") STOP 708 + if ("y" /= achar ( ichar ( "y"))) STOP 709 + i = 121 + c = "y" + if (achar(i) /= "y") STOP 710 + if (iachar(c) /= iachar("y")) STOP 711 + if (iachar(achar(122)) /= 122) STOP 712 + if (iachar ("z")/= 122) STOP 713 + if (achar (122) /= "z") STOP 714 + if ("z" /= achar ( ichar ( "z"))) STOP 715 + i = 122 + c = "z" + if (achar(i) /= "z") STOP 716 + if (iachar(c) /= iachar("z")) STOP 717 + if (iachar(achar(123)) /= 123) STOP 718 + if (iachar ("{")/= 123) STOP 719 + if (achar (123) /= "{") STOP 720 + if ("{" /= achar ( ichar ( "{"))) STOP 721 + i = 123 + c = "{" + if (achar(i) /= "{") STOP 722 + if (iachar(c) /= iachar("{")) STOP 723 + if (iachar(achar(124)) /= 124) STOP 724 + if (iachar ("|")/= 124) STOP 725 + if (achar (124) /= "|") STOP 726 + if ("|" /= achar ( ichar ( "|"))) STOP 727 + i = 124 + c = "|" + if (achar(i) /= "|") STOP 728 + if (iachar(c) /= iachar("|")) STOP 729 + if (iachar(achar(125)) /= 125) STOP 730 + if (iachar ("}")/= 125) STOP 731 + if (achar (125) /= "}") STOP 732 + if ("}" /= achar ( ichar ( "}"))) STOP 733 + i = 125 + c = "}" + if (achar(i) /= "}") STOP 734 + if (iachar(c) /= iachar("}")) STOP 735 + if (iachar(achar(126)) /= 126) STOP 736 + if (iachar ("~")/= 126) STOP 737 + if (achar (126) /= "~") STOP 738 + if ("~" /= achar ( ichar ( "~"))) STOP 739 + i = 126 + c = "~" + if (achar(i) /= "~") STOP 740 + if (iachar(c) /= iachar("~")) STOP 741 + if (iachar(achar(127)) /= 127) STOP 742 + if (iachar ("")/= 127) STOP 743 + if (achar (127) /= "") STOP 744 + if ("" /= achar ( ichar ( ""))) STOP 745 + i = 127 + c = "" + if (achar(i) /= "") STOP 746 + if (iachar(c) /= iachar("")) STOP 747 + if (iachar(achar(128)) /= 128) STOP 748 + if (iachar ("�")/= 128) STOP 749 + if (achar (128) /= "�") STOP 750 + if ("�" /= achar ( ichar ( "�"))) STOP 751 + i = 128 + c = "�" + if (achar(i) /= "�") STOP 752 + if (iachar(c) /= iachar("�")) STOP 753 + if (iachar(achar(129)) /= 129) STOP 754 + if (iachar ("�")/= 129) STOP 755 + if (achar (129) /= "�") STOP 756 + if ("�" /= achar ( ichar ( "�"))) STOP 757 + i = 129 + c = "�" + if (achar(i) /= "�") STOP 758 + if (iachar(c) /= iachar("�")) STOP 759 + if (iachar(achar(130)) /= 130) STOP 760 + if (iachar ("�")/= 130) STOP 761 + if (achar (130) /= "�") STOP 762 + if ("�" /= achar ( ichar ( "�"))) STOP 763 + i = 130 + c = "�" + if (achar(i) /= "�") STOP 764 + if (iachar(c) /= iachar("�")) STOP 765 + if (iachar(achar(131)) /= 131) STOP 766 + if (iachar ("�")/= 131) STOP 767 + if (achar (131) /= "�") STOP 768 + if ("�" /= achar ( ichar ( "�"))) STOP 769 + i = 131 + c = "�" + if (achar(i) /= "�") STOP 770 + if (iachar(c) /= iachar("�")) STOP 771 + if (iachar(achar(132)) /= 132) STOP 772 + if (iachar ("�")/= 132) STOP 773 + if (achar (132) /= "�") STOP 774 + if ("�" /= achar ( ichar ( "�"))) STOP 775 + i = 132 + c = "�" + if (achar(i) /= "�") STOP 776 + if (iachar(c) /= iachar("�")) STOP 777 + if (iachar(achar(133)) /= 133) STOP 778 + if (iachar ("�")/= 133) STOP 779 + if (achar (133) /= "�") STOP 780 + if ("�" /= achar ( ichar ( "�"))) STOP 781 + i = 133 + c = "�" + if (achar(i) /= "�") STOP 782 + if (iachar(c) /= iachar("�")) STOP 783 + if (iachar(achar(134)) /= 134) STOP 784 + if (iachar ("�")/= 134) STOP 785 + if (achar (134) /= "�") STOP 786 + if ("�" /= achar ( ichar ( "�"))) STOP 787 + i = 134 + c = "�" + if (achar(i) /= "�") STOP 788 + if (iachar(c) /= iachar("�")) STOP 789 + if (iachar(achar(135)) /= 135) STOP 790 + if (iachar ("�")/= 135) STOP 791 + if (achar (135) /= "�") STOP 792 + if ("�" /= achar ( ichar ( "�"))) STOP 793 + i = 135 + c = "�" + if (achar(i) /= "�") STOP 794 + if (iachar(c) /= iachar("�")) STOP 795 + if (iachar(achar(136)) /= 136) STOP 796 + if (iachar ("�")/= 136) STOP 797 + if (achar (136) /= "�") STOP 798 + if ("�" /= achar ( ichar ( "�"))) STOP 799 + i = 136 + c = "�" + if (achar(i) /= "�") STOP 800 + if (iachar(c) /= iachar("�")) STOP 801 + if (iachar(achar(137)) /= 137) STOP 802 + if (iachar ("�")/= 137) STOP 803 + if (achar (137) /= "�") STOP 804 + if ("�" /= achar ( ichar ( "�"))) STOP 805 + i = 137 + c = "�" + if (achar(i) /= "�") STOP 806 + if (iachar(c) /= iachar("�")) STOP 807 + if (iachar(achar(138)) /= 138) STOP 808 + if (iachar ("�")/= 138) STOP 809 + if (achar (138) /= "�") STOP 810 + if ("�" /= achar ( ichar ( "�"))) STOP 811 + i = 138 + c = "�" + if (achar(i) /= "�") STOP 812 + if (iachar(c) /= iachar("�")) STOP 813 + if (iachar(achar(139)) /= 139) STOP 814 + if (iachar ("�")/= 139) STOP 815 + if (achar (139) /= "�") STOP 816 + if ("�" /= achar ( ichar ( "�"))) STOP 817 + i = 139 + c = "�" + if (achar(i) /= "�") STOP 818 + if (iachar(c) /= iachar("�")) STOP 819 + if (iachar(achar(140)) /= 140) STOP 820 + if (iachar ("�")/= 140) STOP 821 + if (achar (140) /= "�") STOP 822 + if ("�" /= achar ( ichar ( "�"))) STOP 823 + i = 140 + c = "�" + if (achar(i) /= "�") STOP 824 + if (iachar(c) /= iachar("�")) STOP 825 + if (iachar(achar(141)) /= 141) STOP 826 + if (iachar ("�")/= 141) STOP 827 + if (achar (141) /= "�") STOP 828 + if ("�" /= achar ( ichar ( "�"))) STOP 829 + i = 141 + c = "�" + if (achar(i) /= "�") STOP 830 + if (iachar(c) /= iachar("�")) STOP 831 + if (iachar(achar(142)) /= 142) STOP 832 + if (iachar ("�")/= 142) STOP 833 + if (achar (142) /= "�") STOP 834 + if ("�" /= achar ( ichar ( "�"))) STOP 835 + i = 142 + c = "�" + if (achar(i) /= "�") STOP 836 + if (iachar(c) /= iachar("�")) STOP 837 + if (iachar(achar(143)) /= 143) STOP 838 + if (iachar ("�")/= 143) STOP 839 + if (achar (143) /= "�") STOP 840 + if ("�" /= achar ( ichar ( "�"))) STOP 841 + i = 143 + c = "�" + if (achar(i) /= "�") STOP 842 + if (iachar(c) /= iachar("�")) STOP 843 + if (iachar(achar(144)) /= 144) STOP 844 + if (iachar ("�")/= 144) STOP 845 + if (achar (144) /= "�") STOP 846 + if ("�" /= achar ( ichar ( "�"))) STOP 847 + i = 144 + c = "�" + if (achar(i) /= "�") STOP 848 + if (iachar(c) /= iachar("�")) STOP 849 + if (iachar(achar(145)) /= 145) STOP 850 + if (iachar ("�")/= 145) STOP 851 + if (achar (145) /= "�") STOP 852 + if ("�" /= achar ( ichar ( "�"))) STOP 853 + i = 145 + c = "�" + if (achar(i) /= "�") STOP 854 + if (iachar(c) /= iachar("�")) STOP 855 + if (iachar(achar(146)) /= 146) STOP 856 + if (iachar ("�")/= 146) STOP 857 + if (achar (146) /= "�") STOP 858 + if ("�" /= achar ( ichar ( "�"))) STOP 859 + i = 146 + c = "�" + if (achar(i) /= "�") STOP 860 + if (iachar(c) /= iachar("�")) STOP 861 + if (iachar(achar(147)) /= 147) STOP 862 + if (iachar ("�")/= 147) STOP 863 + if (achar (147) /= "�") STOP 864 + if ("�" /= achar ( ichar ( "�"))) STOP 865 + i = 147 + c = "�" + if (achar(i) /= "�") STOP 866 + if (iachar(c) /= iachar("�")) STOP 867 + if (iachar(achar(148)) /= 148) STOP 868 + if (iachar ("�")/= 148) STOP 869 + if (achar (148) /= "�") STOP 870 + if ("�" /= achar ( ichar ( "�"))) STOP 871 + i = 148 + c = "�" + if (achar(i) /= "�") STOP 872 + if (iachar(c) /= iachar("�")) STOP 873 + if (iachar(achar(149)) /= 149) STOP 874 + if (iachar ("�")/= 149) STOP 875 + if (achar (149) /= "�") STOP 876 + if ("�" /= achar ( ichar ( "�"))) STOP 877 + i = 149 + c = "�" + if (achar(i) /= "�") STOP 878 + if (iachar(c) /= iachar("�")) STOP 879 + if (iachar(achar(150)) /= 150) STOP 880 + if (iachar ("�")/= 150) STOP 881 + if (achar (150) /= "�") STOP 882 + if ("�" /= achar ( ichar ( "�"))) STOP 883 + i = 150 + c = "�" + if (achar(i) /= "�") STOP 884 + if (iachar(c) /= iachar("�")) STOP 885 + if (iachar(achar(151)) /= 151) STOP 886 + if (iachar ("�")/= 151) STOP 887 + if (achar (151) /= "�") STOP 888 + if ("�" /= achar ( ichar ( "�"))) STOP 889 + i = 151 + c = "�" + if (achar(i) /= "�") STOP 890 + if (iachar(c) /= iachar("�")) STOP 891 + if (iachar(achar(152)) /= 152) STOP 892 + if (iachar ("�")/= 152) STOP 893 + if (achar (152) /= "�") STOP 894 + if ("�" /= achar ( ichar ( "�"))) STOP 895 + i = 152 + c = "�" + if (achar(i) /= "�") STOP 896 + if (iachar(c) /= iachar("�")) STOP 897 + if (iachar(achar(153)) /= 153) STOP 898 + if (iachar ("�")/= 153) STOP 899 + if (achar (153) /= "�") STOP 900 + if ("�" /= achar ( ichar ( "�"))) STOP 901 + i = 153 + c = "�" + if (achar(i) /= "�") STOP 902 + if (iachar(c) /= iachar("�")) STOP 903 + if (iachar(achar(154)) /= 154) STOP 904 + if (iachar ("�")/= 154) STOP 905 + if (achar (154) /= "�") STOP 906 + if ("�" /= achar ( ichar ( "�"))) STOP 907 + i = 154 + c = "�" + if (achar(i) /= "�") STOP 908 + if (iachar(c) /= iachar("�")) STOP 909 + if (iachar(achar(155)) /= 155) STOP 910 + if (iachar ("�")/= 155) STOP 911 + if (achar (155) /= "�") STOP 912 + if ("�" /= achar ( ichar ( "�"))) STOP 913 + i = 155 + c = "�" + if (achar(i) /= "�") STOP 914 + if (iachar(c) /= iachar("�")) STOP 915 + if (iachar(achar(156)) /= 156) STOP 916 + if (iachar ("�")/= 156) STOP 917 + if (achar (156) /= "�") STOP 918 + if ("�" /= achar ( ichar ( "�"))) STOP 919 + i = 156 + c = "�" + if (achar(i) /= "�") STOP 920 + if (iachar(c) /= iachar("�")) STOP 921 + if (iachar(achar(157)) /= 157) STOP 922 + if (iachar ("�")/= 157) STOP 923 + if (achar (157) /= "�") STOP 924 + if ("�" /= achar ( ichar ( "�"))) STOP 925 + i = 157 + c = "�" + if (achar(i) /= "�") STOP 926 + if (iachar(c) /= iachar("�")) STOP 927 + if (iachar(achar(158)) /= 158) STOP 928 + if (iachar ("�")/= 158) STOP 929 + if (achar (158) /= "�") STOP 930 + if ("�" /= achar ( ichar ( "�"))) STOP 931 + i = 158 + c = "�" + if (achar(i) /= "�") STOP 932 + if (iachar(c) /= iachar("�")) STOP 933 + if (iachar(achar(159)) /= 159) STOP 934 + if (iachar ("�")/= 159) STOP 935 + if (achar (159) /= "�") STOP 936 + if ("�" /= achar ( ichar ( "�"))) STOP 937 + i = 159 + c = "�" + if (achar(i) /= "�") STOP 938 + if (iachar(c) /= iachar("�")) STOP 939 + if (iachar(achar(160)) /= 160) STOP 940 + if (iachar ("�")/= 160) STOP 941 + if (achar (160) /= "�") STOP 942 + if ("�" /= achar ( ichar ( "�"))) STOP 943 + i = 160 + c = "�" + if (achar(i) /= "�") STOP 944 + if (iachar(c) /= iachar("�")) STOP 945 + if (iachar(achar(161)) /= 161) STOP 946 + if (iachar ("�")/= 161) STOP 947 + if (achar (161) /= "�") STOP 948 + if ("�" /= achar ( ichar ( "�"))) STOP 949 + i = 161 + c = "�" + if (achar(i) /= "�") STOP 950 + if (iachar(c) /= iachar("�")) STOP 951 + if (iachar(achar(162)) /= 162) STOP 952 + if (iachar ("�")/= 162) STOP 953 + if (achar (162) /= "�") STOP 954 + if ("�" /= achar ( ichar ( "�"))) STOP 955 + i = 162 + c = "�" + if (achar(i) /= "�") STOP 956 + if (iachar(c) /= iachar("�")) STOP 957 + if (iachar(achar(163)) /= 163) STOP 958 + if (iachar ("�")/= 163) STOP 959 + if (achar (163) /= "�") STOP 960 + if ("�" /= achar ( ichar ( "�"))) STOP 961 + i = 163 + c = "�" + if (achar(i) /= "�") STOP 962 + if (iachar(c) /= iachar("�")) STOP 963 + if (iachar(achar(164)) /= 164) STOP 964 + if (iachar ("�")/= 164) STOP 965 + if (achar (164) /= "�") STOP 966 + if ("�" /= achar ( ichar ( "�"))) STOP 967 + i = 164 + c = "�" + if (achar(i) /= "�") STOP 968 + if (iachar(c) /= iachar("�")) STOP 969 + if (iachar(achar(165)) /= 165) STOP 970 + if (iachar ("�")/= 165) STOP 971 + if (achar (165) /= "�") STOP 972 + if ("�" /= achar ( ichar ( "�"))) STOP 973 + i = 165 + c = "�" + if (achar(i) /= "�") STOP 974 + if (iachar(c) /= iachar("�")) STOP 975 + if (iachar(achar(166)) /= 166) STOP 976 + if (iachar ("�")/= 166) STOP 977 + if (achar (166) /= "�") STOP 978 + if ("�" /= achar ( ichar ( "�"))) STOP 979 + i = 166 + c = "�" + if (achar(i) /= "�") STOP 980 + if (iachar(c) /= iachar("�")) STOP 981 + if (iachar(achar(167)) /= 167) STOP 982 + if (iachar ("�")/= 167) STOP 983 + if (achar (167) /= "�") STOP 984 + if ("�" /= achar ( ichar ( "�"))) STOP 985 + i = 167 + c = "�" + if (achar(i) /= "�") STOP 986 + if (iachar(c) /= iachar("�")) STOP 987 + if (iachar(achar(168)) /= 168) STOP 988 + if (iachar ("�")/= 168) STOP 989 + if (achar (168) /= "�") STOP 990 + if ("�" /= achar ( ichar ( "�"))) STOP 991 + i = 168 + c = "�" + if (achar(i) /= "�") STOP 992 + if (iachar(c) /= iachar("�")) STOP 993 + if (iachar(achar(169)) /= 169) STOP 994 + if (iachar ("�")/= 169) STOP 995 + if (achar (169) /= "�") STOP 996 + if ("�" /= achar ( ichar ( "�"))) STOP 997 + i = 169 + c = "�" + if (achar(i) /= "�") STOP 998 + if (iachar(c) /= iachar("�")) STOP 999 + if (iachar(achar(170)) /= 170) STOP 1000 + if (iachar ("�")/= 170) STOP 1001 + if (achar (170) /= "�") STOP 1002 + if ("�" /= achar ( ichar ( "�"))) STOP 1003 + i = 170 + c = "�" + if (achar(i) /= "�") STOP 1004 + if (iachar(c) /= iachar("�")) STOP 1005 + if (iachar(achar(171)) /= 171) STOP 1006 + if (iachar ("�")/= 171) STOP 1007 + if (achar (171) /= "�") STOP 1008 + if ("�" /= achar ( ichar ( "�"))) STOP 1009 + i = 171 + c = "�" + if (achar(i) /= "�") STOP 1010 + if (iachar(c) /= iachar("�")) STOP 1011 + if (iachar(achar(172)) /= 172) STOP 1012 + if (iachar ("�")/= 172) STOP 1013 + if (achar (172) /= "�") STOP 1014 + if ("�" /= achar ( ichar ( "�"))) STOP 1015 + i = 172 + c = "�" + if (achar(i) /= "�") STOP 1016 + if (iachar(c) /= iachar("�")) STOP 1017 + if (iachar(achar(173)) /= 173) STOP 1018 + if (iachar ("�")/= 173) STOP 1019 + if (achar (173) /= "�") STOP 1020 + if ("�" /= achar ( ichar ( "�"))) STOP 1021 + i = 173 + c = "�" + if (achar(i) /= "�") STOP 1022 + if (iachar(c) /= iachar("�")) STOP 1023 + if (iachar(achar(174)) /= 174) STOP 1024 + if (iachar ("�")/= 174) STOP 1025 + if (achar (174) /= "�") STOP 1026 + if ("�" /= achar ( ichar ( "�"))) STOP 1027 + i = 174 + c = "�" + if (achar(i) /= "�") STOP 1028 + if (iachar(c) /= iachar("�")) STOP 1029 + if (iachar(achar(175)) /= 175) STOP 1030 + if (iachar ("�")/= 175) STOP 1031 + if (achar (175) /= "�") STOP 1032 + if ("�" /= achar ( ichar ( "�"))) STOP 1033 + i = 175 + c = "�" + if (achar(i) /= "�") STOP 1034 + if (iachar(c) /= iachar("�")) STOP 1035 + if (iachar(achar(176)) /= 176) STOP 1036 + if (iachar ("�")/= 176) STOP 1037 + if (achar (176) /= "�") STOP 1038 + if ("�" /= achar ( ichar ( "�"))) STOP 1039 + i = 176 + c = "�" + if (achar(i) /= "�") STOP 1040 + if (iachar(c) /= iachar("�")) STOP 1041 + if (iachar(achar(177)) /= 177) STOP 1042 + if (iachar ("�")/= 177) STOP 1043 + if (achar (177) /= "�") STOP 1044 + if ("�" /= achar ( ichar ( "�"))) STOP 1045 + i = 177 + c = "�" + if (achar(i) /= "�") STOP 1046 + if (iachar(c) /= iachar("�")) STOP 1047 + if (iachar(achar(178)) /= 178) STOP 1048 + if (iachar ("�")/= 178) STOP 1049 + if (achar (178) /= "�") STOP 1050 + if ("�" /= achar ( ichar ( "�"))) STOP 1051 + i = 178 + c = "�" + if (achar(i) /= "�") STOP 1052 + if (iachar(c) /= iachar("�")) STOP 1053 + if (iachar(achar(179)) /= 179) STOP 1054 + if (iachar ("�")/= 179) STOP 1055 + if (achar (179) /= "�") STOP 1056 + if ("�" /= achar ( ichar ( "�"))) STOP 1057 + i = 179 + c = "�" + if (achar(i) /= "�") STOP 1058 + if (iachar(c) /= iachar("�")) STOP 1059 + if (iachar(achar(180)) /= 180) STOP 1060 + if (iachar ("�")/= 180) STOP 1061 + if (achar (180) /= "�") STOP 1062 + if ("�" /= achar ( ichar ( "�"))) STOP 1063 + i = 180 + c = "�" + if (achar(i) /= "�") STOP 1064 + if (iachar(c) /= iachar("�")) STOP 1065 + if (iachar(achar(181)) /= 181) STOP 1066 + if (iachar ("�")/= 181) STOP 1067 + if (achar (181) /= "�") STOP 1068 + if ("�" /= achar ( ichar ( "�"))) STOP 1069 + i = 181 + c = "�" + if (achar(i) /= "�") STOP 1070 + if (iachar(c) /= iachar("�")) STOP 1071 + if (iachar(achar(182)) /= 182) STOP 1072 + if (iachar ("�")/= 182) STOP 1073 + if (achar (182) /= "�") STOP 1074 + if ("�" /= achar ( ichar ( "�"))) STOP 1075 + i = 182 + c = "�" + if (achar(i) /= "�") STOP 1076 + if (iachar(c) /= iachar("�")) STOP 1077 + if (iachar(achar(183)) /= 183) STOP 1078 + if (iachar ("�")/= 183) STOP 1079 + if (achar (183) /= "�") STOP 1080 + if ("�" /= achar ( ichar ( "�"))) STOP 1081 + i = 183 + c = "�" + if (achar(i) /= "�") STOP 1082 + if (iachar(c) /= iachar("�")) STOP 1083 + if (iachar(achar(184)) /= 184) STOP 1084 + if (iachar ("�")/= 184) STOP 1085 + if (achar (184) /= "�") STOP 1086 + if ("�" /= achar ( ichar ( "�"))) STOP 1087 + i = 184 + c = "�" + if (achar(i) /= "�") STOP 1088 + if (iachar(c) /= iachar("�")) STOP 1089 + if (iachar(achar(185)) /= 185) STOP 1090 + if (iachar ("�")/= 185) STOP 1091 + if (achar (185) /= "�") STOP 1092 + if ("�" /= achar ( ichar ( "�"))) STOP 1093 + i = 185 + c = "�" + if (achar(i) /= "�") STOP 1094 + if (iachar(c) /= iachar("�")) STOP 1095 + if (iachar(achar(186)) /= 186) STOP 1096 + if (iachar ("�")/= 186) STOP 1097 + if (achar (186) /= "�") STOP 1098 + if ("�" /= achar ( ichar ( "�"))) STOP 1099 + i = 186 + c = "�" + if (achar(i) /= "�") STOP 1100 + if (iachar(c) /= iachar("�")) STOP 1101 + if (iachar(achar(187)) /= 187) STOP 1102 + if (iachar ("�")/= 187) STOP 1103 + if (achar (187) /= "�") STOP 1104 + if ("�" /= achar ( ichar ( "�"))) STOP 1105 + i = 187 + c = "�" + if (achar(i) /= "�") STOP 1106 + if (iachar(c) /= iachar("�")) STOP 1107 + if (iachar(achar(188)) /= 188) STOP 1108 + if (iachar ("�")/= 188) STOP 1109 + if (achar (188) /= "�") STOP 1110 + if ("�" /= achar ( ichar ( "�"))) STOP 1111 + i = 188 + c = "�" + if (achar(i) /= "�") STOP 1112 + if (iachar(c) /= iachar("�")) STOP 1113 + if (iachar(achar(189)) /= 189) STOP 1114 + if (iachar ("�")/= 189) STOP 1115 + if (achar (189) /= "�") STOP 1116 + if ("�" /= achar ( ichar ( "�"))) STOP 1117 + i = 189 + c = "�" + if (achar(i) /= "�") STOP 1118 + if (iachar(c) /= iachar("�")) STOP 1119 + if (iachar(achar(190)) /= 190) STOP 1120 + if (iachar ("�")/= 190) STOP 1121 + if (achar (190) /= "�") STOP 1122 + if ("�" /= achar ( ichar ( "�"))) STOP 1123 + i = 190 + c = "�" + if (achar(i) /= "�") STOP 1124 + if (iachar(c) /= iachar("�")) STOP 1125 + if (iachar(achar(191)) /= 191) STOP 1126 + if (iachar ("�")/= 191) STOP 1127 + if (achar (191) /= "�") STOP 1128 + if ("�" /= achar ( ichar ( "�"))) STOP 1129 + i = 191 + c = "�" + if (achar(i) /= "�") STOP 1130 + if (iachar(c) /= iachar("�")) STOP 1131 + if (iachar(achar(192)) /= 192) STOP 1132 + if (iachar ("�")/= 192) STOP 1133 + if (achar (192) /= "�") STOP 1134 + if ("�" /= achar ( ichar ( "�"))) STOP 1135 + i = 192 + c = "�" + if (achar(i) /= "�") STOP 1136 + if (iachar(c) /= iachar("�")) STOP 1137 + if (iachar(achar(193)) /= 193) STOP 1138 + if (iachar ("�")/= 193) STOP 1139 + if (achar (193) /= "�") STOP 1140 + if ("�" /= achar ( ichar ( "�"))) STOP 1141 + i = 193 + c = "�" + if (achar(i) /= "�") STOP 1142 + if (iachar(c) /= iachar("�")) STOP 1143 + if (iachar(achar(194)) /= 194) STOP 1144 + if (iachar ("�")/= 194) STOP 1145 + if (achar (194) /= "�") STOP 1146 + if ("�" /= achar ( ichar ( "�"))) STOP 1147 + i = 194 + c = "�" + if (achar(i) /= "�") STOP 1148 + if (iachar(c) /= iachar("�")) STOP 1149 + if (iachar(achar(195)) /= 195) STOP 1150 + if (iachar ("�")/= 195) STOP 1151 + if (achar (195) /= "�") STOP 1152 + if ("�" /= achar ( ichar ( "�"))) STOP 1153 + i = 195 + c = "�" + if (achar(i) /= "�") STOP 1154 + if (iachar(c) /= iachar("�")) STOP 1155 + if (iachar(achar(196)) /= 196) STOP 1156 + if (iachar ("�")/= 196) STOP 1157 + if (achar (196) /= "�") STOP 1158 + if ("�" /= achar ( ichar ( "�"))) STOP 1159 + i = 196 + c = "�" + if (achar(i) /= "�") STOP 1160 + if (iachar(c) /= iachar("�")) STOP 1161 + if (iachar(achar(197)) /= 197) STOP 1162 + if (iachar ("�")/= 197) STOP 1163 + if (achar (197) /= "�") STOP 1164 + if ("�" /= achar ( ichar ( "�"))) STOP 1165 + i = 197 + c = "�" + if (achar(i) /= "�") STOP 1166 + if (iachar(c) /= iachar("�")) STOP 1167 + if (iachar(achar(198)) /= 198) STOP 1168 + if (iachar ("�")/= 198) STOP 1169 + if (achar (198) /= "�") STOP 1170 + if ("�" /= achar ( ichar ( "�"))) STOP 1171 + i = 198 + c = "�" + if (achar(i) /= "�") STOP 1172 + if (iachar(c) /= iachar("�")) STOP 1173 + if (iachar(achar(199)) /= 199) STOP 1174 + if (iachar ("�")/= 199) STOP 1175 + if (achar (199) /= "�") STOP 1176 + if ("�" /= achar ( ichar ( "�"))) STOP 1177 + i = 199 + c = "�" + if (achar(i) /= "�") STOP 1178 + if (iachar(c) /= iachar("�")) STOP 1179 + if (iachar(achar(200)) /= 200) STOP 1180 + if (iachar ("�")/= 200) STOP 1181 + if (achar (200) /= "�") STOP 1182 + if ("�" /= achar ( ichar ( "�"))) STOP 1183 + i = 200 + c = "�" + if (achar(i) /= "�") STOP 1184 + if (iachar(c) /= iachar("�")) STOP 1185 + if (iachar(achar(201)) /= 201) STOP 1186 + if (iachar ("�")/= 201) STOP 1187 + if (achar (201) /= "�") STOP 1188 + if ("�" /= achar ( ichar ( "�"))) STOP 1189 + i = 201 + c = "�" + if (achar(i) /= "�") STOP 1190 + if (iachar(c) /= iachar("�")) STOP 1191 + if (iachar(achar(202)) /= 202) STOP 1192 + if (iachar ("�")/= 202) STOP 1193 + if (achar (202) /= "�") STOP 1194 + if ("�" /= achar ( ichar ( "�"))) STOP 1195 + i = 202 + c = "�" + if (achar(i) /= "�") STOP 1196 + if (iachar(c) /= iachar("�")) STOP 1197 + if (iachar(achar(203)) /= 203) STOP 1198 + if (iachar ("�")/= 203) STOP 1199 + if (achar (203) /= "�") STOP 1200 + if ("�" /= achar ( ichar ( "�"))) STOP 1201 + i = 203 + c = "�" + if (achar(i) /= "�") STOP 1202 + if (iachar(c) /= iachar("�")) STOP 1203 + if (iachar(achar(204)) /= 204) STOP 1204 + if (iachar ("�")/= 204) STOP 1205 + if (achar (204) /= "�") STOP 1206 + if ("�" /= achar ( ichar ( "�"))) STOP 1207 + i = 204 + c = "�" + if (achar(i) /= "�") STOP 1208 + if (iachar(c) /= iachar("�")) STOP 1209 + if (iachar(achar(205)) /= 205) STOP 1210 + if (iachar ("�")/= 205) STOP 1211 + if (achar (205) /= "�") STOP 1212 + if ("�" /= achar ( ichar ( "�"))) STOP 1213 + i = 205 + c = "�" + if (achar(i) /= "�") STOP 1214 + if (iachar(c) /= iachar("�")) STOP 1215 + if (iachar(achar(206)) /= 206) STOP 1216 + if (iachar ("�")/= 206) STOP 1217 + if (achar (206) /= "�") STOP 1218 + if ("�" /= achar ( ichar ( "�"))) STOP 1219 + i = 206 + c = "�" + if (achar(i) /= "�") STOP 1220 + if (iachar(c) /= iachar("�")) STOP 1221 + if (iachar(achar(207)) /= 207) STOP 1222 + if (iachar ("�")/= 207) STOP 1223 + if (achar (207) /= "�") STOP 1224 + if ("�" /= achar ( ichar ( "�"))) STOP 1225 + i = 207 + c = "�" + if (achar(i) /= "�") STOP 1226 + if (iachar(c) /= iachar("�")) STOP 1227 + if (iachar(achar(208)) /= 208) STOP 1228 + if (iachar ("�")/= 208) STOP 1229 + if (achar (208) /= "�") STOP 1230 + if ("�" /= achar ( ichar ( "�"))) STOP 1231 + i = 208 + c = "�" + if (achar(i) /= "�") STOP 1232 + if (iachar(c) /= iachar("�")) STOP 1233 + if (iachar(achar(209)) /= 209) STOP 1234 + if (iachar ("�")/= 209) STOP 1235 + if (achar (209) /= "�") STOP 1236 + if ("�" /= achar ( ichar ( "�"))) STOP 1237 + i = 209 + c = "�" + if (achar(i) /= "�") STOP 1238 + if (iachar(c) /= iachar("�")) STOP 1239 + if (iachar(achar(210)) /= 210) STOP 1240 + if (iachar ("�")/= 210) STOP 1241 + if (achar (210) /= "�") STOP 1242 + if ("�" /= achar ( ichar ( "�"))) STOP 1243 + i = 210 + c = "�" + if (achar(i) /= "�") STOP 1244 + if (iachar(c) /= iachar("�")) STOP 1245 + if (iachar(achar(211)) /= 211) STOP 1246 + if (iachar ("�")/= 211) STOP 1247 + if (achar (211) /= "�") STOP 1248 + if ("�" /= achar ( ichar ( "�"))) STOP 1249 + i = 211 + c = "�" + if (achar(i) /= "�") STOP 1250 + if (iachar(c) /= iachar("�")) STOP 1251 + if (iachar(achar(212)) /= 212) STOP 1252 + if (iachar ("�")/= 212) STOP 1253 + if (achar (212) /= "�") STOP 1254 + if ("�" /= achar ( ichar ( "�"))) STOP 1255 + i = 212 + c = "�" + if (achar(i) /= "�") STOP 1256 + if (iachar(c) /= iachar("�")) STOP 1257 + if (iachar(achar(213)) /= 213) STOP 1258 + if (iachar ("�")/= 213) STOP 1259 + if (achar (213) /= "�") STOP 1260 + if ("�" /= achar ( ichar ( "�"))) STOP 1261 + i = 213 + c = "�" + if (achar(i) /= "�") STOP 1262 + if (iachar(c) /= iachar("�")) STOP 1263 + if (iachar(achar(214)) /= 214) STOP 1264 + if (iachar ("�")/= 214) STOP 1265 + if (achar (214) /= "�") STOP 1266 + if ("�" /= achar ( ichar ( "�"))) STOP 1267 + i = 214 + c = "�" + if (achar(i) /= "�") STOP 1268 + if (iachar(c) /= iachar("�")) STOP 1269 + if (iachar(achar(215)) /= 215) STOP 1270 + if (iachar ("�")/= 215) STOP 1271 + if (achar (215) /= "�") STOP 1272 + if ("�" /= achar ( ichar ( "�"))) STOP 1273 + i = 215 + c = "�" + if (achar(i) /= "�") STOP 1274 + if (iachar(c) /= iachar("�")) STOP 1275 + if (iachar(achar(216)) /= 216) STOP 1276 + if (iachar ("�")/= 216) STOP 1277 + if (achar (216) /= "�") STOP 1278 + if ("�" /= achar ( ichar ( "�"))) STOP 1279 + i = 216 + c = "�" + if (achar(i) /= "�") STOP 1280 + if (iachar(c) /= iachar("�")) STOP 1281 + if (iachar(achar(217)) /= 217) STOP 1282 + if (iachar ("�")/= 217) STOP 1283 + if (achar (217) /= "�") STOP 1284 + if ("�" /= achar ( ichar ( "�"))) STOP 1285 + i = 217 + c = "�" + if (achar(i) /= "�") STOP 1286 + if (iachar(c) /= iachar("�")) STOP 1287 + if (iachar(achar(218)) /= 218) STOP 1288 + if (iachar ("�")/= 218) STOP 1289 + if (achar (218) /= "�") STOP 1290 + if ("�" /= achar ( ichar ( "�"))) STOP 1291 + i = 218 + c = "�" + if (achar(i) /= "�") STOP 1292 + if (iachar(c) /= iachar("�")) STOP 1293 + if (iachar(achar(219)) /= 219) STOP 1294 + if (iachar ("�")/= 219) STOP 1295 + if (achar (219) /= "�") STOP 1296 + if ("�" /= achar ( ichar ( "�"))) STOP 1297 + i = 219 + c = "�" + if (achar(i) /= "�") STOP 1298 + if (iachar(c) /= iachar("�")) STOP 1299 + if (iachar(achar(220)) /= 220) STOP 1300 + if (iachar ("�")/= 220) STOP 1301 + if (achar (220) /= "�") STOP 1302 + if ("�" /= achar ( ichar ( "�"))) STOP 1303 + i = 220 + c = "�" + if (achar(i) /= "�") STOP 1304 + if (iachar(c) /= iachar("�")) STOP 1305 + if (iachar(achar(221)) /= 221) STOP 1306 + if (iachar ("�")/= 221) STOP 1307 + if (achar (221) /= "�") STOP 1308 + if ("�" /= achar ( ichar ( "�"))) STOP 1309 + i = 221 + c = "�" + if (achar(i) /= "�") STOP 1310 + if (iachar(c) /= iachar("�")) STOP 1311 + if (iachar(achar(222)) /= 222) STOP 1312 + if (iachar ("�")/= 222) STOP 1313 + if (achar (222) /= "�") STOP 1314 + if ("�" /= achar ( ichar ( "�"))) STOP 1315 + i = 222 + c = "�" + if (achar(i) /= "�") STOP 1316 + if (iachar(c) /= iachar("�")) STOP 1317 + if (iachar(achar(223)) /= 223) STOP 1318 + if (iachar ("�")/= 223) STOP 1319 + if (achar (223) /= "�") STOP 1320 + if ("�" /= achar ( ichar ( "�"))) STOP 1321 + i = 223 + c = "�" + if (achar(i) /= "�") STOP 1322 + if (iachar(c) /= iachar("�")) STOP 1323 + if (iachar(achar(224)) /= 224) STOP 1324 + if (iachar ("�")/= 224) STOP 1325 + if (achar (224) /= "�") STOP 1326 + if ("�" /= achar ( ichar ( "�"))) STOP 1327 + i = 224 + c = "�" + if (achar(i) /= "�") STOP 1328 + if (iachar(c) /= iachar("�")) STOP 1329 + if (iachar(achar(225)) /= 225) STOP 1330 + if (iachar ("�")/= 225) STOP 1331 + if (achar (225) /= "�") STOP 1332 + if ("�" /= achar ( ichar ( "�"))) STOP 1333 + i = 225 + c = "�" + if (achar(i) /= "�") STOP 1334 + if (iachar(c) /= iachar("�")) STOP 1335 + if (iachar(achar(226)) /= 226) STOP 1336 + if (iachar ("�")/= 226) STOP 1337 + if (achar (226) /= "�") STOP 1338 + if ("�" /= achar ( ichar ( "�"))) STOP 1339 + i = 226 + c = "�" + if (achar(i) /= "�") STOP 1340 + if (iachar(c) /= iachar("�")) STOP 1341 + if (iachar(achar(227)) /= 227) STOP 1342 + if (iachar ("�")/= 227) STOP 1343 + if (achar (227) /= "�") STOP 1344 + if ("�" /= achar ( ichar ( "�"))) STOP 1345 + i = 227 + c = "�" + if (achar(i) /= "�") STOP 1346 + if (iachar(c) /= iachar("�")) STOP 1347 + if (iachar(achar(228)) /= 228) STOP 1348 + if (iachar ("�")/= 228) STOP 1349 + if (achar (228) /= "�") STOP 1350 + if ("�" /= achar ( ichar ( "�"))) STOP 1351 + i = 228 + c = "�" + if (achar(i) /= "�") STOP 1352 + if (iachar(c) /= iachar("�")) STOP 1353 + if (iachar(achar(229)) /= 229) STOP 1354 + if (iachar ("�")/= 229) STOP 1355 + if (achar (229) /= "�") STOP 1356 + if ("�" /= achar ( ichar ( "�"))) STOP 1357 + i = 229 + c = "�" + if (achar(i) /= "�") STOP 1358 + if (iachar(c) /= iachar("�")) STOP 1359 + if (iachar(achar(230)) /= 230) STOP 1360 + if (iachar ("�")/= 230) STOP 1361 + if (achar (230) /= "�") STOP 1362 + if ("�" /= achar ( ichar ( "�"))) STOP 1363 + i = 230 + c = "�" + if (achar(i) /= "�") STOP 1364 + if (iachar(c) /= iachar("�")) STOP 1365 + if (iachar(achar(231)) /= 231) STOP 1366 + if (iachar ("�")/= 231) STOP 1367 + if (achar (231) /= "�") STOP 1368 + if ("�" /= achar ( ichar ( "�"))) STOP 1369 + i = 231 + c = "�" + if (achar(i) /= "�") STOP 1370 + if (iachar(c) /= iachar("�")) STOP 1371 + if (iachar(achar(232)) /= 232) STOP 1372 + if (iachar ("�")/= 232) STOP 1373 + if (achar (232) /= "�") STOP 1374 + if ("�" /= achar ( ichar ( "�"))) STOP 1375 + i = 232 + c = "�" + if (achar(i) /= "�") STOP 1376 + if (iachar(c) /= iachar("�")) STOP 1377 + if (iachar(achar(233)) /= 233) STOP 1378 + if (iachar ("�")/= 233) STOP 1379 + if (achar (233) /= "�") STOP 1380 + if ("�" /= achar ( ichar ( "�"))) STOP 1381 + i = 233 + c = "�" + if (achar(i) /= "�") STOP 1382 + if (iachar(c) /= iachar("�")) STOP 1383 + if (iachar(achar(234)) /= 234) STOP 1384 + if (iachar ("�")/= 234) STOP 1385 + if (achar (234) /= "�") STOP 1386 + if ("�" /= achar ( ichar ( "�"))) STOP 1387 + i = 234 + c = "�" + if (achar(i) /= "�") STOP 1388 + if (iachar(c) /= iachar("�")) STOP 1389 + if (iachar(achar(235)) /= 235) STOP 1390 + if (iachar ("�")/= 235) STOP 1391 + if (achar (235) /= "�") STOP 1392 + if ("�" /= achar ( ichar ( "�"))) STOP 1393 + i = 235 + c = "�" + if (achar(i) /= "�") STOP 1394 + if (iachar(c) /= iachar("�")) STOP 1395 + if (iachar(achar(236)) /= 236) STOP 1396 + if (iachar ("�")/= 236) STOP 1397 + if (achar (236) /= "�") STOP 1398 + if ("�" /= achar ( ichar ( "�"))) STOP 1399 + i = 236 + c = "�" + if (achar(i) /= "�") STOP 1400 + if (iachar(c) /= iachar("�")) STOP 1401 + if (iachar(achar(237)) /= 237) STOP 1402 + if (iachar ("�")/= 237) STOP 1403 + if (achar (237) /= "�") STOP 1404 + if ("�" /= achar ( ichar ( "�"))) STOP 1405 + i = 237 + c = "�" + if (achar(i) /= "�") STOP 1406 + if (iachar(c) /= iachar("�")) STOP 1407 + if (iachar(achar(238)) /= 238) STOP 1408 + if (iachar ("�")/= 238) STOP 1409 + if (achar (238) /= "�") STOP 1410 + if ("�" /= achar ( ichar ( "�"))) STOP 1411 + i = 238 + c = "�" + if (achar(i) /= "�") STOP 1412 + if (iachar(c) /= iachar("�")) STOP 1413 + if (iachar(achar(239)) /= 239) STOP 1414 + if (iachar ("�")/= 239) STOP 1415 + if (achar (239) /= "�") STOP 1416 + if ("�" /= achar ( ichar ( "�"))) STOP 1417 + i = 239 + c = "�" + if (achar(i) /= "�") STOP 1418 + if (iachar(c) /= iachar("�")) STOP 1419 + if (iachar(achar(240)) /= 240) STOP 1420 + if (iachar ("�")/= 240) STOP 1421 + if (achar (240) /= "�") STOP 1422 + if ("�" /= achar ( ichar ( "�"))) STOP 1423 + i = 240 + c = "�" + if (achar(i) /= "�") STOP 1424 + if (iachar(c) /= iachar("�")) STOP 1425 + if (iachar(achar(241)) /= 241) STOP 1426 + if (iachar ("�")/= 241) STOP 1427 + if (achar (241) /= "�") STOP 1428 + if ("�" /= achar ( ichar ( "�"))) STOP 1429 + i = 241 + c = "�" + if (achar(i) /= "�") STOP 1430 + if (iachar(c) /= iachar("�")) STOP 1431 + if (iachar(achar(242)) /= 242) STOP 1432 + if (iachar ("�")/= 242) STOP 1433 + if (achar (242) /= "�") STOP 1434 + if ("�" /= achar ( ichar ( "�"))) STOP 1435 + i = 242 + c = "�" + if (achar(i) /= "�") STOP 1436 + if (iachar(c) /= iachar("�")) STOP 1437 + if (iachar(achar(243)) /= 243) STOP 1438 + if (iachar ("�")/= 243) STOP 1439 + if (achar (243) /= "�") STOP 1440 + if ("�" /= achar ( ichar ( "�"))) STOP 1441 + i = 243 + c = "�" + if (achar(i) /= "�") STOP 1442 + if (iachar(c) /= iachar("�")) STOP 1443 + if (iachar(achar(244)) /= 244) STOP 1444 + if (iachar ("�")/= 244) STOP 1445 + if (achar (244) /= "�") STOP 1446 + if ("�" /= achar ( ichar ( "�"))) STOP 1447 + i = 244 + c = "�" + if (achar(i) /= "�") STOP 1448 + if (iachar(c) /= iachar("�")) STOP 1449 + if (iachar(achar(245)) /= 245) STOP 1450 + if (iachar ("�")/= 245) STOP 1451 + if (achar (245) /= "�") STOP 1452 + if ("�" /= achar ( ichar ( "�"))) STOP 1453 + i = 245 + c = "�" + if (achar(i) /= "�") STOP 1454 + if (iachar(c) /= iachar("�")) STOP 1455 + if (iachar(achar(246)) /= 246) STOP 1456 + if (iachar ("�")/= 246) STOP 1457 + if (achar (246) /= "�") STOP 1458 + if ("�" /= achar ( ichar ( "�"))) STOP 1459 + i = 246 + c = "�" + if (achar(i) /= "�") STOP 1460 + if (iachar(c) /= iachar("�")) STOP 1461 + if (iachar(achar(247)) /= 247) STOP 1462 + if (iachar ("�")/= 247) STOP 1463 + if (achar (247) /= "�") STOP 1464 + if ("�" /= achar ( ichar ( "�"))) STOP 1465 + i = 247 + c = "�" + if (achar(i) /= "�") STOP 1466 + if (iachar(c) /= iachar("�")) STOP 1467 + if (iachar(achar(248)) /= 248) STOP 1468 + if (iachar ("�")/= 248) STOP 1469 + if (achar (248) /= "�") STOP 1470 + if ("�" /= achar ( ichar ( "�"))) STOP 1471 + i = 248 + c = "�" + if (achar(i) /= "�") STOP 1472 + if (iachar(c) /= iachar("�")) STOP 1473 + if (iachar(achar(249)) /= 249) STOP 1474 + if (iachar ("�")/= 249) STOP 1475 + if (achar (249) /= "�") STOP 1476 + if ("�" /= achar ( ichar ( "�"))) STOP 1477 + i = 249 + c = "�" + if (achar(i) /= "�") STOP 1478 + if (iachar(c) /= iachar("�")) STOP 1479 + if (iachar(achar(250)) /= 250) STOP 1480 + if (iachar ("�")/= 250) STOP 1481 + if (achar (250) /= "�") STOP 1482 + if ("�" /= achar ( ichar ( "�"))) STOP 1483 + i = 250 + c = "�" + if (achar(i) /= "�") STOP 1484 + if (iachar(c) /= iachar("�")) STOP 1485 + if (iachar(achar(251)) /= 251) STOP 1486 + if (iachar ("�")/= 251) STOP 1487 + if (achar (251) /= "�") STOP 1488 + if ("�" /= achar ( ichar ( "�"))) STOP 1489 + i = 251 + c = "�" + if (achar(i) /= "�") STOP 1490 + if (iachar(c) /= iachar("�")) STOP 1491 + if (iachar(achar(252)) /= 252) STOP 1492 + if (iachar ("�")/= 252) STOP 1493 + if (achar (252) /= "�") STOP 1494 + if ("�" /= achar ( ichar ( "�"))) STOP 1495 + i = 252 + c = "�" + if (achar(i) /= "�") STOP 1496 + if (iachar(c) /= iachar("�")) STOP 1497 + if (iachar(achar(253)) /= 253) STOP 1498 + if (iachar ("�")/= 253) STOP 1499 + if (achar (253) /= "�") STOP 1500 + if ("�" /= achar ( ichar ( "�"))) STOP 1501 + i = 253 + c = "�" + if (achar(i) /= "�") STOP 1502 + if (iachar(c) /= iachar("�")) STOP 1503 + if (iachar(achar(254)) /= 254) STOP 1504 + if (iachar ("�")/= 254) STOP 1505 + if (achar (254) /= "�") STOP 1506 + if ("�" /= achar ( ichar ( "�"))) STOP 1507 + i = 254 + c = "�" + if (achar(i) /= "�") STOP 1508 + if (iachar(c) /= iachar("�")) STOP 1509 + if (iachar(achar(255)) /= 255) STOP 1510 + if (iachar ("�")/= 255) STOP 1511 + if (achar (255) /= "�") STOP 1512 + if ("�" /= achar ( ichar ( "�"))) STOP 1513 + i = 255 + c = "�" + if (achar(i) /= "�") STOP 1514 + if (iachar(c) /= iachar("�")) STOP 1515 + print *, 'DONE' +end program main + +! DejaGNU only checks the exit code but 'STOP 256' has exit code 0. Hence, +! check output for: +! { dg-output "DONE" } diff --git a/Fortran/gfortran/regression/achar_3.f90 b/Fortran/gfortran/regression/achar_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/achar_3.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-Wall" } +program main + print *,achar(-3) ! { dg-error "negative" } + print *,achar(200) ! { dg-warning "outside of range" } + print *,char(222+221) ! { dg-error "too large for the collating sequence" } + print *,char(-44) ! { dg-error "negative" } + print *,iachar("�") ! { dg-warning "outside of range" } +end program main diff --git a/Fortran/gfortran/regression/achar_4.f90 b/Fortran/gfortran/regression/achar_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/achar_4.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! Tests the fix for PR31257, in which achar caused an ICE because it had no +! charlen. +! +! The code comes from http://www.star.le.ac.uk/~cgp/fortran.html (by Clive Page) +! Reported by Thomas Koenig +! + if (any (Up ("AbCdEfGhIjKlM") .ne. (/"ABCDEFGHIJKLM"/))) STOP 1 +contains + Character (len=20) Function Up (string) + Character(len=*) string + Up = & + transfer(merge(achar(iachar(transfer(string,"x",len(string)))- & + (ichar('a')-ichar('A')) ), & + transfer(string,"x",len(string)) , & + transfer(string,"x",len(string)) >= "a" .and. & + transfer(string,"x",len(string)) <= "z"), repeat("x", len(string))) + return + end function Up +end diff --git a/Fortran/gfortran/regression/achar_5.f90 b/Fortran/gfortran/regression/achar_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/achar_5.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! +program test + + print *, char(255) + print *, achar(255) + print *, char(255,kind=1) + print *, achar(255,kind=1) + print *, char(255,kind=4) + print *, achar(255,kind=4) + + print *, char(0) + print *, achar(0) + print *, char(0,kind=1) + print *, achar(0,kind=1) + print *, char(0,kind=4) + print *, achar(0,kind=4) + + print *, char(297) ! { dg-error "too large for the collating sequence" } + print *, achar(297) ! { dg-error "too large for the collating sequence" } + print *, char(297,kind=1) ! { dg-error "too large for the collating sequence" } + print *, achar(297,kind=1) ! { dg-error "too large for the collating sequence" } + print *, char(297,kind=4) + print *, achar(297,kind=4) + + print *, char(-1) ! { dg-error "negative" } + print *, achar(-1) ! { dg-error "negative" } + print *, char(-1,kind=1) ! { dg-error "negative" } + print *, achar(-1,kind=1) ! { dg-error "negative" } + print *, char(-1,kind=4) ! { dg-error "negative" } + print *, achar(-1,kind=4) ! { dg-error "negative" } + + print *, char(huge(0_8)) ! { dg-error "too large for the collating sequence" } + print *, achar(huge(0_8)) ! { dg-error "too large for the collating sequence" } + print *, char(huge(0_8),kind=1) ! { dg-error "too large for the collating sequence" } + print *, achar(huge(0_8),kind=1) ! { dg-error "too large for the collating sequence" } + print *, char(huge(0_8),kind=4) ! { dg-error "too large for the collating sequence" } + print *, achar(huge(0_8),kind=4) ! { dg-error "too large for the collating sequence" } + +end program test diff --git a/Fortran/gfortran/regression/achar_6.F90 b/Fortran/gfortran/regression/achar_6.F90 --- /dev/null +++ b/Fortran/gfortran/regression/achar_6.F90 @@ -0,0 +1,70 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + +#define TEST(x,y,z) \ + call test (x, y, z, iachar(x), iachar(y), ichar(x), ichar(y)) + + TEST("a", 4_"a", 97) + TEST("\0", 4_"\0", 0) + TEST("\b", 4_"\b", 8) + TEST("\x80", 4_"\x80", int(z'80')) + TEST("\xFF", 4_"\xFF", int(z'FF')) + +#define TEST2(y,z) \ + call test_bis (y, z, iachar(y), ichar(y)) + + TEST2(4_"\u0100", int(z'0100')) + TEST2(4_"\ufe00", int(z'fe00')) + TEST2(4_"\u106a", int(z'106a')) + TEST2(4_"\uff00", int(z'ff00')) + TEST2(4_"\uffff", int(z'ffff')) + +contains + +subroutine test (s1, s4, i, i1, i2, i3, i4) + character(kind=1,len=1) :: s1 + character(kind=4,len=1) :: s4 + integer :: i, i1, i2, i3, i4 + + if (i /= i1) STOP 1 + if (i /= i2) STOP 2 + if (i /= i3) STOP 3 + if (i /= i4) STOP 4 + + if (iachar (s1) /= i) STOP 5 + if (iachar (s4) /= i) STOP 6 + + if (ichar (s1) /= i) STOP 7 + if (ichar (s4) /= i) STOP 8 + + if (achar(i, kind=1) /= s1) STOP 9 + if (achar(i, kind=4) /= s4) STOP 10 + + if (char(i, kind=1) /= s1) STOP 11 + if (char(i, kind=4) /= s4) STOP 12 + + if (iachar(achar(i, kind=1)) /= i) STOP 13 + if (iachar(achar(i, kind=4)) /= i) STOP 14 + + if (ichar(char(i, kind=1)) /= i) STOP 15 + if (ichar(char(i, kind=4)) /= i) STOP 16 + +end subroutine test + +subroutine test_bis (s4, i, i2, i4) + character(kind=4,len=1) :: s4 + integer :: i, i2, i4 + + if (i /= i2) STOP 17 + if (i /= i4) STOP 18 + + if (iachar (s4) /= i) STOP 19 + if (ichar (s4) /= i) STOP 20 + if (achar(i, kind=4) /= s4) STOP 21 + if (char(i, kind=4) /= s4) STOP 22 + if (iachar(achar(i, kind=4)) /= i) STOP 23 + if (ichar(char(i, kind=4)) /= i) STOP 24 + +end subroutine test_bis + +end diff --git a/Fortran/gfortran/regression/actual_array_constructor_1.f90 b/Fortran/gfortran/regression/actual_array_constructor_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/actual_array_constructor_1.f90 @@ -0,0 +1,80 @@ +! { dg-do run } +! Test the fix by HJ Lu for PR23634 and friends. All involve the ICE +! that arose from a character array constructor usedas an actual +! argument. +! +! The various parts of this test are taken from the PRs. +! +! Test PR26491 +module global + public p, line + interface p + module procedure p + end interface + character(128) :: line = 'abcdefghijklmnopqrstuvwxyz' +contains + subroutine p() + character(128) :: word + word = line + call redirect_((/word/)) + end subroutine + subroutine redirect_ (ch) + character(*) :: ch(:) + if (ch(1) /= line) STOP 1 + end subroutine redirect_ +end module global + +! Test PR26550 +module my_module + implicit none + type point + real :: x + end type point + type(point), pointer, public :: stdin => NULL() +contains + subroutine my_p(w) + character(128) :: w + call r(stdin,(/w/)) + end subroutine my_p + subroutine r(ptr, io) + use global + type(point), pointer :: ptr + character(128) :: io(:) + if (associated (ptr)) STOP 2 + if (io(1) .ne. line) STOP 3 + end subroutine r +end module my_module + +program main + use global + use my_module + + integer :: i(6) = (/1,6,3,4,5,2/) + character (6) :: a = 'hello ', t + character(len=1) :: s(6) = (/'g','g','d','d','a','o'/) + equivalence (s, t) + + call option_stopwatch_s (a) ! Call test of PR25619 + call p () ! Call test of PR26491 + call my_p (line) ! Call test of PR26550 + +! Test Vivek Rao's bug, as reported in PR25619. + s = s(i) + call option_stopwatch_a ((/a,'hola! ', t/)) + +contains + +! Test PR23634 + subroutine option_stopwatch_s(a) + character (*), intent(in) :: a + character (len=len(a)) :: b + + b = 'hola! ' + call option_stopwatch_a((/a, b, 'goddag'/)) + end subroutine option_stopwatch_s + subroutine option_stopwatch_a (a) + character (*) :: a(:) + if (any (a .ne. (/'hello ','hola! ','goddag'/))) STOP 4 + end subroutine option_stopwatch_a + +end program main diff --git a/Fortran/gfortran/regression/actual_array_constructor_2.f90 b/Fortran/gfortran/regression/actual_array_constructor_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/actual_array_constructor_2.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! Tests the fix for pr28167, in which character array constructors +! with an implied do loop would cause an ICE, when used as actual +! arguments. +! +! Based on the testscase by Harald Anlauf +! + character(4), dimension(4) :: c1, c2 + integer m + m = 4 +! Test the original problem + call foo ((/( 'abcd',i=1,m )/), c2) + if (any(c2(:) .ne. (/'abcd','abcd', & + 'abcd','abcd'/))) STOP 1 + +! Now get a bit smarter + call foo ((/"abcd", "efgh", "ijkl", "mnop"/), c1) ! worked previously + call foo ((/(c1(i), i = m,1,-1)/), c2) ! was broken + if (any(c2(4:1:-1) .ne. c1)) STOP 2 + +! gfc_todo: Not Implemented: complex character array constructors + call foo ((/(c1(i)(i/2+1:i/2+2), i = 1,4)/), c2) ! Ha! take that..! + if (any (c2 .ne. (/"ab ","fg ","jk ","op "/))) STOP 3 + +! Check functions in the constructor + call foo ((/(achar(64+i)//achar(68+i)//achar(72+i)// & + achar(76+i),i=1,4 )/), c1) ! was broken + if (any (c1 .ne. (/"AEIM","BFJN","CGKO","DHLP"/))) STOP 4 +contains + subroutine foo (chr1, chr2) + character(*), dimension(:) :: chr1, chr2 + chr2 = chr1 + end subroutine foo +end diff --git a/Fortran/gfortran/regression/actual_array_constructor_3.f90 b/Fortran/gfortran/regression/actual_array_constructor_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/actual_array_constructor_3.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! Tests the fix for pr28914, in which array constructors using the loop +! variable within a do loop for the implied do loop of the constructor +! would result in a corrupted do loop counter. +! +! Based on the testscase by Ed Korkven +! +program pr28914 + implicit none + integer n, i + parameter (n = 66000) ! Problem manifests for n > 65535 + double precision a(n), summation + + summation = 0.0 + do i = 1, 1 + a = (/ (i, i = 1, n) /) ! This is legal and was broken + a = sqrt(a) + summation = SUM(a) + enddo + summation = abs(summation - 11303932.9138271_8) + + if (summation.gt.0.00001) STOP 1 +end program pr28914 + + diff --git a/Fortran/gfortran/regression/actual_array_interface_1.f90 b/Fortran/gfortran/regression/actual_array_interface_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/actual_array_interface_1.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! Tests the fix for PR29490, in which the creation of the +! interface expression for the first argument of the call to +! 'john' would cause an ICE because GFC_TYPE_ARRAY_LBOUND +! was NULL. +! +! Contributed by Philip Mason +! + !--------------------------------- + program fred + !--------------------------------- + real :: dezz(1:10) + real, allocatable :: jack(:) + ! + allocate(jack(10)); jack = 9. + dezz = john(jack,1) + print*,'dezz = ',dezz + + contains + !--------------------------------- + function john(t,il) + !--------------------------------- + real :: t(il:) + real :: john(1:10) + john = 10. + end function john + end diff --git a/Fortran/gfortran/regression/actual_array_interface_2.f90 b/Fortran/gfortran/regression/actual_array_interface_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/actual_array_interface_2.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +program gprogram + implicit none + real, dimension(-2:0) :: my_arr + call fill_array(my_arr) + contains + subroutine fill_array(arr) + implicit none + real, dimension(-2:0), intent(out) :: arr + arr = 42 + end subroutine fill_array +end program gprogram + diff --git a/Fortran/gfortran/regression/actual_array_offset_1.f90 b/Fortran/gfortran/regression/actual_array_offset_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/actual_array_offset_1.f90 @@ -0,0 +1,167 @@ +! { dg-do run } +! +! Check the fix for PR67779, in which array sections passed in the +! recursive calls to 'quicksort' had an incorrect offset. +! +! Contributed by Arjen Markus +! +! NOTE: This is the version of the testcase in comment #16 (from Thomas Koenig) +! +module myclass_def + implicit none + + type, abstract :: myclass + contains + procedure(assign_object), deferred :: copy + procedure(one_lower_than_two), deferred :: lower + procedure(print_object), deferred :: print + procedure, nopass :: quicksort ! without nopass, it does not work + end type myclass + + abstract interface + subroutine assign_object( left, right ) + import :: myclass + class(myclass), intent(inout) :: left + class(myclass), intent(in) :: right + end subroutine assign_object + end interface + + abstract interface + logical function one_lower_than_two( op1, op2 ) + import :: myclass + class(myclass), intent(in) :: op1, op2 + end function one_lower_than_two + end interface + + abstract interface + subroutine print_object( obj ) + import :: myclass + class(myclass), intent(in) :: obj + end subroutine print_object + end interface + + ! + ! Type containing a real + ! + + type, extends(myclass) :: mysortable + integer :: value + contains + procedure :: copy => copy_sortable + procedure :: lower => lower_sortable + procedure :: print => print_sortable + end type mysortable + +contains +! +! Generic part +! +recursive subroutine quicksort( array ) + class(myclass), dimension(:) :: array + + class(myclass), allocatable :: v, tmp + integer :: i, j + + integer :: k + + i = 1 + j = size(array) + + allocate( v, source = array(1) ) + allocate( tmp, source = array(1) ) + + call v%copy( array((j+i)/2) ) ! Use the middle element + + do + do while ( array(i)%lower(v) ) + i = i + 1 + enddo + do while ( v%lower(array(j)) ) + j = j - 1 + enddo + + if ( i <= j ) then + call tmp%copy( array(i) ) + call array(i)%copy( array(j) ) + call array(j)%copy( tmp ) + i = i + 1 + j = j - 1 + endif + + if ( i > j ) then + exit + endif + enddo + + if ( 1 < j ) then + call quicksort( array(1:j) ) ! Problem here + endif + + if ( i < size(array) ) then + call quicksort( array(i:) ) ! ....and here + endif +end subroutine quicksort + +! +! Specific part +! +subroutine copy_sortable( left, right ) + class(mysortable), intent(inout) :: left + class(myclass), intent(in) :: right + + select type (right) + type is (mysortable) + select type (left) + type is (mysortable) + left = right + end select + end select +end subroutine copy_sortable + +logical function lower_sortable( op1, op2 ) + class(mysortable), intent(in) :: op1 + class(myclass), intent(in) :: op2 + + select type (op2) + type is (mysortable) + lower_sortable = op1%value < op2%value + end select +end function lower_sortable + +subroutine print_sortable( obj ) + class(mysortable), intent(in) :: obj + + write(*,'(G0," ")', advance="no") obj%value +end subroutine print_sortable + +end module myclass_def + + +! test program +program test_quicksort + use myclass_def + + implicit none + + type(mysortable), dimension(20) :: array + real, dimension(20) :: values + + call random_number(values) + + array%value = int (1000000 * values) + +! It would be pretty perverse if this failed! + if (check (array)) STOP 1 + + call quicksort( array ) + +! Check the array is correctly ordered + if (.not.check (array)) STOP 2 +contains + logical function check (arg) + type(mysortable), dimension(:) :: arg + integer :: s + s = size (arg, 1) + check = all (arg(2 : s)%value .ge. arg(1 : s - 1)%value) + end function check +end program test_quicksort diff --git a/Fortran/gfortran/regression/actual_array_result_1.f90 b/Fortran/gfortran/regression/actual_array_result_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/actual_array_result_1.f90 @@ -0,0 +1,70 @@ +! { dg-do run } +! PR fortan/31692 +! Passing array valued results to procedures +! +! Test case contributed by rakuen_himawari@yahoo.co.jp +module one + integer :: flag = 0 +contains + function foo1 (n) + integer :: n + integer :: foo1(n) + if (flag == 0) then + call bar1 (n, foo1) + else + call bar2 (n, foo1) + end if + end function + + function foo2 (n) + implicit none + integer :: n + integer,ALLOCATABLE :: foo2(:) + allocate (foo2(n)) + if (flag == 0) then + call bar1 (n, foo2) + else + call bar2 (n, foo2) + end if + end function + + function foo3 (n) + implicit none + integer :: n + integer,ALLOCATABLE :: foo3(:) + allocate (foo3(n)) + foo3 = 0 + call bar2(n, foo3(2:(n-1))) ! Check that sections are OK + end function + + subroutine bar1 (n, array) ! Checks assumed size formal arg. + integer :: n + integer :: array(*) + integer :: i + do i = 1, n + array(i) = i + enddo + end subroutine + + subroutine bar2(n, array) ! Checks assumed shape formal arg. + integer :: n + integer :: array(:) + integer :: i + do i = 1, size (array, 1) + array(i) = i + enddo + end subroutine +end module + +program main + use one + integer :: n + n = 3 + if(any (foo1(n) /= [ 1,2,3 ])) STOP 1 + if(any (foo2(n) /= [ 1,2,3 ])) STOP 2 + flag = 1 + if(any (foo1(n) /= [ 1,2,3 ])) STOP 3 + if(any (foo2(n) /= [ 1,2,3 ])) STOP 4 + n = 5 + if(any (foo3(n) /= [ 0,1,2,3,0 ])) STOP 5 +end program diff --git a/Fortran/gfortran/regression/actual_array_substr_1.f90 b/Fortran/gfortran/regression/actual_array_substr_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/actual_array_substr_1.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! Test fix of PR28118, in which a substring reference to an +! actual argument with an array reference would cause a segfault. +! +! Contributed by Paul Thomas +! +program gfcbug33 + character(12) :: a(2) + a(1) = "abcdefghijkl" + a(2) = "mnopqrstuvwx" + call foo ((a(2:1:-1)(6:))) + call bar ((a(:)(7:11))) +contains + subroutine foo (chr) + character(7) :: chr(:) + if (chr(1)//chr(2) .ne. "rstuvwxfghijkl") STOP 1 + end subroutine foo + subroutine bar (chr) + character(*) :: chr(:) + if (trim(chr(1))//trim(chr(2)) .ne. "ghijkstuvw") STOP 2 + end subroutine bar +end program gfcbug33 diff --git a/Fortran/gfortran/regression/actual_array_substr_2.f90 b/Fortran/gfortran/regression/actual_array_substr_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/actual_array_substr_2.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! Tests the fix for pr28174, in which the fix for pr28118 was +! corrupting the character lengths of arrays that shared a +! character length structure. In addition, in developing the +! fix, it was noted that intent(out/inout) arguments were not +! getting written back to the calling scope. +! +! Based on the testscase by Harald Anlauf +! +program pr28174 + implicit none + character(len=12) :: teststring(2) = (/ "abc def ghij", & + "klm nop qrst" /) + character(len=12) :: a(2), b(2), c(2), d(2) + integer :: m = 7, n + a = teststring + b = a + c = a + d = a + n = m - 4 + +! Make sure that variable substring references work. + call foo (a(:)(m:m+5), c(:)(n:m+2), d(:)(5:9)) + if (any (a .ne. teststring)) STOP 1 + if (any (b .ne. teststring)) STOP 2 + if (any (c .ne. (/"ab456789#hij", & + "kl7654321rst"/))) STOP 3 + if (any (d .ne. (/"abc 23456hij", & + "klm 98765rst"/))) STOP 4 +contains + subroutine foo (w, x, y) + character(len=*), intent(in) :: w(:) + character(len=*), intent(inOUT) :: x(:) + character(len=*), intent(OUT) :: y(:) + character(len=12) :: foostring(2) = (/"0123456789#$" , & + "$#9876543210"/) +! This next is not required by the standard but tests the +! functioning of the gfortran implementation. +! if (all (x(:)(3:7) .eq. y)) STOP 5 + x = foostring (:)(5 : 4 + len (x)) + y = foostring (:)(3 : 2 + len (y)) + end subroutine foo +end program pr28174 + diff --git a/Fortran/gfortran/regression/actual_array_substr_3.f90 b/Fortran/gfortran/regression/actual_array_substr_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/actual_array_substr_3.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } +! PR 43072 - no temporary needed because the substring +! is of equal length to the string. +subroutine foo2 + implicit none + external foo + character(len=20) :: str(2) = '1234567890' + call foo(str(:)(1:20)) +end +! { dg-final { scan-tree-dump-not "memmove" "original" } } diff --git a/Fortran/gfortran/regression/actual_array_vect_1.f90 b/Fortran/gfortran/regression/actual_array_vect_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/actual_array_vect_1.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! PR fortran/32323 +! Array sections with vector subscripts are not allowed +! with dummy arguments which have VOLATILE or INTENT OUT/INOUT +! +! Contributed by terry@chem.gu.se +! +module mod +implicit none +contains +subroutine aa(v) +integer,dimension(:),volatile::v +write(*,*)size(v) +v=0 +end subroutine aa +subroutine bb(v) +integer,dimension(:),intent(out)::v +write(*,*)size(v) +v=0 +end subroutine bb +end module mod + +program ff +use mod +implicit none +integer,dimension(10)::w +w=1 +call aa(w(2:4)) +call aa(w((/3,2,1/))) ! { dg-error "vector subscript" } +call bb(w(2:4)) +call bb(w((/3,2,1/))) ! { dg-error "vector subscript" } +write(*,*)w +end diff --git a/Fortran/gfortran/regression/actual_pointer_function_1.f90 b/Fortran/gfortran/regression/actual_pointer_function_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/actual_pointer_function_1.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! Tests the fix for PR31211, in which the value of the result for +! cp_get_default_logger was stored as a temporary, rather than the +! pointer itself. This caused a segfault when the result was +! nullified. +! +! Contributed by Joost VandeVondele +! + TYPE cp_logger_type + INTEGER :: a + END TYPE cp_logger_type + + if (cp_logger_log(cp_get_default_logger (0))) STOP 1 + if (.not. cp_logger_log(cp_get_default_logger (42))) STOP 2 + +CONTAINS + + logical function cp_logger_log(logger) + TYPE(cp_logger_type), POINTER ::logger + if (associated (logger)) then + cp_logger_log = (logger%a .eq. 42) + else + cp_logger_log = .false. + end if + END function + + FUNCTION cp_get_default_logger(v) RESULT(res) + TYPE(cp_logger_type), POINTER ::res + integer :: v + if (v .eq. 0) then + NULLIFY(RES) + else + allocate(RES) + res%a = v + end if + END FUNCTION cp_get_default_logger +END diff --git a/Fortran/gfortran/regression/actual_procedure_1.f90 b/Fortran/gfortran/regression/actual_procedure_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/actual_procedure_1.f90 @@ -0,0 +1,71 @@ +! { dg-do run } +! Tests the fix for PR36433 in which a check for the array size +! or character length of the actual arguments of foo and bar +! would reject this legal code. +! +! Contributed by Paul Thomas +! +module m +contains + function proc4 (arg, chr) + integer, dimension(10) :: proc4 + integer, intent(in) :: arg + character(8), intent(inout) :: chr + proc4 = arg + chr = "proc4" + end function + function chr_proc () + character(8) :: chr_proc + chr_proc = "chr_proc" + end function +end module + +program procPtrTest + use m + character(8) :: chr + interface + function proc_ext (arg, chr) + integer, dimension(10) :: proc_ext + integer, intent(in) :: arg + character(8), intent(inout) :: chr + end function + end interface +! Check the passing of a module function + call foo (proc4, chr) + if (trim (chr) .ne. "proc4") STOP 1 +! Check the passing of an external function + call foo (proc_ext, chr) +! Check the passing of a character function + if (trim (chr) .ne. "proc_ext") STOP 2 + call bar (chr_proc) +contains + subroutine foo (p, chr) + character(8), intent(inout) :: chr + integer :: i(10) + interface + function p (arg, chr) + integer, dimension(10) :: p + integer, intent(in) :: arg + character(8), intent(inout) :: chr + end function + end interface + i = p (99, chr) + if (any(i .ne. 99)) STOP 3 + end subroutine + subroutine bar (p) + interface + function p () + character(8):: p + end function + end interface + if (p () .ne. "chr_proc") STOP 4 + end subroutine +end program + +function proc_ext (arg, chr) + integer, dimension(10) :: proc_ext + integer, intent(in) :: arg + character(8), intent(inout) :: chr + proc_ext = arg + chr = "proc_ext" +end function diff --git a/Fortran/gfortran/regression/actual_rank_check_1.f90 b/Fortran/gfortran/regression/actual_rank_check_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/actual_rank_check_1.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! Test the fix for PR40158, where the errro message was not clear about scalars. +! +! Contributed by Tobias Burnus +! + implicit none + integer :: i(4,5),j + i = 0 + call sub1(i) + call sub1(j) ! { dg-error "rank-1 and scalar" } + call sub2(i) ! { dg-error "scalar and rank-2" } + call sub2(j) + print '(5i0)', i +contains + subroutine sub1(i1) + integer :: i1(*) + i1(1) = 2 + end subroutine sub1 + subroutine sub2(i2) + integer :: i2 + i2 = 2 + end subroutine sub2 +end diff --git a/Fortran/gfortran/regression/adjustl_1.f90 b/Fortran/gfortran/regression/adjustl_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/adjustl_1.f90 @@ -0,0 +1,8 @@ +! { dg-do run } +! PR 52749 - this used to ICE. +! Original test case by Stefan Mauerberger. +PROGRAM test + character(len=10) :: u + WRITE(unit=u,fmt='(3A)') PACK(ADJUSTL([" a", " b"]), [.TRUE., .FALSE.]) + if (u .ne. 'a ') STOP 1 +END PROGRAM test diff --git a/Fortran/gfortran/regression/advance_1.f90 b/Fortran/gfortran/regression/advance_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/advance_1.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! PR25463 Check that advance='no' works correctly. +! Derived from example given in PR by Thomas Koenig +! Contributed by Jerry DeLisle +program pr25463 + character(10) :: str + write (10,'(A)',advance="no") 'ab' + write (10,'(TL2,A)') 'c' + rewind (10) + read (10, '(a)') str + if (str.ne.'abc') STOP 1 + close (10, status='delete') +end diff --git a/Fortran/gfortran/regression/advance_2.f90 b/Fortran/gfortran/regression/advance_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/advance_2.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +subroutine foo + character(len=5) :: a + a = "yes" + write(*, '(a)', advance=a) "hello world" +end subroutine foo diff --git a/Fortran/gfortran/regression/advance_3.f90 b/Fortran/gfortran/regression/advance_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/advance_3.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +subroutine foo + real :: a + a = 1 + write(*, '(a)', advance=a) "hello world" ! { dg-error "must be of type CHARACTER" } +end subroutine foo +subroutine bar + write(*, '(a)', advance=5.) "hello world" ! { dg-error "must be of type CHARACTER" } +end subroutine bar diff --git a/Fortran/gfortran/regression/advance_4.f90 b/Fortran/gfortran/regression/advance_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/advance_4.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! PR31207 Last record truncated for read after short write +program main + character(10) :: answer + write (12,'(A,T2,A)',advance="no") 'XXXXXX','ABCD' + close (12) + read (12, '(6A)') answer + close (12, status="delete") + if (answer /= "XABCDX") STOP 1 +end program main diff --git a/Fortran/gfortran/regression/advance_5.f90 b/Fortran/gfortran/regression/advance_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/advance_5.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! PR31207 Last record truncated for read after short write. +character(len=20) :: b +! write something no advance +open(10,file="fort.10",position="rewind") +write(10, '(a,t1,a)',advance='no') 'xxxxxx', 'abc' +close(10) +! append some data +open(10,file="fort.10",position="append") +write(10, '(a)') 'def' +close(10) +! check what is in the first record +open(10,file="fort.10",position="rewind") +read(10,'(a)') b +close(10, status="delete") +if (b.ne."abcxxx") STOP 1 +end diff --git a/Fortran/gfortran/regression/advance_6.f90 b/Fortran/gfortran/regression/advance_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/advance_6.f90 @@ -0,0 +1,76 @@ +! { dg-do run { target fd_truncate } } +! PR 34370 - file positioning after non-advancing I/O didn't add +! a record marker. + +program main + implicit none + character(len=3) :: c + character(len=80), parameter :: fname = "advance_backspace_1.dat" + + call write_file + close (95) + call check_end_record + + call write_file + backspace 95 + c = 'xxx' + read (95,'(A)') c + if (c /= 'ab ') STOP 1 + close (95) + call check_end_record + + call write_file + backspace 95 + close (95) + call check_end_record + + call write_file + endfile 95 + close (95) + call check_end_record + + call write_file + endfile 95 + rewind 95 + c = 'xxx' + read (95,'(A)') c + if (c /= 'ab ') STOP 2 + close (95) + call check_end_record + + call write_file + rewind 95 + c = 'xxx' + read (95,'(A)') c + if (c /= 'ab ') STOP 3 + close (95) + call check_end_record + +contains + + subroutine write_file + open(95, file=fname, status="replace", form="formatted") + write (95, '(A)', advance="no") 'a' + write (95, '(A)', advance="no") 'b' + end subroutine write_file + +! Checks for correct end record, then deletes the file. + + subroutine check_end_record + character(len=1) :: x + open(2003, file=fname, status="old", access="stream", form="unformatted") + read(2003) x + if (x /= 'a') STOP 4 + read(2003) x + if (x /= 'b') STOP 5 + read(2003) x + if (x /= achar(10)) then + read(2003) x + if (x /= achar(13)) then + else + STOP 6 + end if + end if + close(2003,status="delete") + end subroutine check_end_record +end program main diff --git a/Fortran/gfortran/regression/aint_anint_1.f90 b/Fortran/gfortran/regression/aint_anint_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/aint_anint_1.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +program aint_anint_1 + + implicit none + + real(4) :: r = 42.7, r1, r2 + real(8) :: s = 42.7D0, s1, s2 + + r1 = aint(r) + r2 = aint(r,kind=8) + if (abs(r1 - r2) > 0.1) STOP 1 + + r1 = anint(r) + r2 = anint(r,kind=8) + if (abs(r1 - r2) > 0.1) STOP 2 + + s1 = aint(s) + s2 = aint(s, kind=4) + if (abs(s1 - s2) > 0.1) STOP 3 + + s1 = anint(s) + s2 = anint(s, kind=4) + if (abs(s1 - s2) > 0.1) STOP 4 + + +end program aint_anint_1 + diff --git a/Fortran/gfortran/regression/aliasing_array_result_1.f90 b/Fortran/gfortran/regression/aliasing_array_result_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/aliasing_array_result_1.f90 @@ -0,0 +1,163 @@ +! { dg-do run } +! Tests the fic for PR44582, where gfortran was found to +! produce an incorrect result when the result of a function +! was aliased by a host or use associated variable, to which +! the function is assigned. In these cases a temporary is +! required in the function assignments. The check has to be +! rather restrictive. Whilst the cases marked below might +! not need temporaries, the TODOs are going to be tough. +! +! Reported by Yin Ma and +! elaborated by Tobias Burnus +! +module foo + INTEGER, PARAMETER :: ONE = 1 + INTEGER, PARAMETER :: TEN = 10 + INTEGER, PARAMETER :: FIVE = TEN/2 + INTEGER, PARAMETER :: TWO = 2 + integer :: foo_a(ONE) + integer :: check(ONE) = TEN + LOGICAL :: abort_flag = .false. +contains + function foo_f() + integer :: foo_f(ONE) + foo_f = -FIVE + foo_f = foo_a - foo_f + end function foo_f + subroutine bar + foo_a = FIVE +! This aliases 'foo_a' by host association. + foo_a = foo_f () + if (any (foo_a .ne. check)) call myabort (0) + end subroutine bar + subroutine myabort(fl) + integer :: fl + print *, fl + abort_flag = .true. + end subroutine myabort +end module foo + +function h_ext() + use foo + integer :: h_ext(ONE) + h_ext = -FIVE + h_ext = FIVE - h_ext +end function h_ext + +function i_ext() result (h) + use foo + integer :: h(ONE) + h = -FIVE + h = FIVE - h +end function i_ext + +subroutine tobias + use foo + integer :: a(ONE) + a = FIVE + call sub1(a) + if (any (a .ne. check)) call myabort (1) +contains + subroutine sub1(x) + integer :: x(ONE) +! 'x' is aliased by host association in 'f'. + x = f() + end subroutine sub1 + function f() + integer :: f(ONE) + f = ONE + f = a + FIVE + end function f +end subroutine tobias + +program test + use foo + implicit none + common /foo_bar/ c + integer :: a(ONE), b(ONE), c(ONE), d(ONE) + interface + function h_ext() + use foo + integer :: h_ext(ONE) + end function h_ext + end interface + interface + function i_ext() result (h) + use foo + integer :: h(ONE) + end function i_ext + end interface + + a = FIVE +! This aliases 'a' by host association + a = f() + if (any (a .ne. check)) call myabort (2) + a = FIVE + if (any (f() .ne. check)) call myabort (3) + call bar + foo_a = FIVE +! This aliases 'foo_a' by host association. + foo_a = g () + if (any (foo_a .ne. check)) call myabort (4) + a = FIVE + a = h() ! TODO: Needs no temporary + if (any (a .ne. check)) call myabort (5) + a = FIVE + a = i() ! TODO: Needs no temporary + if (any (a .ne. check)) call myabort (6) + a = FIVE + a = h_ext() ! Needs no temporary - was OK + if (any (a .ne. check)) call myabort (15) + a = FIVE + a = i_ext() ! Needs no temporary - was OK + if (any (a .ne. check)) call myabort (16) + c = FIVE +! This aliases 'c' through the common block. + c = j() + if (any (c .ne. check)) call myabort (7) + call aaa + call tobias + if (abort_flag) STOP 1 +contains + function f() + integer :: f(ONE) + f = -FIVE + f = a - f + end function f + function g() + integer :: g(ONE) + g = -FIVE + g = foo_a - g + end function g + function h() + integer :: h(ONE) + h = -FIVE + h = FIVE - h + end function h + function i() result (h) + integer :: h(ONE) + h = -FIVE + h = FIVE - h + end function i + function j() + common /foo_bar/ cc + integer :: j(ONE), cc(ONE) + j = -FIVE + j = cc - j + end function j + subroutine aaa() + d = TEN - TWO +! This aliases 'd' through 'get_d'. + d = bbb() + if (any (d .ne. check)) call myabort (8) + end subroutine aaa + function bbb() + integer :: bbb(ONE) + bbb = TWO + bbb = bbb + get_d() + end function bbb + function get_d() + integer :: get_d(ONE) + get_d = d + end function get_d +end program test diff --git a/Fortran/gfortran/regression/aliasing_dummy_1.f90 b/Fortran/gfortran/regression/aliasing_dummy_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/aliasing_dummy_1.f90 @@ -0,0 +1,67 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! This tests the fix for PR24276, which originated from the Loren P. Meissner example, +! Array_List. The PR concerns dummy argument aliassing of components of arrays of derived +! types as arrays of the type of the component. gfortran would compile and run this +! example but the stride used did not match the actual argument. This test case exercises +! a procedure call (to foo2, below) that is identical to Array_List's. +! +! Contributed by Paul Thomas + +program test_lex + type :: dtype + integer :: n + character*5 :: word + end type dtype + + type :: list + type(dtype), dimension(4) :: list + integer :: l = 4 + end type list + + type(list) :: table + type(dtype) :: elist(2,2) + + table%list = (/dtype (1 , "one "), dtype (2 , "two "), dtype (3 , "three"), dtype (4 , "four ")/) + +! Test 1D with assumed shape (original bug) and assumed size. + call bar (table, 2, 4) + if (any (table%list%word.ne.(/"one ","i= 2","three","i= 4"/))) STOP 1 + + elist = reshape (table%list, (/2,2/)) + +! Check 2D is OK with assumed shape and assumed size. + call foo3 (elist%word, 1) + call foo1 (elist%word, 3) + if (any (elist%word.ne.reshape ((/"i= 1","i= 2","i= 3","i= 4"/), (/2,2/)))) STOP 2 + +contains + + subroutine bar (table, n, m) + type(list) :: table + integer n, m + call foo1 (table%list(:table%l)%word, n) + call foo2 (table%list(:table%l)%word, m) + end subroutine bar + + subroutine foo1 (slist, i) + character(*), dimension(*) :: slist + integer i + write (slist(i), '(2hi=,i3)') i + end subroutine foo1 + + subroutine foo2 (slist, i) + character(5), dimension(:) :: slist + integer i + write (slist(i), '(2hi=,i3)') i + end subroutine foo2 + + subroutine foo3 (slist, i) + character(5), dimension(:,:) :: slist + integer i + write (slist(1,1), '(2hi=,i3)') i + end subroutine foo3 + +end program test_lex + diff --git a/Fortran/gfortran/regression/aliasing_dummy_2.f90 b/Fortran/gfortran/regression/aliasing_dummy_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/aliasing_dummy_2.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! This tests the fix for PR28885, in which multiple calls to a procedure +! with different components of an array of derived types for an INTENT(OUT) +! argument caused an ICE internal compiler error. This came about because +! the compiler would lose the temporary declaration with each subsequent +! call of the procedure. +! +! Reduced from the contribution by Drew McCormack +! +program test + type t + integer :: i + integer :: j + end type + type (t) :: a(5) + call sub('one',a%j) + call sub('two',a%i) +contains + subroutine sub(key,a) + integer, intent(out) :: a(:) + character(*),intent(in) :: key + a = 1 + end subroutine +end program diff --git a/Fortran/gfortran/regression/aliasing_dummy_3.f90 b/Fortran/gfortran/regression/aliasing_dummy_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/aliasing_dummy_3.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! This tests the fix for PR29565, which failed in the gimplifier +! with the third call to has_read_key because this lost the first +! temporary array declaration from the current context. +! +! Contributed by William Mitchell +! + type element_t + integer :: gid + end type element_t + + type(element_t) :: element(1) + call hash_read_key(element%gid) + call hash_read_key(element%gid) + call hash_read_key(element%gid) +contains + subroutine hash_read_key(key) + integer, intent(out) :: key(1) + end subroutine hash_read_key +end diff --git a/Fortran/gfortran/regression/aliasing_dummy_4.f90 b/Fortran/gfortran/regression/aliasing_dummy_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/aliasing_dummy_4.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +! This tests the fix for PR29315, in which array components of derived type arrays were +! not correctly passed to procedures because of a fault in the function that detects +! these references that do not have the span of a natural type. +! +! Contributed by Stephen Jeffrey +! +program test_f90 + + integer, parameter :: N = 2 + + type test_type + integer a(N, N) + end type + + type (test_type) s(N, N) + + forall (l = 1:N, m = 1:N) & + s(l, m)%a(:, :) = reshape ([((i*l + 10*j*m +100, i = 1, N), j = 1, N)], [N, N]) + + call test_sub(s%a(1, 1), 1000) ! Test the original problem. + + if ( any (s(1, 1)%a(:, :) /= reshape ([1111, 112, 121, 122], [2, 2]))) STOP 1 + if ( any (s(1, 2)%a(:, :) /= reshape ([1121, 122, 141, 142], [2, 2]))) STOP 2 + if ( any (s(2, 1)%a(:, :) /= reshape ([1112, 114, 122, 124], [2, 2]))) STOP 3 + if ( any (s(2, 2)%a(:, :) /= reshape ([1122, 124, 142, 144], [2, 2]))) STOP 4 + + call test_sub(s(1, 1)%a(:, :), 1000) ! Check "normal" references. + + if ( any (s(1, 1)%a(:, :) /= reshape ([2111,1112,1121,1122], [2, 2]))) STOP 5 + if ( any (s(1, 2)%a(:, :) /= reshape ([1121, 122, 141, 142], [2, 2]))) STOP 6 + if ( any (s(2, 1)%a(:, :) /= reshape ([1112, 114, 122, 124], [2, 2]))) STOP 7 + if ( any (s(2, 2)%a(:, :) /= reshape ([1122, 124, 142, 144], [2, 2]))) STOP 8 +contains + subroutine test_sub(array, offset) + integer array(:, :), offset + + forall (i = 1:N, j = 1:N) & + array(i, j) = array(i, j) + offset + end subroutine +end program + diff --git a/Fortran/gfortran/regression/aliasing_dummy_5.f90 b/Fortran/gfortran/regression/aliasing_dummy_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/aliasing_dummy_5.f90 @@ -0,0 +1,53 @@ +! { dg-do run } +! +! PR fortran/45019 +! +! Check that the compiler knows that +! "arg" and "arr" can alias. +! +MODULE m + IMPLICIT NONE + INTEGER, TARGET :: arr(3) +CONTAINS + SUBROUTINE foobar (arg) + INTEGER, TARGET :: arg(:) + arr(2:3) = arg(1:2) + END SUBROUTINE foobar +END MODULE m + +PROGRAM main + USE m + IMPLICIT NONE + arr = (/ 1, 2, 3 /) + CALL bar(arr) + if (any (arr /= (/ 1, 1, 2 /))) STOP 1 + CALL test() +contains + subroutine bar(x) + INTEGER, TARGET :: x(:) + CALL foobar (x) + end subroutine bar +END PROGRAM main + +MODULE m2 + IMPLICIT NONE + INTEGER, TARGET :: arr(3) +CONTAINS + SUBROUTINE foobar (arg) + INTEGER, TARGET :: arg(:) + arr(1) = 5 + arg(1) = 6 + if (arr(1) == 5) STOP 2 + END SUBROUTINE foobar +END MODULE m2 +subroutine test + USE m2 + IMPLICIT NONE + arr = (/ 1, 2, 3 /) + CALL bar(arr) +contains + subroutine bar(x) + INTEGER, TARGET :: x(:) + CALL foobar (x) + end subroutine bar +END subroutine test diff --git a/Fortran/gfortran/regression/all_bounds_1.f90 b/Fortran/gfortran/regression/all_bounds_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/all_bounds_1.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Incorrect extent in return value of ALL intrinsic" } +program main + logical(kind=4), allocatable :: f(:,:) + logical(kind=4) :: res(3) + character(len=80) line + allocate (f(2,2)) + f = .false. + f(1,1) = .true. + f(2,1) = .true. + res = all(f,dim=1) + write(line,fmt='(80L1)') res +end program main +! { dg-output "Fortran runtime error: Incorrect extent in return value of ALL intrinsic in dimension 1: is 3, should be 2" } + + diff --git a/Fortran/gfortran/regression/alloc_alloc_expr_1.f90 b/Fortran/gfortran/regression/alloc_alloc_expr_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_alloc_expr_1.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +program fc011 +! Tests fix for PR20779 and PR20891. +! Submitted by Walt Brainerd, The Fortran Company +! and by Joost VandeVondele + +! This program violates requirements of 6.3.1 of the F95 standard. + +! An allocate-object, or a subobject of an allocate-object, shall not appear +! in a bound in the same ALLOCATE statement. The stat-variable shall not appear +! in a bound in the same ALLOCATE statement. + +! The stat-variable shall not be allocated within the ALLOCATE statement in which +! it appears; nor shall it depend on the value, bounds, allocation status, or +! association status of any allocate-object or subobject of an allocate-object +! allocated in the same statement. + + integer, pointer :: PTR + integer, allocatable :: ALLOCS(:) + + allocate (PTR, stat=PTR) ! { dg-error "in the same ALLOCATE statement" } + + allocate (ALLOCS(10),stat=ALLOCS(1)) ! { dg-error "in the same ALLOCATE statement" } + + ALLOCATE(PTR,ALLOCS(PTR)) ! { dg-error "same ALLOCATE statement" } + + deallocate(ALLOCS(1)) ! { dg-error "must be ALLOCATABLE or a POINTER" } + + print *, 'This program has four errors', PTR, ALLOC(1) + +end program fc011 diff --git a/Fortran/gfortran/regression/alloc_alloc_expr_2.f90 b/Fortran/gfortran/regression/alloc_alloc_expr_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_alloc_expr_2.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! This tests the fix for PR29343, in which the valid ALLOCATE statement +! below triggered an error following the patch for PR20779 and PR20891. +! +! Contributed by Grigory Zagorodnev +! + Subroutine ReadParameters (Album) + Implicit NONE + + + Type GalleryP + Integer :: NoOfEntries + Character(80), Pointer :: FileName (:) + End Type GalleryP + + + Type(GalleryP), Intent(Out) :: Album + Allocate (Album%FileName (Album%NoOfEntries)) + end diff --git a/Fortran/gfortran/regression/alloc_alloc_expr_3.f90 b/Fortran/gfortran/regression/alloc_alloc_expr_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_alloc_expr_3.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! PR fortran/34714 - ICE on invalid +! Testcase contributed by Martin Reinecke +! + +module foo + type bar + logical, pointer, dimension(:) :: baz + end type +contains + +function func1() + type(bar) func1 + allocate(func1%baz(1)) +end function + +function func2() + type(bar) func2 + allocate(func1%baz(1)) ! { dg-error "is not a variable" } +end function + +end module foo diff --git a/Fortran/gfortran/regression/alloc_comp_assign_1.f90 b/Fortran/gfortran/regression/alloc_comp_assign_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_assign_1.f90 @@ -0,0 +1,57 @@ +! { dg-do run } +! Test assignments of derived type with allocatable components (PR 20541). +! +! Contributed by Erik Edelmann +! and Paul Thomas +! + type :: ivs + character(1), allocatable :: chars(:) + end type ivs + + type(ivs) :: a, b + type(ivs) :: x(3), y(3) + + allocate(a%chars(5)) + a%chars = (/"h","e","l","l","o"/) + +! An intrinsic assignment must deallocate the l-value and copy across +! the array from the r-value. + b = a + if (any (b%chars .ne. (/"h","e","l","l","o"/))) STOP 1 + if (allocated (a%chars) .eqv. .false.) STOP 2 + +! Scalar to array needs to copy the derived type, to its ultimate components, +! to each of the l-value elements. */ + x = b + x(2)%chars = (/"g","'","d","a","y"/) + if (any (x(1)%chars .ne. (/"h","e","l","l","o"/))) STOP 3 + if (any (x(2)%chars .ne. (/"g","'","d","a","y"/))) STOP 4 + if (allocated (b%chars) .eqv. .false.) STOP 5 + deallocate (x(1)%chars, x(2)%chars, x(3)%chars) + +! Array intrinsic assignments are like their scalar counterpart and +! must deallocate each element of the l-value and copy across the +! arrays from the r-value elements. + allocate(x(1)%chars(5), x(2)%chars(5), x(3)%chars(5)) + x(1)%chars = (/"h","e","l","l","o"/) + x(2)%chars = (/"g","'","d","a","y"/) + x(3)%chars = (/"g","o","d","a","g"/) + y(2:1:-1) = x(1:2) + if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) STOP 6 + if (any (y(2)%chars .ne. (/"h","e","l","l","o"/))) STOP 7 + if (any (x(3)%chars .ne. (/"g","o","d","a","g"/))) STOP 8 + +! In the case of an assignment where there is a dependency, so that a +! temporary is necessary, each element must be copied to its +! destination after it has been deallocated. + y(2:3) = y(1:2) + if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) STOP 9 + if (any (y(2)%chars .ne. (/"g","'","d","a","y"/))) STOP 10 + if (any (y(3)%chars .ne. (/"h","e","l","l","o"/))) STOP 11 + +! An identity assignment must not do any deallocation....! + y = y + if (any (y(1)%chars .ne. (/"g","'","d","a","y"/))) STOP 12 + if (any (y(2)%chars .ne. (/"g","'","d","a","y"/))) STOP 13 + if (any (y(3)%chars .ne. (/"h","e","l","l","o"/))) STOP 14 +end diff --git a/Fortran/gfortran/regression/alloc_comp_assign_10.f90 b/Fortran/gfortran/regression/alloc_comp_assign_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_assign_10.f90 @@ -0,0 +1,59 @@ +! { dg-do run } +! +! Test the fix for PR39879, in which gfc gagged on the double +! defined assignment where the rhs had a default initialiser. +! +! Contributed by David Sagan +! +module test_struct + interface assignment (=) + module procedure tao_lat_equal_tao_lat + end interface + type bunch_params_struct + integer n_live_particle + end type + type tao_lattice_struct + type (bunch_params_struct), allocatable :: bunch_params(:) + type (bunch_params_struct), allocatable :: bunch_params2(:) + end type + type tao_universe_struct + type (tao_lattice_struct), pointer :: model, design + character(200), pointer :: descrip => NULL() + end type + type tao_super_universe_struct + type (tao_universe_struct), allocatable :: u(:) + end type + type (tao_super_universe_struct), save, target :: s + contains + subroutine tao_lat_equal_tao_lat (lat1, lat2) + implicit none + type (tao_lattice_struct), intent(inout) :: lat1 + type (tao_lattice_struct), intent(in) :: lat2 + if (allocated(lat2%bunch_params)) then + lat1%bunch_params = lat2%bunch_params + end if + if (allocated(lat2%bunch_params2)) then + lat1%bunch_params2 = lat2%bunch_params2 + end if + end subroutine +end module + +program tao_program + use test_struct + implicit none + type (tao_universe_struct), pointer :: u + integer n, i + allocate (s%u(1)) + u => s%u(1) + allocate (u%design, u%model) + n = 112 + allocate (u%model%bunch_params(0:n), u%design%bunch_params(0:n)) + u%design%bunch_params%n_live_particle = [(i, i = 0, n)] + u%model = u%design + u%model = u%design ! The double assignment was the cause of the ICE + if (.not. allocated (u%model%bunch_params)) STOP 1 + if (any (u%model%bunch_params%n_live_particle .ne. [(i, i = 0, n)])) STOP 2 + Deallocate (u%model%bunch_params, u%design%bunch_params) + deallocate (u%design, u%model) + deallocate (s%u) +end program diff --git a/Fortran/gfortran/regression/alloc_comp_assign_11.f90 b/Fortran/gfortran/regression/alloc_comp_assign_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_assign_11.f90 @@ -0,0 +1,41 @@ +! { dg-do run } +! +! PR fortran/49324 +! +! Check that with array constructors a deep copy is done +! +implicit none +type t + integer, allocatable :: A(:) +end type t + +type(t) :: x, y +type(t), allocatable :: z(:), z2(:) + +allocate (x%A(2)) +allocate (y%A(1)) +x%A(:) = 11 +y%A(:) = 22 + +allocate (z(2)) + +z = [ x, y ] +!print *, z(1)%a, z(2)%a, x%A, y%A +if (any (z(1)%a /= 11) .or. z(2)%a(1) /= 22 .or. any (x%A /= 11) & + .or. y%A(1) /= 22) & + STOP 1 + +x%A(:) = 444 +y%A(:) = 555 + +!print *, z(1)%a, z(2)%a, x%A, y%A +if (any (z(1)%a /= 11) .or. z(2)%a(1) /= 22 .or. any (x%A /= 444) & + .or. y%A(1) /= 555) & + STOP 2 + +z(:) = [ x, y ] +!print *, z(1)%a, z(2)%a, x%A, y%A +if (any (z(1)%a /= 444) .or. z(2)%a(1) /= 555 .or. any (x%A /= 444) & + .or. y%A(1) /= 555) & + STOP 3 +end diff --git a/Fortran/gfortran/regression/alloc_comp_assign_12.f03 b/Fortran/gfortran/regression/alloc_comp_assign_12.f03 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_assign_12.f03 @@ -0,0 +1,42 @@ +! { dg-do run } +! PR48351 - automatic (re)allocation of allocatable components of class objects +! +! Contributed by Nasser M. Abbasi on comp.lang.fortran +! +module foo + implicit none + type :: foo_t + private + real, allocatable :: u(:) + contains + procedure :: make + procedure :: disp + end type foo_t +contains + subroutine make(this,u) + implicit none + class(foo_t) :: this + real, intent(in) :: u(:) + this%u = u(int (u)) ! The failure to allocate occurred here. + if (.not.allocated (this%u)) STOP 1 + end subroutine make + function disp(this) + implicit none + class(foo_t) :: this + real, allocatable :: disp (:) + if (allocated (this%u)) disp = this%u + end function +end module foo + +program main2 + use foo + implicit none + type(foo_t) :: o + real, allocatable :: u(:) + u=real ([3,2,1,4]) + call o%make(u) + if (any (int (o%disp()) .ne. [1,2,3,4])) STOP 2 + u=real ([2,1]) + call o%make(u) + if (any (int (o%disp()) .ne. [1,2])) STOP 3 +end program main2 diff --git a/Fortran/gfortran/regression/alloc_comp_assign_13.f08 b/Fortran/gfortran/regression/alloc_comp_assign_13.f08 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_assign_13.f08 @@ -0,0 +1,43 @@ +! { dg-do run } +! Test for allocatable scalar components and deferred length char arrays. +! Check that fix for pr60357 works. +! Contributed by Antony Lewis and +! Andre Vehreschild +! +program test_allocatable_components + Type A + integer :: X + integer, allocatable :: y + character(len=:), allocatable :: c + end type A + Type(A) :: Me + Type(A) :: Ea + + Me= A(X= 1, Y= 2, C="correctly allocated") + + if (Me%X /= 1) STOP 1 + if (.not. allocated(Me%y) .or. Me%y /= 2) STOP 2 + if (.not. allocated(Me%c)) STOP 3 + if (len(Me%c) /= 19) STOP 4 + if (Me%c /= "correctly allocated") STOP 5 + + ! Now check explicitly allocated components. + Ea%X = 9 + allocate(Ea%y) + Ea%y = 42 + ! Implicit allocate on assign in the next line + Ea%c = "13 characters" + + if (Ea%X /= 9) STOP 6 + if (.not. allocated(Ea%y) .or. Ea%y /= 42) STOP 7 + if (.not. allocated(Ea%c)) STOP 8 + if (len(Ea%c) /= 13) STOP 9 + if (Ea%c /= "13 characters") STOP 10 + + deallocate(Ea%y) + deallocate(Ea%c) + if (allocated(Ea%y)) STOP 11 + if (allocated(Ea%c)) STOP 12 +end program + +! vim:ts=4:sts=4:sw=4: diff --git a/Fortran/gfortran/regression/alloc_comp_assign_14.f08 b/Fortran/gfortran/regression/alloc_comp_assign_14.f08 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_assign_14.f08 @@ -0,0 +1,46 @@ +! { dg-do run } +! Test for allocatable scalar components and deferred length char arrays. +! Check that fix for pr61275 works. +! Contributed by Antony Lewis and +! Andre Vehreschild +! +module typeA + Type A + integer :: X + integer, allocatable :: y + character(len=:), allocatable :: c + end type A +end module + +program test_allocatable_components + use typeA + Type(A) :: Me + Type(A) :: Ea + + Me= A(X= 1, Y= 2, C="correctly allocated") + + if (Me%X /= 1) STOP 1 + if (.not. allocated(Me%y) .or. Me%y /= 2) STOP 2 + if (.not. allocated(Me%c)) STOP 3 + if (len(Me%c) /= 19) STOP 4 + if (Me%c /= "correctly allocated") STOP 5 + + ! Now check explicitly allocated components. + Ea%X = 9 + allocate(Ea%y) + Ea%y = 42 + ! Implicit allocate on assign in the next line + Ea%c = "13 characters" + + if (Ea%X /= 9) STOP 6 + if (.not. allocated(Ea%y) .or. Ea%y /= 42) STOP 7 + if (.not. allocated(Ea%c)) STOP 8 + if (len(Ea%c) /= 13) STOP 9 + if (Ea%c /= "13 characters") STOP 10 + + deallocate(Ea%y) + deallocate(Ea%c) + if (allocated(Ea%y)) STOP 11 + if (allocated(Ea%c)) STOP 12 +end program + diff --git a/Fortran/gfortran/regression/alloc_comp_assign_15.f03 b/Fortran/gfortran/regression/alloc_comp_assign_15.f03 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_assign_15.f03 @@ -0,0 +1,32 @@ +! { dg-do run } +! +! Check the test for PR69422, in which the allocatable component 'Source' +! of the pointer component 'P' was not automatically (re)allocated on +! assignment. +! +! Contributed by Anthony Lewis +! +module funcs + implicit none + + Type T + character(LEN=:), allocatable :: source + end type T + + type TPointer + Type(T), pointer :: P + end type TPointer + +end module + +program Test1 + use funcs + Type(TPointer) :: X + + allocate(X%P) + + X%P%Source = 'test string' + if (.not.allocated (X%P%Source)) STOP 1 + if (X%P%Source .ne. 'test string') STOP 2 + +end program Test1 diff --git a/Fortran/gfortran/regression/alloc_comp_assign_16.f03 b/Fortran/gfortran/regression/alloc_comp_assign_16.f03 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_assign_16.f03 @@ -0,0 +1,37 @@ +! { dg-do run } +! +! Test the fix for PR88393 in which a segfault occurred as indicated. +! +! Contributed by Janus Weil +! +module m + implicit none + type :: t + character(len=:), allocatable :: cs + contains + procedure :: ass + generic :: assignment(=) => ass + end type +contains + subroutine ass(a, b) + class(t), intent(inout) :: a + class(t), intent(in) :: b + a%cs = b%cs + print *, "ass" + end subroutine +end module + +program p + use m + implicit none + type :: t2 + type(t) :: c + end type + type(t2), dimension(1:2) :: arr + arr(1)%c%cs = "abcd" + arr(2)%c = arr(1)%c ! Segfault here. + print *, "done", arr(2)%c%cs, arr(2)%c%cs +! Make sure with valgrind that there are no memory leaks. + deallocate (arr(1)%c%cs) + deallocate (arr(2)%c%cs) +end diff --git a/Fortran/gfortran/regression/alloc_comp_assign_2.f90 b/Fortran/gfortran/regression/alloc_comp_assign_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_assign_2.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! Test FORALL and WHERE with derived types with allocatable components (PR 20541). +! +! Contributed by Erik Edelmann +! and Paul Thomas +! + type :: a + integer, allocatable :: i(:) + end type a + + type :: b + type (a), allocatable :: at(:) + end type b + + type(a) :: x(2) + type(b) :: y(2), z(2) + integer i, m(4) + +! Start with scalar and array element assignments in FORALL. + + x(1) = a ((/1, 2, 3, 4/)) + x(2) = a ((/1, 2, 3, 4/) + 10) + forall (j = 1:2, i = 1:4, x(j)%i(i) > 2 + (j-1)*10) x(j)%i(i) = j*4-i + if (any ((/((x(i)%i(j), j = 1,4), i = 1,2)/) .ne. & + (/1, 2, 1, 0, 11, 12, 5, 4/))) STOP 1 + + y(1) = b ((/x(1),x(2)/)) + y(2) = b ((/x(2),x(1)/)) + forall (k = 1:2, j=1:2, i = 1:4, y(k)%at(j)%i(i) <= 10) + y(k)%at(j)%i(i) = j*4-i+k + end forall + if (any ((/(((y(k)%at(i)%i(j), j = 1,4), i = 1,2), k = 1,2)/) .ne. & + (/4,3,2,1,11,12,6,5,11,12,3,2,9,8,7,6/))) STOP 2 + +! Now simple assignments in WHERE. + + where (y(1)%at(1)%i > 2) y(1)%at(1)%i = 0 + if (any( (/(((y(k)%at(i)%i(j), j = 1,4), i = 1,2), k = 1,2)/) .ne. & + (/0,0,2,1,11,12,6,5,11,12,3,2,9,8,7,6/))) STOP 3 + +! Check that temporaries and full array alloctable component assignments +! are correctly handled in FORALL. + + x = (/a ((/1,2,3,4/)),a ((/5,6,7,8/))/) + forall (i=1:2) y(i) = b ((/x(i)/)) + forall (i=1:2) y(i) = y(3-i) ! This needs a temporary. + forall (i=1:2) z(i) = y(i) + if (any ((/(((z(k)%at(i)%i(j), j = 1,4), i = 1,1), k = 1,2)/) .ne. & + (/(/5,6,7,8/),(/1,2,3,4/)/))) STOP 4 + +end diff --git a/Fortran/gfortran/regression/alloc_comp_assign_3.f90 b/Fortran/gfortran/regression/alloc_comp_assign_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_assign_3.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! Test assignments of nested derived types with allocatable components(PR 20541). +! +! Contributed by Erik Edelmann +! and Paul Thomas +! + type :: a + integer, allocatable :: i(:) + end type a + + type :: b + type (a), allocatable :: at(:) + end type b + + type(a) :: x(2) + type(b) :: y(2), z(2) + integer i, m(4) + + x(1) = a((/1,2,3,4/)) + x(2) = a((/1,2,3,4/)+10) + + y(1) = b((/x(1),x(2)/)) + y(2) = b((/x(2),x(1)/)) + + y(2) = y(1) + forall (j=1:2,k=1:4, y(1)%at(j)%i(k) .ne. y(2)%at(j)%i(k)) & + y(1)%at(j)%i(k) = 999 + if (any ((/((y(1)%at(j)%i(k), k=1,4),j=1,2)/) .eq. 999)) STOP 1 + + + z = y + forall (i=1:2,j=1:2,k=1:4, z(i)%at(j)%i(k) .ne. y(i)%at(j)%i(k)) & + z(i)%at(j)%i(k) = 999 + if (any ((/(((z(i)%at(j)%i(k), k=1,4),j=1,2),i=1,2)/) .eq. 999)) STOP 2 + +end diff --git a/Fortran/gfortran/regression/alloc_comp_assign_4.f90 b/Fortran/gfortran/regression/alloc_comp_assign_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_assign_4.f90 @@ -0,0 +1,63 @@ +! { dg-do run } +! Test assignments of nested derived types with character allocatable +! components(PR 20541). Subroutine test_ab6 checks out a bug in a test +! version of gfortran's allocatable arrays. +! +! Contributed by Erik Edelmann +! and Paul Thomas +! + type :: a + character(4), allocatable :: ch(:) + end type a + + type :: b + type (a), allocatable :: at(:) + end type b + + type(a) :: x(2) + type(b) :: y(2), z(2) + + character(4) :: chr1(4) = (/"abcd","efgh","ijkl","mnop"/) + character(4) :: chr2(4) = (/"qrst","uvwx","yz12","3456"/) + + x(1) = a(chr1) + + ! Check constructor with character array constructors. + x(2) = a((/"qrst","uvwx","yz12","3456"/)) + + y(1) = b((/x(1),x(2)/)) + y(2) = b((/x(2),x(1)/)) + + y(2) = y(1) + + if (any((/((y(2)%at(i)%ch(j),j=1,4),i=1,2)/) .ne. & + (/chr1, chr2/))) STOP 1 + + call test_ab6 () + +contains + + subroutine test_ab6 () +! This subroutine tests the presence of a scalar derived type, intermediate +! in a chain of derived types with allocatable components. +! Contributed by Salvatore Filippone + + type b + type(a) :: a + end type b + + type c + type(b), allocatable :: b(:) + end type c + + type(c) :: p + type(b) :: bv + + p = c((/b(a((/"Mary","Lamb"/)))/)) + bv = p%b(1) + + if (any ((bv%a%ch(:)) .ne. (/"Mary","Lamb"/))) STOP 2 + +end subroutine test_ab6 + +end diff --git a/Fortran/gfortran/regression/alloc_comp_assign_5.f90 b/Fortran/gfortran/regression/alloc_comp_assign_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_assign_5.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! { dg-options "-O2" } +! Tests the fix for PR29428, in which the assignment of +! a function result would result in the function being +! called twice, if it were not a result by reference, +! because of a spurious nullify in gfc_trans_scalar_assign. +! +! Contributed by Paul Thomas +! +program test +implicit none + + type A + integer, allocatable :: j(:) + end type A + + type(A):: x + integer :: ctr = 0 + + x = f() + + if (ctr /= 1) STOP 1 + +contains + + function f() + type(A):: f + ctr = ctr + 1 + f = A ((/1,2/)) + end function f + +end program + diff --git a/Fortran/gfortran/regression/alloc_comp_assign_6.f90 b/Fortran/gfortran/regression/alloc_comp_assign_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_assign_6.f90 @@ -0,0 +1,53 @@ +! { dg-do run } +! Tests the fix for pr32880, in which 'res' was deallocated +! before it could be used in the concatenation. +! Adapted from vst28.f95, in Lawrie Schonfeld's iso_varying_string +! testsuite, by Tobias Burnus. +! +module iso_varying_string + type varying_string + character(LEN=1), dimension(:), allocatable :: chars + end type varying_string + interface assignment(=) + module procedure op_assign_VS_CH + end interface assignment(=) + interface operator(//) + module procedure op_concat_VS_CH + end interface operator(//) +contains + elemental subroutine op_assign_VS_CH (var, exp) + type(varying_string), intent(out) :: var + character(LEN=*), intent(in) :: exp + integer :: length + integer :: i_char + length = len(exp) + allocate(var%chars(length)) + forall(i_char = 1:length) + var%chars(i_char) = exp(i_char:i_char) + end forall + end subroutine op_assign_VS_CH + elemental function op_concat_VS_CH (string_a, string_b) result (concat_string) + type(varying_string), intent(in) :: string_a + character(LEN=*), intent(in) :: string_b + type(varying_string) :: concat_string + len_string_a = size(string_a%chars) + allocate(concat_string%chars(len_string_a+len(string_b))) + if (len_string_a >0) & + concat_string%chars(:len_string_a) = string_a%chars + if (len (string_b) > 0) & + concat_string%chars(len_string_a+1:) = string_b + end function op_concat_VS_CH +end module iso_varying_string + +program VST28 + use iso_varying_string + character(len=10) :: char_a + type(VARYING_STRING) :: res + char_a = "abcdefghij" + res = char_a(5:5) + res = res//char_a(6:6) + if(size(res%chars) /= 2 .or. any(res%chars /= ['e','f'])) then + write(*,*) 'ERROR: should be ef, got: ', res%chars, size(res%chars) + STOP 1 + end if +end program VST28 diff --git a/Fortran/gfortran/regression/alloc_comp_assign_7.f90 b/Fortran/gfortran/regression/alloc_comp_assign_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_assign_7.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! +! Test the fix for PR37735, in which gfc gagged in the assignement to +! 'p'. The array component 'r' caused an ICE. +! +! Contributed by Steven Winfield +! +module PrettyPix_module + implicit none + type Spline + real, allocatable, dimension(:) ::y2 + end type Spline + type Path + type(Spline) :: r(3) + end type Path + type Scene + type(path) :: look_at_path + end type Scene +contains + subroutine scene_set_look_at_path(this,p) + type(scene), intent(inout) :: this + type(path), intent(in) :: p + this%look_at_path = p + end subroutine scene_set_look_at_path +end module PrettyPix_module + + use PrettyPix_module + implicit none + integer :: i + real :: x(3) = [1.0, 2.0, 3.0] + type(scene) :: this + type(path) :: p + p = path ([spline([x(1)]),spline([x(2)]),spline([x(3)])]) + call scene_set_look_at_path(this,p) + do i = 1, 3 + if (this%look_at_path%r(i)%y2(1) .ne. x(i)) STOP 1 + end do +end diff --git a/Fortran/gfortran/regression/alloc_comp_assign_8.f90 b/Fortran/gfortran/regression/alloc_comp_assign_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_assign_8.f90 @@ -0,0 +1,48 @@ +! { dg-do run } +! +! Test the fix for PR35824, in which the interface assignment and +! negation did not work correctly. +! +! Contributed by Rolf Roth +! +module typemodule + type alltype + double precision :: a + double precision,allocatable :: b(:) + end type + interface assignment(=) + module procedure at_from_at + end interface + interface operator(-) + module procedure neg_at + end interface +contains + subroutine at_from_at(b,a) + type(alltype), intent(in) :: a + type(alltype), intent(out) :: b + b%a=a%a + allocate(b%b(2)) + b%b=a%b + end subroutine at_from_at + function neg_at(a) result(b) + type(alltype), intent(in) :: a + type(alltype) :: b + b%a=-a%a + allocate(b%b(2)) + b%b=-a%b + end function neg_at +end module + use typemodule + type(alltype) t1,t2,t3 + allocate(t1%b(2)) + t1%a=0.5d0 + t1%b(1)=1d0 + t1%b(2)=2d0 + t2=-t1 + if (t2%a .ne. -0.5d0) STOP 1 + if (any(t2%b .ne. [-1d0, -2d0])) STOP 2 + + t1=-t1 + if (t1%a .ne. -0.5d0) STOP 3 + if (any(t1%b .ne. [-1d0, -2d0])) STOP 4 +end diff --git a/Fortran/gfortran/regression/alloc_comp_assign_9.f90 b/Fortran/gfortran/regression/alloc_comp_assign_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_assign_9.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! Test the fix for PR39519, where the presence of the pointer +! as the first component was preventing the second from passing +! the "alloc_comp" attribute to the derived type. +! +! Contributed by Gilbert Scott +! +PROGRAM X + TYPE T + INTEGER, POINTER :: P + INTEGER, ALLOCATABLE :: A(:) + END TYPE T + TYPE(T) :: T1,T2 + ALLOCATE ( T1%A(1) ) + ALLOCATE ( T2%A(1) ) + T1%A = 23 + T2 = T1 + T1%A = 42 + if (T2%A(1) .NE. 23) STOP 1 +END PROGRAM X diff --git a/Fortran/gfortran/regression/alloc_comp_auto_array_1.f90 b/Fortran/gfortran/regression/alloc_comp_auto_array_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_auto_array_1.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +! Fix for PR29699 - see below for details. +! +! Contributed by Tobias Burnus +! +PROGRAM vocabulary_word_count + + IMPLICIT NONE + TYPE VARYING_STRING + CHARACTER,DIMENSION(:),ALLOCATABLE :: chars + ENDTYPE VARYING_STRING + + INTEGER :: list_size=200 + + call extend_lists2 + +CONTAINS + +! First the original problem: vocab_swap not being referenced caused +! an ICE because default initialization is used, which results in a +! call to gfc_conv_variable, which calls gfc_get_symbol_decl. + + SUBROUTINE extend_lists1 + type(VARYING_STRING),DIMENSION(list_size) :: vocab_swap + ENDSUBROUTINE extend_lists1 + +! Curing this then uncovered two more problems: If vocab_swap were +! actually referenced, an ICE occurred in the gimplifier because +! the declaration for this automatic array is presented as a +! pointer to the array, rather than the array. Curing this allows +! the code to compile but it bombed out at run time because the +! malloc/free occurred in the wrong order with respect to the +! nullify/deallocate of the allocatable components. + + SUBROUTINE extend_lists2 + type(VARYING_STRING),DIMENSION(list_size) :: vocab_swap + allocate (vocab_swap(1)%chars(10)) + if (.not.allocated(vocab_swap(1)%chars)) STOP 1 + if (allocated(vocab_swap(10)%chars)) STOP 2 + ENDSUBROUTINE extend_lists2 + +ENDPROGRAM vocabulary_word_count diff --git a/Fortran/gfortran/regression/alloc_comp_auto_array_2.f90 b/Fortran/gfortran/regression/alloc_comp_auto_array_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_auto_array_2.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! Tests the fix for PR34820, in which the nullification of the +! automatic array iregion occurred in the caller, rather than the +! callee. Since 'nproc' was not available, an ICE ensued. During +! the bug fix, it was found that the scalar to array assignment +! of derived types with allocatable components did not work and +! the fix of this is tested too. +! +! Contributed by Toon Moene +! +module grid_io + type grid_index_region + integer, allocatable::lons(:) + end type grid_index_region +contains + subroutine read_grid_header() + integer :: npiece = 1 + type(grid_index_region),allocatable :: iregion(:) + allocate (iregion(npiece + 1)) + call read_iregion(npiece,iregion) + if (size(iregion) .ne. npiece + 1) STOP 1 + if (.not.allocated (iregion(npiece)%lons)) STOP 2 + if (allocated (iregion(npiece+1)%lons)) STOP 3 + if (any (iregion(npiece)%lons .ne. [(i, i = 1, npiece)])) STOP 4 + deallocate (iregion) + end subroutine read_grid_header + + subroutine read_iregion (nproc,iregion) + integer,intent(in)::nproc + type(grid_index_region), intent(OUT)::iregion(1:nproc) + integer :: iarg(nproc) + iarg = [(i, i = 1, nproc)] + iregion = grid_index_region (iarg) ! + end subroutine read_iregion +end module grid_io + + use grid_io + call read_grid_header +end diff --git a/Fortran/gfortran/regression/alloc_comp_auto_array_3.f90 b/Fortran/gfortran/regression/alloc_comp_auto_array_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_auto_array_3.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! { dg-options "-O0 -fdump-tree-original" } +! +! Test the fix for PR66082. The original problem was with the first +! call foo_1d. +! +! Reported by Damian Rouson +! + type foo_t + real, allocatable :: bigarr + end type + block + type(foo_t) :: foo + allocate(foo%bigarr) + call foo_1d (1,[foo]) ! wasy lost + call foo_1d (1,bar_1d()) ! Check that this is OK + end block +contains + subroutine foo_1d (n,foo) + integer n + type(foo_t) :: foo(n) + end subroutine + function bar_1d () result (array) + type(foo_t) :: array(1) + allocate (array(1)%bigarr) + end function +end +! { dg-final { scan-tree-dump-times "builtin_malloc" 3 "original" } } +! { dg-final { scan-tree-dump-times "builtin_free" 3 "original" } } +! { dg-final { scan-tree-dump-times "while \\(1\\)" 4 "original" } } diff --git a/Fortran/gfortran/regression/alloc_comp_basics_1.f90 b/Fortran/gfortran/regression/alloc_comp_basics_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_basics_1.f90 @@ -0,0 +1,144 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! Check some basic functionality of allocatable components, including that they +! are nullified when created and automatically deallocated when +! 1. A variable goes out of scope +! 2. INTENT(OUT) dummies +! 3. Function results +! +! +! Contributed by Erik Edelmann +! and Paul Thomas +! +module alloc_m + + implicit none + + type :: alloc1 + real, allocatable :: x(:) + end type alloc1 + +end module alloc_m + + +program alloc + + use alloc_m + + implicit none + + type :: alloc2 + type(alloc1), allocatable :: a1(:) + integer, allocatable :: a2(:) + end type alloc2 + + integer :: i + + BLOCK ! To ensure that the allocatables are freed at the end of the scope + type(alloc2) :: b + type(alloc2), allocatable :: c(:) + + if (allocated(b%a2) .OR. allocated(b%a1)) then + write (0, *) 'main - 1' + STOP 1 + end if + + ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy) + call allocate_alloc2(b) + call check_alloc2(b) + + do i = 1, size(b%a1) + ! 1 call to _gfortran_deallocate + deallocate(b%a1(i)%x) + end do + + ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy) + call allocate_alloc2(b) + + call check_alloc2(return_alloc2()) + ! 3 calls to _gfortran_deallocate (function result) + + allocate(c(1)) + ! 3 calls to _gfortran_deallocate (INTENT(OUT) dummy) + call allocate_alloc2(c(1)) + ! 4 calls to _gfortran_deallocate + deallocate(c) + + ! 7 calls to _gfortran_deallocate (b (3) and c(4) goes aout of scope) + END BLOCK +contains + + subroutine allocate_alloc2(b) + type(alloc2), intent(out) :: b + integer :: i + + if (allocated(b%a2) .OR. allocated(b%a1)) then + write (0, *) 'allocate_alloc2 - 1' + STOP 2 + end if + + allocate (b%a2(3)) + b%a2 = [ 1, 2, 3 ] + + allocate (b%a1(3)) + + do i = 1, 3 + if (allocated(b%a1(i)%x)) then + write (0, *) 'allocate_alloc2 - 2', i + STOP 3 + end if + allocate (b%a1(i)%x(3)) + b%a1(i)%x = i + [ 1.0, 2.0, 3.0 ] + end do + + end subroutine allocate_alloc2 + + + type(alloc2) function return_alloc2() result(b) + if (allocated(b%a2) .OR. allocated(b%a1)) then + write (0, *) 'return_alloc2 - 1' + STOP 4 + end if + + allocate (b%a2(3)) + b%a2 = [ 1, 2, 3 ] + + allocate (b%a1(3)) + + do i = 1, 3 + if (allocated(b%a1(i)%x)) then + write (0, *) 'return_alloc2 - 2', i + STOP 5 + end if + allocate (b%a1(i)%x(3)) + b%a1(i)%x = i + [ 1.0, 2.0, 3.0 ] + end do + end function return_alloc2 + + + subroutine check_alloc2(b) + type(alloc2), intent(in) :: b + + if (.NOT.(allocated(b%a2) .AND. allocated(b%a1))) then + write (0, *) 'check_alloc2 - 1' + STOP 6 + end if + if (any(b%a2 /= [ 1, 2, 3 ])) then + write (0, *) 'check_alloc2 - 2' + STOP 7 + end if + do i = 1, 3 + if (.NOT.allocated(b%a1(i)%x)) then + write (0, *) 'check_alloc2 - 3', i + STOP 8 + end if + if (any(b%a1(i)%x /= i + [ 1.0, 2.0, 3.0 ])) then + write (0, *) 'check_alloc2 - 4', i + STOP 9 + end if + end do + end subroutine check_alloc2 + +end program alloc +! { dg-final { scan-tree-dump-times "builtin_free" 21 "original" } } diff --git a/Fortran/gfortran/regression/alloc_comp_basics_2.f90 b/Fortran/gfortran/regression/alloc_comp_basics_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_basics_2.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! Check "double" allocations of allocatable components (PR 20541). +! +! Contributed by Erik Edelmann +! and Paul Thomas +! +program main + + implicit none + + type foo + integer, dimension(:), allocatable :: array + end type foo + + type(foo),allocatable,dimension(:) :: mol + type(foo),pointer,dimension(:) :: molp + integer :: i + + allocate (mol(1)) + allocate (mol(1), stat=i) + !print *, i ! /= 0 + if (i == 0) STOP 1 + + allocate (mol(1)%array(5)) + allocate (mol(1)%array(5),stat=i) + !print *, i ! /= 0 + if (i == 0) STOP 2 + + allocate (molp(1)) + allocate (molp(1), stat=i) + !print *, i ! == 0 + if (i /= 0) STOP 3 + + allocate (molp(1)%array(5)) + allocate (molp(1)%array(5),stat=i) + !print *, i ! /= 0 + if (i == 0) STOP 4 + +end program main diff --git a/Fortran/gfortran/regression/alloc_comp_basics_3.f90 b/Fortran/gfortran/regression/alloc_comp_basics_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_basics_3.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! Test the patch for PR30202 in which the INTENT(OUT) +! caused an ICE. +! +! Contributed by Salvatore Filippone +! +program class_scal_p + implicit none + type scal_p + real, allocatable :: b(:) + end type scal_p + type(scal_p) :: pd + call psb_geallv(pd%b) +contains + subroutine psb_geallv(x) + real, allocatable, intent(out) :: x(:) + end subroutine psb_geallv +end program class_scal_p diff --git a/Fortran/gfortran/regression/alloc_comp_basics_4.f90 b/Fortran/gfortran/regression/alloc_comp_basics_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_basics_4.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! Tests the fix for PR30660 in which gfortran insisted that g_dest +! should have the SAVE attribute because the hidden default +! initializer for the allocatable component was being detected. +! +! Contributed by Toon Moene +! +MODULE types_m + TYPE coord_t + INTEGER ncord + REAL,ALLOCATABLE,DIMENSION(:) :: x, y + END TYPE + + TYPE grib_t + REAL,DIMENSION(:),ALLOCATABLE :: vdata + TYPE(coord_t) coords + END TYPE +END MODULE + +MODULE globals_m + USE types_m + TYPE(grib_t) g_dest ! output field +END MODULE diff --git a/Fortran/gfortran/regression/alloc_comp_basics_5.f90 b/Fortran/gfortran/regression/alloc_comp_basics_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_basics_5.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! This checks the correct functioning of derived types with the SAVE +! attribute and allocatable components - PR31163 +! +! Contributed by Salvatore Filippone +! +Module bar_mod + + type foo_type + integer, allocatable :: mv(:) + end type foo_type + + +contains + + + subroutine bar_foo_ab(info) + + integer, intent(out) :: info + Type(foo_type), save :: f_a + + if (allocated(f_a%mv)) then + info = size(f_a%mv) + else + allocate(f_a%mv(10),stat=info) + if (info /= 0) then + info = -1 + endif + end if + end subroutine bar_foo_ab + + +end module bar_mod + +program tsave + use bar_mod + + integer :: info + + call bar_foo_ab(info) + if (info .ne. 0) STOP 1 + call bar_foo_ab(info) + if (info .ne. 10) STOP 2 + +end program tsave diff --git a/Fortran/gfortran/regression/alloc_comp_basics_6.f90 b/Fortran/gfortran/regression/alloc_comp_basics_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_basics_6.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! +! PR 58026: Bad error recovery for allocatable component of undeclared type +! +! Contributed by Joost VandeVondele + + type sysmtx_t + type(ext_complex_t), allocatable :: S(:) ! { dg-error "has not been declared" } + class(some_type), allocatable :: X ! { dg-error "has not been declared" } + end type + +end diff --git a/Fortran/gfortran/regression/alloc_comp_basics_7.f90 b/Fortran/gfortran/regression/alloc_comp_basics_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_basics_7.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! PR 86888: [F08] allocatable components of indirectly recursive type +! +! Contributed by Janus Weil + +type :: s + type(t), allocatable :: x +end type + +type :: t + type(s), allocatable :: y +end type + +end diff --git a/Fortran/gfortran/regression/alloc_comp_bounds_1.f90 b/Fortran/gfortran/regression/alloc_comp_bounds_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_bounds_1.f90 @@ -0,0 +1,50 @@ +! { dg-do run } +! Test the fix for PR38324, in which the bounds were not set correctly for +! constructor assignments with allocatable components. +! +! Contributed by Dominique d'Humieres +! + integer, parameter :: ik4 = 4 + integer, parameter :: ik8 = 8 + integer, parameter :: from = -1, to = 2 + call foo + call bar +contains + subroutine foo + type :: struct + integer(4), allocatable :: ib(:) + end type struct + integer(ik4), allocatable :: ia(:) + type(struct) :: x + allocate(ia(from:to)) + if (any(lbound(ia) .ne. -1) .or. any(ubound(ia) .ne. 2)) STOP 1 + if (any(lbound(ia(:)) .ne. 1) .or. any(ubound(ia(:)) .ne. 4)) STOP 2 + if (any(lbound(ia(from:to)) .ne. 1) .or. any(ubound(ia(from:to)) .ne. 4)) STOP 3 + x=struct(ia) + if (any(lbound(x%ib) .ne. -1) .or. any(ubound(x%ib) .ne. 2)) STOP 4 + x=struct(ia(:)) + if (any(lbound(x%ib) .ne. 1) .or. any(ubound(x%ib) .ne. 4)) STOP 5 + x=struct(ia(from:to)) + if (any(lbound(x%ib) .ne. 1) .or. any(ubound(x%ib) .ne. 4)) STOP 6 + deallocate(ia) + end subroutine + subroutine bar + type :: struct + integer(4), allocatable :: ib(:) + end type struct + integer(ik8), allocatable :: ia(:) + type(struct) :: x + allocate(ia(from:to)) + if (any(lbound(ia) .ne. -1) .or. any(ubound(ia) .ne. 2)) STOP 7 + if (any(lbound(ia(:)) .ne. 1) .or. any(ubound(ia(:)) .ne. 4)) STOP 8 + if (any(lbound(ia(from:to)) .ne. 1) .or. any(ubound(ia(from:to)) .ne. 4)) STOP 9 + x=struct(ia) + if (any(lbound(x%ib) .ne. -1) .or. any(ubound(x%ib) .ne. 2)) STOP 10 + x=struct(ia(:)) + if (any(lbound(x%ib) .ne. 1) .or. any(ubound(x%ib) .ne. 4)) STOP 11 + x=struct(ia(from:to)) + if (any(lbound(x%ib) .ne. 1) .or. any(ubound(x%ib) .ne. 4)) STOP 12 + deallocate(ia) + end subroutine +end + diff --git a/Fortran/gfortran/regression/alloc_comp_class_1.f90 b/Fortran/gfortran/regression/alloc_comp_class_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_class_1.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! Test the fix for PR43895, in which the dummy 'a' was not +! dereferenced for the deallocation of component 'a', as required +! for INTENT(OUT). +! +! Contributed by Salvatore Filippone +! +module d_mat_mod + type :: base_sparse_mat + end type base_sparse_mat + + type, extends(base_sparse_mat) :: d_base_sparse_mat + integer :: i + end type d_base_sparse_mat + + type :: d_sparse_mat + class(d_base_sparse_mat), allocatable :: a + end type d_sparse_mat +end module d_mat_mod + + use d_mat_mod + type(d_sparse_mat) :: b + allocate (b%a) + b%a%i = 42 + call bug14 (b) + if (allocated (b%a)) STOP 1 +contains + subroutine bug14(a) + implicit none + type(d_sparse_mat), intent(out) :: a + end subroutine bug14 +end diff --git a/Fortran/gfortran/regression/alloc_comp_class_2.f90 b/Fortran/gfortran/regression/alloc_comp_class_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_class_2.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! +! PR 46838: [OOP] Initialization of polymorphic allocatable components +! +! Contributed by Salvatore Filippone + +program bug28 + + implicit none + + type indx_map + end type + + type desc_type + integer, allocatable :: matrix_data + class(indx_map), allocatable :: indxmap + end type + + type(desc_type) :: desc_a + call cdall(desc_a) + +contains + + subroutine cdall(desc) + type(desc_type), intent(out) :: desc + if (allocated(desc%indxmap)) STOP 1 + end subroutine cdall + +end program diff --git a/Fortran/gfortran/regression/alloc_comp_class_3.f03 b/Fortran/gfortran/regression/alloc_comp_class_3.f03 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_class_3.f03 @@ -0,0 +1,55 @@ +! { dg-do run } +! { dg-options "-Wreturn-type" } +! +! Check that pr58586 is fixed now. +! Based on a contribution by Vladimir Fuka +! Contibuted by Andre Vehreschild + +program test_pr58586 + implicit none + + type :: a + end type + + type :: c + type(a), allocatable :: a + end type + + type :: b + integer, allocatable :: a + end type + + type :: t + integer, allocatable :: comp + end type + type :: u + type(t), allocatable :: comp + end type + + + ! These two are merely to check, if compilation works + call add(b()) + call add(b(null())) + + ! This needs to execute, to see whether the segfault at runtime is resolved + call add_c(c_init()) + + call sub(u()) +contains + + subroutine add (d) + type(b), value :: d + end subroutine + + subroutine add_c (d) + type(c), value :: d + end subroutine + + type(c) function c_init() ! { dg-warning "not set" } + end function + + subroutine sub(d) + type(u), value :: d + end subroutine +end program test_pr58586 + diff --git a/Fortran/gfortran/regression/alloc_comp_class_4.f03 b/Fortran/gfortran/regression/alloc_comp_class_4.f03 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_class_4.f03 @@ -0,0 +1,105 @@ +! { dg-do run } +! { dg-options "-Wreturn-type" } +! +! Check that pr58586 is fixed now. +! Based on a contribution by Vladimir Fuka +! Contibuted by Andre Vehreschild + +module test_pr58586_mod + implicit none + + type :: a + end type + + type :: c + type(a), allocatable :: a + end type + + type :: d + contains + procedure :: init => d_init + end type + + type, extends(d) :: e + contains + procedure :: init => e_init + end type + + type :: b + integer, allocatable :: a + end type + + type t + integer :: i = 5 + end type + +contains + + subroutine add (d) + type(b), value :: d + end subroutine + + subroutine add_c (d) + type(c), value :: d + end subroutine + + subroutine add_class_c (d) + class(c), value :: d + end subroutine + + subroutine add_t (d) + type(t), value :: d + end subroutine + + type(c) function c_init() ! { dg-warning "not set" } + end function + + class(c) function c_init2() ! { dg-warning "not set" } + allocatable :: c_init2 + end function + + type(c) function d_init(this) ! { dg-warning "not set" } + class(d) :: this + end function + + type(c) function e_init(this) + class(e) :: this + allocate (e_init%a) + end function + + type(t) function t_init() ! { dg-warning "not set" } + allocatable :: t_init + end function + + type(t) function static_t_init() ! { dg-warning "not set" } + end function +end module test_pr58586_mod + +program test_pr58586 + use test_pr58586_mod + + class(d), allocatable :: od + class(e), allocatable :: oe + type(t), allocatable :: temp + + ! These two are merely to check, if compilation works + call add(b()) + call add(b(null())) + + ! This needs to execute, to see whether the segfault at runtime is resolved + call add_c(c_init()) + call add_class_c(c_init2()) + + call add_t(static_t_init()) + ! temp = t_init() ! <-- This derefs a null-pointer currently + ! Filed as pr66775 + if (allocated (temp)) STOP 1 + + allocate(od) + call add_c(od%init()) + deallocate(od) + allocate(oe) + call add_c(oe%init()) + deallocate(oe) +end program + diff --git a/Fortran/gfortran/regression/alloc_comp_class_5.f03 b/Fortran/gfortran/regression/alloc_comp_class_5.f03 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_class_5.f03 @@ -0,0 +1,74 @@ +! { dg-do run } +! +! Contributed by Vladimir Fuka +! Check that pr61337 and pr78053, which was caused by this testcase, is fixed. + +module array_list + + type container + class(*), allocatable :: items(:) + end type + +contains + + subroutine add_item(a, e) + type(container),allocatable,intent(inout) :: a(:) + class(*),intent(in) :: e(:) + type(container),allocatable :: tmp(:) + + if (.not.allocated(a)) then + allocate(a(1)) + allocate(a(1)%items(size(e)), source = e) + else + call move_alloc(a,tmp) + allocate(a(size(tmp)+1)) + a(1:size(tmp)) = tmp + allocate(a(size(tmp)+1)%items(size(e)), source=e) + end if + end subroutine + +end module + +program test_pr61337 + + use array_list + + type(container), allocatable :: a_list(:) + integer(kind = 8) :: i + + call add_item(a_list, [1, 2]) + call add_item(a_list, [3.0_8, 4.0_8]) + call add_item(a_list, [.true., .false.]) + call add_item(a_list, ["foo", "bar", "baz"]) + + if (size(a_list) /= 4) STOP 1 + do i = 1, size(a_list) + call checkarr(a_list(i)) + end do + + deallocate(a_list) + +contains + + subroutine checkarr(c) + type(container) :: c + + if (allocated(c%items)) then + select type (x=>c%items) + type is (integer) + if (any(x /= [1, 2])) STOP 2 + type is (real(kind=8)) + if (any(x /= [3.0_8, 4.0_8])) STOP 3 + type is (logical) + if (any(x .neqv. [.true., .false.])) STOP 4 + type is (character(len=*)) + if (len(x) /= 3) STOP 5 + if (any(x /= ["foo", "bar", "baz"])) STOP 6 + class default + STOP 7 + end select + else + STOP 8 + end if + end subroutine +end diff --git a/Fortran/gfortran/regression/alloc_comp_constraint_1.f90 b/Fortran/gfortran/regression/alloc_comp_constraint_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_constraint_1.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options -std=f2003 } +! Check that we don't allow IO of NAMELISTs with types with allocatable +! components (PR 20541) +program main + + type :: foo + integer, allocatable :: x(:) + end type foo + + type :: bar + type(foo) :: x + end type bar + + type(foo) :: a + type(bar) :: b + namelist /blah/ a ! This is allowed under F2003, but not F95 + ! The following require User Defined Derived Type I/O procedures. + write (*, *) a ! { dg-error "cannot have ALLOCATABLE components" } + + read (*, *) b ! { dg-error "cannot have ALLOCATABLE components" } + +end program main diff --git a/Fortran/gfortran/regression/alloc_comp_constraint_2.f90 b/Fortran/gfortran/regression/alloc_comp_constraint_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_constraint_2.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! Check that equivalence with allocatable components isn't allowed (PR 20541) +program main + + type :: foo + sequence + integer, allocatable :: x(:) + end type foo + + type(foo) :: a + integer :: b + + equivalence (a, b) ! { dg-error "cannot have ALLOCATABLE components" } + +end program main diff --git a/Fortran/gfortran/regression/alloc_comp_constraint_3.f90 b/Fortran/gfortran/regression/alloc_comp_constraint_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_constraint_3.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! Check that default initializer for allocatable components isn't accepted (PR +! 20541) +program main + + type :: foo + integer, allocatable :: a(:) = [ 1 ] ! { dg-error "Initialization of allocatable" } + + integer :: x ! Just to avoid "extra" error messages about empty type. + end type foo + +end program main diff --git a/Fortran/gfortran/regression/alloc_comp_constraint_4.f90 b/Fortran/gfortran/regression/alloc_comp_constraint_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_constraint_4.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! Tests the fix for PR29422, in which function results +! were not tested for suitability in IO statements. +! +! Contributed by Dominique d'Humieres +! +Type drv + Integer :: i + Integer, allocatable :: arr(:) +End type drv + + print *, fun1 () ! { dg-error "cannot have ALLOCATABLE" } + +contains + Function fun1 () + + Type(drv) :: fun1 + fun1%i = 10 + end function fun1 +end + diff --git a/Fortran/gfortran/regression/alloc_comp_constraint_5.f90 b/Fortran/gfortran/regression/alloc_comp_constraint_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_constraint_5.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! Check that ALLOCATABLE components aren't allowed to the right of a non-zero +! rank part reference. +program test + + implicit none + type :: foo + real, allocatable :: bar(:) + end type foo + type(foo), target :: x(3) + integer :: i + real, pointer :: p(:) + + allocate(x(:)%bar(5))! { dg-error "must not have the ALLOCATABLE attribute" } + x(:)%bar(1) = 1.0 ! { dg-error "must not have the ALLOCATABLE attribute" } + p => x(:)%bar(1) ! { dg-error "must not have the ALLOCATABLE attribute" } + +end program test diff --git a/Fortran/gfortran/regression/alloc_comp_constraint_6.f90 b/Fortran/gfortran/regression/alloc_comp_constraint_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_constraint_6.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! PR45889 Regression with I/O of element of allocatable array in derived type +module cell + implicit none + private + type, public:: unit_cell + integer ::num_species + character(len=8), dimension(:), allocatable::species_symbol + end type unit_cell + type(unit_cell), public, save::current_cell + contains + subroutine cell_output + implicit none + integer::i + do i=1,current_cell%num_species + write(*,*)(current_cell%species_symbol(i)) + end do + return + end subroutine cell_output +end module cell diff --git a/Fortran/gfortran/regression/alloc_comp_constraint_7.f90 b/Fortran/gfortran/regression/alloc_comp_constraint_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_constraint_7.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options -std=f95 } +! Check that we don't allow types with allocatable +program main + + type :: foo + integer :: k + integer, allocatable :: x(:) ! { dg-error "Fortran 2003: ALLOCATABLE" } + end type foo + + type :: bar + type(foo) :: x + end type bar + + type(foo) :: a + type(bar) :: b + namelist /blah/ a + +end program main diff --git a/Fortran/gfortran/regression/alloc_comp_constructor_1.f90 b/Fortran/gfortran/regression/alloc_comp_constructor_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_constructor_1.f90 @@ -0,0 +1,110 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! Test constructors of derived type with allocatable components (PR 20541). +! +! Contributed by Erik Edelmann +! and Paul Thomas +! + +Program test_constructor + + implicit none + + type :: thytype + integer(4) :: a(2,2) + end type thytype + + type :: mytype + integer(4), allocatable :: a(:, :) + type(thytype), allocatable :: q(:) + end type mytype + + type (thytype) :: foo = thytype(reshape ([43, 100, 54, 76], [2,2])) + integer :: y(0:1, -1:0) = reshape ([42, 99, 55, 77], [2,2]) + + BLOCK ! Add scoping unit as the vars are otherwise implicitly SAVEd + + type (mytype) :: x + integer, allocatable :: yy(:,:) + type (thytype), allocatable :: bar(:) + integer :: i + + ! Check that null() works + x = mytype(null(), null()) + if (allocated(x%a) .or. allocated(x%q)) STOP 1 + + ! Check that unallocated allocatables work + x = mytype(yy, bar) + if (allocated(x%a) .or. allocated(x%q)) STOP 2 + + ! Check that non-allocatables work + x = mytype(y, [foo, foo]) + if (.not.allocated(x%a) .or. .not.allocated(x%q)) STOP 3 + if (any(lbound(x%a) /= lbound(y))) STOP 4 + if (any(ubound(x%a) /= ubound(y))) STOP 5 + if (any(x%a /= y)) STOP 6 + if (size(x%q) /= 2) STOP 7 + do i = 1, 2 + if (any(x%q(i)%a /= foo%a)) STOP 8 + end do + + ! Check that allocated allocatables work + allocate(yy(size(y,1), size(y,2))) + yy = y + allocate(bar(2)) + bar = [foo, foo] + x = mytype(yy, bar) + if (.not.allocated(x%a) .or. .not.allocated(x%q)) STOP 9 + if (any(x%a /= y)) STOP 10 + if (size(x%q) /= 2) STOP 11 + do i = 1, 2 + if (any(x%q(i)%a /= foo%a)) STOP 12 + end do + + ! Functions returning arrays + x = mytype(bluhu(), null()) + if (.not.allocated(x%a) .or. allocated(x%q)) STOP 13 + if (any(x%a /= reshape ([41, 98, 54, 76], [2,2]))) STOP 14 + + ! Functions returning allocatable arrays + x = mytype(blaha(), null()) + if (.not.allocated(x%a) .or. allocated(x%q)) STOP 15 + if (any(x%a /= reshape ([40, 97, 53, 75], [2,2]))) STOP 16 + + ! Check that passing the constructor to a procedure works + call check_mytype (mytype(y, [foo, foo])) + END BLOCK +contains + + subroutine check_mytype(x) + type(mytype), intent(in) :: x + integer :: i + + if (.not.allocated(x%a) .or. .not.allocated(x%q)) STOP 17 + if (any(lbound(x%a) /= lbound(y))) STOP 18 + if (any(ubound(x%a) /= ubound(y))) STOP 19 + if (any(x%a /= y)) STOP 20 + if (size(x%q) /= 2) STOP 21 + do i = 1, 2 + if (any(x%q(i)%a /= foo%a)) STOP 22 + end do + + end subroutine check_mytype + + + function bluhu() + integer :: bluhu(2,2) + + bluhu = reshape ([41, 98, 54, 76], [2,2]) + end function bluhu + + + function blaha() + integer, allocatable :: blaha(:,:) + + allocate(blaha(2,2)) + blaha = reshape ([40, 97, 53, 75], [2,2]) + end function blaha + +end program test_constructor +! { dg-final { scan-tree-dump-times "builtin_free" 19 "original" } } diff --git a/Fortran/gfortran/regression/alloc_comp_constructor_2.f90 b/Fortran/gfortran/regression/alloc_comp_constructor_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_constructor_2.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! Test constructors of nested derived types with allocatable components(PR 20541). +! +! Contributed by Erik Edelmann +! and Paul Thomas +! + type :: thytype + integer(4), allocatable :: h(:) + end type thytype + + type :: mytype + type(thytype), allocatable :: q(:) + end type mytype + + type (mytype) :: x + type (thytype) :: w(2) + integer :: y(2) =(/1,2/) + + w = (/thytype(y), thytype (2*y)/) + x = mytype (w) + if (any ((/((x%q(j)%h(i),j=1,2),i=1,2)/) .ne. (/1,2,2,4/))) STOP 1 + + x = mytype ((/thytype(3*y), thytype (4*y)/)) + if (any ((/((x%q(j)%h(i),j=1,2),i=1,2)/) .ne. (/3,4,6,8/))) STOP 2 + +end diff --git a/Fortran/gfortran/regression/alloc_comp_constructor_3.f90 b/Fortran/gfortran/regression/alloc_comp_constructor_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_constructor_3.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! Tests the fix for PR32665 in which the structure initializer at line +! 13 was getting the array length wrong by one and in which the automatic +! deallocation of a in 14 was occurring before the evaluation of the rhs. +! +! Contributed by Daniel Franke +! + TYPE :: x + INTEGER, ALLOCATABLE :: a(:) + END TYPE + TYPE(x) :: a + + a = x ((/ 1, 2, 3 /)) ! This is also pr31320. + a = x ((/ a%a, 4 /)) + if (any (a%a .ne. (/1,2,3,4/))) STOP 1 +end diff --git a/Fortran/gfortran/regression/alloc_comp_constructor_4.f90 b/Fortran/gfortran/regression/alloc_comp_constructor_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_constructor_4.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! Tests the fix for PR32795, which was primarily about memory leakage is +! certain combinations of alloctable components and constructors. This test +! which appears in comment #2 of the PR has the advantage of a wrong +! numeric result which is symptomatic. +! +! Contributed by Tobias Burnus +! + type :: a + integer, allocatable :: i(:) + end type a + type(a) :: x, y + x = a ([1, 2, 3]) + y = a (x%i(:)) ! used to cause a memory leak and wrong result + if (any (x%i .ne. [1, 2, 3])) STOP 1 +end diff --git a/Fortran/gfortran/regression/alloc_comp_constructor_5.f90 b/Fortran/gfortran/regression/alloc_comp_constructor_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_constructor_5.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! { dg-options "-fdefault-integer-8" } +! Tests the fix for PR34143, in which the implicit conversion of yy, with +! fdefault-integer-8, would cause a segfault at runtime. +! +! Contributed by Thomas Koenig +! +Program test_constructor + implicit none + type :: thytype + integer(4) :: a(2,2) + end type thytype + type :: mytype + integer(4), allocatable :: a(:, :) + type(thytype), allocatable :: q(:) + end type mytype + integer, allocatable :: yy(:,:) + type (thytype), allocatable :: bar(:) + type (mytype) :: x, y + x = mytype(yy, bar) + if (allocated (x%a) .or. allocated (x%q)) STOP 1 + allocate (yy(2,2)) + allocate (bar(2)) + yy = reshape ([10,20,30,40],[2,2]) + bar = thytype (reshape ([1,2,3,4],[2,2])) + ! Check that unallocated allocatables work + y = mytype(yy, bar) + if (.not.allocated (y%a) .or. .not.allocated (y%q)) STOP 2 +end program test_constructor diff --git a/Fortran/gfortran/regression/alloc_comp_constructor_6.f90 b/Fortran/gfortran/regression/alloc_comp_constructor_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_constructor_6.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! { dg-options "-fdefault-integer-8 -O2" } +! Tests the fix for PR34143, where the implicit type +! conversion in the derived type constructor would fail, +! when 'yy' was not allocated. The testscase is an +! extract from alloc_comp_constructor.f90. +! +! Reported by Thomas Koenig +! +Program test_constructor + implicit none + type :: thytype + integer(4) :: a(2,2) + end type thytype + type :: mytype + integer(4), allocatable :: a(:, :) + type(thytype), allocatable :: q(:) + end type mytype + integer, allocatable :: yy(:,:) + type (thytype), allocatable :: bar(:) + call non_alloc + call alloc +contains + subroutine non_alloc + type (mytype) :: x + x = mytype(yy, bar) + if (allocated (x%a) .or. allocated (x%q)) STOP 1 + end subroutine non_alloc + subroutine alloc + type (mytype) :: x + allocate (yy(2,2)) + allocate (bar(2)) + yy = reshape ([10,20,30,40],[2,2]) + bar = thytype (reshape ([1,2,3,4],[2,2])) + x = mytype(yy, bar) + if (.not.allocated (x%a) .or. .not.allocated (x%q)) STOP 2 + end subroutine alloc +end program test_constructor diff --git a/Fortran/gfortran/regression/alloc_comp_constructor_7.f90 b/Fortran/gfortran/regression/alloc_comp_constructor_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_constructor_7.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! +! PR 60357: [F08] structure constructor with unspecified values for allocatable components +! +! Contributed by Antony Lewis + +Type A + integer :: X = 1 + integer, allocatable :: y + integer, allocatable :: z(:) +end type + +Type(A) :: Me = A(X=1) + +if (allocated(Me%y)) STOP 1 +if (allocated(Me%z)) STOP 2 + +end diff --git a/Fortran/gfortran/regression/alloc_comp_deep_copy_1.f03 b/Fortran/gfortran/regression/alloc_comp_deep_copy_1.f03 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_deep_copy_1.f03 @@ -0,0 +1,270 @@ +! { dg-do run } +! +! Check fix for correctly deep copying allocatable components. +! PR fortran/59678 +! Contributed by Andre Vehreschild +! +program alloc_comp_copy_test + + type InnerT + integer :: ii + integer, allocatable :: ai + integer, allocatable :: v(:) + end type InnerT + + type T + integer :: i + integer, allocatable :: a_i + type(InnerT), allocatable :: it + type(InnerT), allocatable :: vec(:) + end type T + + type(T) :: o1, o2 + class(T), allocatable :: o3, o4 + o1%i = 42 + + call copyO(o1, o2) + if (o2%i /= 42) STOP 1 + if (allocated(o2%a_i)) STOP 2 + if (allocated(o2%it)) STOP 3 + if (allocated(o2%vec)) STOP 4 + + allocate (o1%a_i, source=2) + call copyO(o1, o2) + if (o2%i /= 42) STOP 5 + if (.not. allocated(o2%a_i)) STOP 6 + if (o2%a_i /= 2) STOP 7 + if (allocated(o2%it)) STOP 8 + if (allocated(o2%vec)) STOP 9 + + allocate (o1%it) + o1%it%ii = 3 + call copyO(o1, o2) + if (o2%i /= 42) STOP 10 + if (.not. allocated(o2%a_i)) STOP 11 + if (o2%a_i /= 2) STOP 12 + if (.not. allocated(o2%it)) STOP 13 + if (o2%it%ii /= 3) STOP 14 + if (allocated(o2%it%ai)) STOP 15 + if (allocated(o2%it%v)) STOP 16 + if (allocated(o2%vec)) STOP 17 + + allocate (o1%it%ai) + o1%it%ai = 4 + call copyO(o1, o2) + if (o2%i /= 42) STOP 18 + if (.not. allocated(o2%a_i)) STOP 19 + if (o2%a_i /= 2) STOP 20 + if (.not. allocated(o2%it)) STOP 21 + if (o2%it%ii /= 3) STOP 22 + if (.not. allocated(o2%it%ai)) STOP 23 + if (o2%it%ai /= 4) STOP 24 + if (allocated(o2%it%v)) STOP 25 + if (allocated(o2%vec)) STOP 26 + + allocate (o1%it%v(3), source= 5) + call copyO(o1, o2) + if (o2%i /= 42) STOP 27 + if (.not. allocated(o2%a_i)) STOP 28 + if (o2%a_i /= 2) STOP 29 + if (.not. allocated(o2%it)) STOP 30 + if (o2%it%ii /= 3) STOP 31 + if (.not. allocated(o2%it%ai)) STOP 32 + if (o2%it%ai /= 4) STOP 33 + if (.not. allocated(o2%it%v)) STOP 34 + if (any (o2%it%v /= 5) .or. size (o2%it%v) /= 3) STOP 35 + if (allocated(o2%vec)) STOP 36 + + allocate (o1%vec(2)) + o1%vec(:)%ii = 6 + call copyO(o1, o2) + if (o2%i /= 42) STOP 37 + if (.not. allocated(o2%a_i)) STOP 38 + if (o2%a_i /= 2) STOP 39 + if (.not. allocated(o2%it)) STOP 40 + if (o2%it%ii /= 3) STOP 41 + if (.not. allocated(o2%it%ai)) STOP 42 + if (o2%it%ai /= 4) STOP 43 + if (.not. allocated(o2%it%v)) STOP 44 + if (size (o2%it%v) /= 3) STOP 45 + if (any (o2%it%v /= 5)) STOP 46 + if (.not. allocated(o2%vec)) STOP 47 + if (size(o2%vec) /= 2) STOP 48 + if (any(o2%vec(:)%ii /= 6)) STOP 49 + if (allocated(o2%vec(1)%ai) .or. allocated(o2%vec(2)%ai)) STOP 50 + if (allocated(o2%vec(1)%v) .or. allocated(o2%vec(2)%v)) STOP 51 + + allocate (o1%vec(2)%ai) + o1%vec(2)%ai = 7 + call copyO(o1, o2) + if (o2%i /= 42) STOP 52 + if (.not. allocated(o2%a_i)) STOP 53 + if (o2%a_i /= 2) STOP 54 + if (.not. allocated(o2%it)) STOP 55 + if (o2%it%ii /= 3) STOP 56 + if (.not. allocated(o2%it%ai)) STOP 57 + if (o2%it%ai /= 4) STOP 58 + if (.not. allocated(o2%it%v)) STOP 59 + if (size (o2%it%v) /= 3) STOP 60 + if (any (o2%it%v /= 5)) STOP 61 + if (.not. allocated(o2%vec)) STOP 62 + if (size(o2%vec) /= 2) STOP 63 + if (any(o2%vec(:)%ii /= 6)) STOP 64 + if (allocated(o2%vec(1)%ai)) STOP 65 + if (.not. allocated(o2%vec(2)%ai)) STOP 66 + if (o2%vec(2)%ai /= 7) STOP 67 + if (allocated(o2%vec(1)%v) .or. allocated(o2%vec(2)%v)) STOP 68 + + allocate (o1%vec(1)%v(3)) + o1%vec(1)%v = [8, 9, 10] + call copyO(o1, o2) + if (o2%i /= 42) STOP 69 + if (.not. allocated(o2%a_i)) STOP 70 + if (o2%a_i /= 2) STOP 71 + if (.not. allocated(o2%it)) STOP 72 + if (o2%it%ii /= 3) STOP 73 + if (.not. allocated(o2%it%ai)) STOP 74 + if (o2%it%ai /= 4) STOP 75 + if (.not. allocated(o2%it%v)) STOP 76 + if (size (o2%it%v) /= 3) STOP 77 + if (any (o2%it%v /= 5)) STOP 78 + if (.not. allocated(o2%vec)) STOP 79 + if (size(o2%vec) /= 2) STOP 80 + if (any(o2%vec(:)%ii /= 6)) STOP 81 + if (allocated(o2%vec(1)%ai)) STOP 82 + if (.not. allocated(o2%vec(2)%ai)) STOP 83 + if (o2%vec(2)%ai /= 7) STOP 84 + if (.not. allocated(o2%vec(1)%v)) STOP 85 + if (any (o2%vec(1)%v /= [8,9,10])) STOP 86 + if (allocated(o2%vec(2)%v)) STOP 87 + + ! Now all the above for class objects. + allocate (o3, o4) + o3%i = 42 + + call copyO(o3, o4) + if (o4%i /= 42) STOP 88 + if (allocated(o4%a_i)) STOP 89 + if (allocated(o4%it)) STOP 90 + if (allocated(o4%vec)) STOP 91 + + allocate (o3%a_i, source=2) + call copyO(o3, o4) + if (o4%i /= 42) STOP 92 + if (.not. allocated(o4%a_i)) STOP 93 + if (o4%a_i /= 2) STOP 94 + if (allocated(o4%it)) STOP 95 + if (allocated(o4%vec)) STOP 96 + + allocate (o3%it) + o3%it%ii = 3 + call copyO(o3, o4) + if (o4%i /= 42) STOP 97 + if (.not. allocated(o4%a_i)) STOP 98 + if (o4%a_i /= 2) STOP 99 + if (.not. allocated(o4%it)) STOP 100 + if (o4%it%ii /= 3) STOP 101 + if (allocated(o4%it%ai)) STOP 102 + if (allocated(o4%it%v)) STOP 103 + if (allocated(o4%vec)) STOP 104 + + allocate (o3%it%ai) + o3%it%ai = 4 + call copyO(o3, o4) + if (o4%i /= 42) STOP 105 + if (.not. allocated(o4%a_i)) STOP 106 + if (o4%a_i /= 2) STOP 107 + if (.not. allocated(o4%it)) STOP 108 + if (o4%it%ii /= 3) STOP 109 + if (.not. allocated(o4%it%ai)) STOP 110 + if (o4%it%ai /= 4) STOP 111 + if (allocated(o4%it%v)) STOP 112 + if (allocated(o4%vec)) STOP 113 + + allocate (o3%it%v(3), source= 5) + call copyO(o3, o4) + if (o4%i /= 42) STOP 114 + if (.not. allocated(o4%a_i)) STOP 115 + if (o4%a_i /= 2) STOP 116 + if (.not. allocated(o4%it)) STOP 117 + if (o4%it%ii /= 3) STOP 118 + if (.not. allocated(o4%it%ai)) STOP 119 + if (o4%it%ai /= 4) STOP 120 + if (.not. allocated(o4%it%v)) STOP 121 + if (any (o4%it%v /= 5) .or. size (o4%it%v) /= 3) STOP 122 + if (allocated(o4%vec)) STOP 123 + + allocate (o3%vec(2)) + o3%vec(:)%ii = 6 + call copyO(o3, o4) + if (o4%i /= 42) STOP 124 + if (.not. allocated(o4%a_i)) STOP 125 + if (o4%a_i /= 2) STOP 126 + if (.not. allocated(o4%it)) STOP 127 + if (o4%it%ii /= 3) STOP 128 + if (.not. allocated(o4%it%ai)) STOP 129 + if (o4%it%ai /= 4) STOP 130 + if (.not. allocated(o4%it%v)) STOP 131 + if (size (o4%it%v) /= 3) STOP 132 + if (any (o4%it%v /= 5)) STOP 133 + if (.not. allocated(o4%vec)) STOP 134 + if (size(o4%vec) /= 2) STOP 135 + if (any(o4%vec(:)%ii /= 6)) STOP 136 + if (allocated(o4%vec(1)%ai) .or. allocated(o4%vec(2)%ai)) STOP 137 + if (allocated(o4%vec(1)%v) .or. allocated(o4%vec(2)%v)) STOP 138 + + allocate (o3%vec(2)%ai) + o3%vec(2)%ai = 7 + call copyO(o3, o4) + if (o4%i /= 42) STOP 139 + if (.not. allocated(o4%a_i)) STOP 140 + if (o4%a_i /= 2) STOP 141 + if (.not. allocated(o4%it)) STOP 142 + if (o4%it%ii /= 3) STOP 143 + if (.not. allocated(o4%it%ai)) STOP 144 + if (o4%it%ai /= 4) STOP 145 + if (.not. allocated(o4%it%v)) STOP 146 + if (size (o4%it%v) /= 3) STOP 147 + if (any (o4%it%v /= 5)) STOP 148 + if (.not. allocated(o4%vec)) STOP 149 + if (size(o4%vec) /= 2) STOP 150 + if (any(o4%vec(:)%ii /= 6)) STOP 151 + if (allocated(o4%vec(1)%ai)) STOP 152 + if (.not. allocated(o4%vec(2)%ai)) STOP 153 + if (o4%vec(2)%ai /= 7) STOP 154 + if (allocated(o4%vec(1)%v) .or. allocated(o4%vec(2)%v)) STOP 155 + + allocate (o3%vec(1)%v(3)) + o3%vec(1)%v = [8, 9, 10] + call copyO(o3, o4) + if (o4%i /= 42) STOP 156 + if (.not. allocated(o4%a_i)) STOP 157 + if (o4%a_i /= 2) STOP 158 + if (.not. allocated(o4%it)) STOP 159 + if (o4%it%ii /= 3) STOP 160 + if (.not. allocated(o4%it%ai)) STOP 161 + if (o4%it%ai /= 4) STOP 162 + if (.not. allocated(o4%it%v)) STOP 163 + if (size (o4%it%v) /= 3) STOP 164 + if (any (o4%it%v /= 5)) STOP 165 + if (.not. allocated(o4%vec)) STOP 166 + if (size(o4%vec) /= 2) STOP 167 + if (any(o4%vec(:)%ii /= 6)) STOP 168 + if (allocated(o4%vec(1)%ai)) STOP 169 + if (.not. allocated(o4%vec(2)%ai)) STOP 170 + if (o4%vec(2)%ai /= 7) STOP 171 + if (.not. allocated(o4%vec(1)%v)) STOP 172 + if (any (o4%vec(1)%v /= [8,9,10])) STOP 173 + if (allocated(o4%vec(2)%v)) STOP 174 + +contains + + subroutine copyO(src, dst) + type(T), intent(in) :: src + type(T), intent(out) :: dst + + dst = src + end subroutine copyO + +end program alloc_comp_copy_test + diff --git a/Fortran/gfortran/regression/alloc_comp_deep_copy_2.f03 b/Fortran/gfortran/regression/alloc_comp_deep_copy_2.f03 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_deep_copy_2.f03 @@ -0,0 +1,21 @@ +! { dg-do run } +! +! Testcase for PR fortran/65841 +! Contributed by Damian Rousson +! +program alloc_comp_deep_copy_2 + type a + real, allocatable :: f + end type + type b + type(a), allocatable :: g + end type + + type(b) c,d + + c%g=a(1.) + d=c + if (d%g%f /= 1.0) STOP 1 + d%g%f = 2.0 + if (d%g%f /= 2.0) STOP 2 +end program diff --git a/Fortran/gfortran/regression/alloc_comp_deep_copy_3.f03 b/Fortran/gfortran/regression/alloc_comp_deep_copy_3.f03 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_deep_copy_3.f03 @@ -0,0 +1,30 @@ +! { dg-do run } +! +! PR fortran/67721 +! Check that scalar to array assignments of derived type constructor +! deep copy the value when there are allocatable components. + +program p + implicit none + + type :: t1 + integer :: c1 + end type t1 + type :: t2 + type(t1), allocatable :: c2 + end type t2 + + block + type(t2) :: v(4) + + v = t2(t1(3)) + v(2)%c2%c1 = 7 + v(3)%c2%c1 = 11 + v(4)%c2%c1 = 13 + + if (v(1)%c2%c1 /= 3) STOP 1 + if (v(2)%c2%c1 /= 7) STOP 2 + if (v(3)%c2%c1 /= 11) STOP 3 + if (v(4)%c2%c1 /= 13) STOP 4 + end block +end program p diff --git a/Fortran/gfortran/regression/alloc_comp_default_init_1.f90 b/Fortran/gfortran/regression/alloc_comp_default_init_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_default_init_1.f90 @@ -0,0 +1,84 @@ +! { dg-do run } +! Checks the fixes for PR34681 and PR34704, in which various mixtures +! of default initializer and allocatable array were not being handled +! correctly for derived types with allocatable components. +! +! Contributed by Paolo Giannozzi +! +program boh + integer :: c1, c2, c3, c4, c5 + ! + call mah (0, c1) ! These calls deal with PR34681 + call mah (1, c2) + call mah (2, c3) + ! + if (c1 /= c2) STOP 1 + if (c1 /= c3) STOP 1 + ! + call mah0 (c4) ! These calls deal with PR34704 + call mah1 (c5) + ! + if (c4 /= c5) STOP 2 + ! +end program boh +! +subroutine mah (i, c) + ! + integer, intent(in) :: i + integer, intent(OUT) :: c + ! + type mix_type + real(8), allocatable :: a(:) + complex(8), allocatable :: b(:) + end type mix_type + type(mix_type), allocatable, save :: t(:) + integer :: j, n=1024 + ! + if (i==0) then + allocate (t(1)) + allocate (t(1)%a(n)) + allocate (t(1)%b(n)) + do j=1,n + t(1)%a(j) = j + t(1)%b(j) = n-j + end do + end if + c = sum( t(1)%a(:) ) + sum( t(1)%b(:) ) + if ( i==2) then + deallocate (t(1)%b) + deallocate (t(1)%a) + deallocate (t) + end if +end subroutine mah + +subroutine mah0 (c) + ! + integer, intent(OUT) :: c + type mix_type + real(8), allocatable :: a(:) + integer :: n=1023 + end type mix_type + type(mix_type) :: t + ! + allocate(t%a(1)) + t%a=3.1415926 + c = t%n + deallocate(t%a) + ! +end subroutine mah0 +! +subroutine mah1 (c) + ! + integer, intent(OUT) :: c + type mix_type + real(8), allocatable :: a(:) + integer :: n=1023 + end type mix_type + type(mix_type), save :: t + ! + allocate(t%a(1)) + t%a=3.1415926 + c = t%n + deallocate(t%a) + ! +end subroutine mah1 diff --git a/Fortran/gfortran/regression/alloc_comp_default_init_2.f90 b/Fortran/gfortran/regression/alloc_comp_default_init_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_default_init_2.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! Tests the fix for PR35959, in which the structure subpattern was declared static +! so that this test faied on the second recursive call. +! +! Contributed by Micha�l Baudin +! +program testprog + type :: t_type + integer, dimension(:), allocatable :: chars + end type t_type + integer, save :: callnb = 0 + type(t_type) :: this + allocate ( this % chars ( 4)) + if (.not.recursivefunc (this) .or. (callnb .ne. 10)) STOP 1 +contains + recursive function recursivefunc ( this ) result ( match ) + type(t_type), intent(in) :: this + type(t_type) :: subpattern + logical :: match + callnb = callnb + 1 + match = (callnb == 10) + if ((.NOT. allocated (this % chars)) .OR. match) return + allocate ( subpattern % chars ( 4 ) ) + match = recursivefunc ( subpattern ) + end function recursivefunc +end program testprog diff --git a/Fortran/gfortran/regression/alloc_comp_init_expr.f03 b/Fortran/gfortran/regression/alloc_comp_init_expr.f03 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_init_expr.f03 @@ -0,0 +1,14 @@ +! { dg-do compile } +! PR fortran/34402 - allocatable components shall not be +! data-initialized in init expr + + type t + real, allocatable :: x(:) + end type + + ! The following is illegal! + type (t) :: bad = t ( (/ 1., 3., 5., 7., 9. /) ) ! { dg-error "Invalid initialization expression" } + + ! This is ok + type (t) :: ok = t ( NULL() ) +end diff --git a/Fortran/gfortran/regression/alloc_comp_initializer_1.f90 b/Fortran/gfortran/regression/alloc_comp_initializer_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_initializer_1.f90 @@ -0,0 +1,70 @@ +! { dg-do run } +! This checks the correct functioning of derived types with default initializers +! and allocatable components. +! +! Contributed by Salvatore Filippone +! +module p_type_mod + + type m_type + integer, allocatable :: p(:) + end type m_type + + type basep_type + type(m_type), allocatable :: av(:) + type(m_type), pointer :: ap => null () + integer :: i = 101 + end type basep_type + + type p_type + type(basep_type), allocatable :: basepv(:) + integer :: p1 , p2 = 1 + end type p_type +end module p_type_mod + +program foo + + use p_type_mod + implicit none + + type(m_type), target :: a + type(p_type) :: pre + type(basep_type) :: wee + + call test_ab8 () + + a = m_type ((/101,102/)) + + call p_bld (a, pre) + + if (associated (wee%ap) .or. wee%i /= 101) STOP 1 + wee%ap => a + if (.not.associated (wee%ap) .or. allocated (wee%av)) STOP 2 + wee = basep_type ((/m_type ((/201, 202, 203/))/), null (), 99) + if (.not.allocated (wee%av) .or. associated (wee%ap) .or. (wee%i .ne. 99)) STOP 3 + +contains + +! Check that allocatable components are nullified after allocation. + subroutine test_ab8 () + type(p_type) :: p + integer :: ierr + + if (.not.allocated(p%basepv)) then + allocate(p%basepv(1),stat=ierr) + endif + if (allocated (p%basepv) .neqv. .true.) STOP 4 + if (allocated (p%basepv(1)%av) .neqv. .false.) STOP 1 + if (p%basepv(1)%i .ne. 101) STOP 5 + + end subroutine test_ab8 + + subroutine p_bld (a, p) + use p_type_mod + type (m_type) :: a + type(p_type) :: p + if (any (a%p .ne. (/101,102/))) STOP 6 + if (allocated (p%basepv) .or. (p%p2 .ne. 1)) STOP 7 + end subroutine p_bld + +end program foo diff --git a/Fortran/gfortran/regression/alloc_comp_initializer_2.f90 b/Fortran/gfortran/regression/alloc_comp_initializer_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_initializer_2.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! Check that default initializer for allocatable components isn't accepted (PR +! 20541) +program main + + type :: foo + integer, allocatable :: a(:) = [ 1 ] ! { dg-error "Initialization of allocatable" } + + integer :: x ! Just to avoid "extra" error messages about empty type. + end type foo + +end program main diff --git a/Fortran/gfortran/regression/alloc_comp_initializer_3.f90 b/Fortran/gfortran/regression/alloc_comp_initializer_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_initializer_3.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! PR fortran/50050 +! Out of bound whilst releasing initialization of allocate object +! +! Contributed by someone + +program bug + implicit none + type foo + integer, pointer :: a => null() + end type + type(foo), dimension(:,:), allocatable :: data + allocate(data(1:1,1)) ! This used to lead to an ICE +end program diff --git a/Fortran/gfortran/regression/alloc_comp_initializer_4.f03 b/Fortran/gfortran/regression/alloc_comp_initializer_4.f03 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_initializer_4.f03 @@ -0,0 +1,14 @@ +! { dg-do run } +! Fixed by the patch for PRs 60357 and 61275 +! +! Contributed by Stefan Mauerberger +! +PROGRAM main + IMPLICIT NONE + TYPE :: test_typ + REAL, ALLOCATABLE :: a + END TYPE + TYPE(test_typ) :: my_test_typ + my_test_typ = test_typ (a = 1.0) + if (abs (my_test_typ%a - 1.0) .gt. 1e-6) STOP 1 +END PROGRAM main diff --git a/Fortran/gfortran/regression/alloc_comp_misc_1.f90 b/Fortran/gfortran/regression/alloc_comp_misc_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_misc_1.f90 @@ -0,0 +1,28 @@ +! PR 29804 +! This used to fail, it was magically fixed; keep in the testsuite so +! that we keep an eye on it. +! +! { dg-do run } +! { dg-options "-fbounds-check" } +program dt_bnd + implicit none + + type dbprc_type + integer, allocatable :: ipv(:) + end type dbprc_type + + type(dbprc_type), allocatable :: pre(:) + call ppset(pre) + +contains + subroutine ppset(p) + type(dbprc_type),allocatable, intent(inout) :: p(:) + integer :: nl + nl = 1 + + allocate(p(1)) + if (.not.allocated(p(nl)%ipv)) then + allocate(p(1)%ipv(1)) + end if + end subroutine ppset +end program dt_bnd diff --git a/Fortran/gfortran/regression/alloc_comp_optional_1.f90 b/Fortran/gfortran/regression/alloc_comp_optional_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_optional_1.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! Tests the fix for PR38602, a regression caused by a modification +! to the nulling of INTENT_OUT dummies with allocatable components +! that caused a segfault with optional arguments. +! +! Contributed by David Kinniburgh +! +program test_iso + type ivs + character(LEN=1), dimension(:), allocatable :: chars + end type ivs + type(ivs) :: v_str + integer :: i + call foo(v_str, i) + if (v_str%chars(1) .ne. "a") STOP 1 + if (i .ne. 0) STOP 2 + call foo(flag = i) + if (i .ne. 1) STOP 3 +contains + subroutine foo (arg, flag) + type(ivs), optional, intent(out) :: arg + integer :: flag + if (present(arg)) then + arg = ivs([(char(i+96), i = 1,10)]) + flag = 0 + else + flag = 1 + end if + end subroutine +end + diff --git a/Fortran/gfortran/regression/alloc_comp_result_1.f90 b/Fortran/gfortran/regression/alloc_comp_result_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_result_1.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! Test the fix for PR38802, in which the nulling of the result 'p' +! in 'a_fun' would cause a segfault. +! +! Posted on the gfortran list by Marco Restelli http://gcc.gnu.org/ml/fortran/2009-01/ + +! +module mod_a + implicit none + public :: a_fun, t_1, t_2 + private + type t_1 + real :: coeff + end type t_1 + type t_2 + type(t_1), allocatable :: mons(:) + end type t_2 +contains + function a_fun(r) result(p) + integer, intent(in) :: r + type(t_2) :: p(r+1) + p = t_2 ([t_1 (99)]) + end function a_fun +end module mod_a + +program test + use mod_a, only: a_fun, t_1, t_2 + implicit none + type(t_2) x(1) + x = a_fun(0) + if (any (x(1)%mons%coeff .ne. 99)) STOP 1 +end program test diff --git a/Fortran/gfortran/regression/alloc_comp_result_2.f90 b/Fortran/gfortran/regression/alloc_comp_result_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_result_2.f90 @@ -0,0 +1,27 @@ +! Tests the fix for PR40440, in which gfortran tried to deallocate +! the allocatable components of the actual argument of CALL SUB +! +! Contributed by Juergen Reuter +! Reduced testcase from Tobias Burnus +! + implicit none + type t + integer, allocatable :: A(:) + end type t + type (t) :: arg + arg = t ([1,2,3]) + call sub (func (arg)) +contains + function func (a) + type(t), pointer :: func + type(t), target :: a + integer, save :: i = 0 + if (i /= 0) STOP 1! multiple calls would cause this abort + i = i + 1 + func => a + end function func + subroutine sub (a) + type(t), intent(IN), target :: a + if (any (a%A .ne. [1,2,3])) STOP 2 + end subroutine sub +end diff --git a/Fortran/gfortran/regression/alloc_comp_result_3.f90 b/Fortran/gfortran/regression/alloc_comp_result_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_result_3.f90 @@ -0,0 +1,75 @@ +! { dg-do run } +! +! Test the fix for PR96495 - segfaults at runtime at locations below. +! +! Contributed by Paul Luckner +! +module foo_m + + implicit none + + type foo + integer, allocatable :: j(:) + end type + + interface operator(.unary.) + module procedure neg_foo + end interface + + interface operator(.binary.) + module procedure foo_sub_foo + end interface + + interface operator(.binaryElemental.) + module procedure foo_add_foo + end interface + +contains + + elemental function foo_add_foo(f, g) result(h) + !! an example for an elemental binary operator + type(foo), intent(in) :: f, g + type(foo) :: h + + allocate (h%j(size(f%j)), source = f%j+g%j) + end function + + elemental function foo_sub_foo(f, g) result(h) + !! an example for an elemental binary operator + type(foo), intent(in) :: f, g + type(foo) :: h + + allocate (h%j(size(f%j)), source = f%j-3*g%j) + end function + + pure function neg_foo(f) result(g) + !! an example for a unary operator + type(foo), intent(in) :: f + type(foo) :: g + + allocate (g%j(size(f%j)), source = -f%j) + end function + +end module + +program main_tmp + + use foo_m + + implicit none + + type(foo) f, g(2) + + allocate (f%j(3)) + f%j = [2, 3, 4] + + g = f + if (any (g(2)%j .ne. [2, 3, 4])) stop 1 + + g = g .binaryElemental. (f .binary. f) ! threw "Segmentation fault" + if (any (g(2)%j .ne. [-2,-3,-4])) stop 2 + + g = g .binaryElemental. ( .unary. f) ! threw "Segmentation fault" + if (any (g(2)%j .ne. [-4,-6,-8])) stop 3 + +end program diff --git a/Fortran/gfortran/regression/alloc_comp_scalar_1.f90 b/Fortran/gfortran/regression/alloc_comp_scalar_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_scalar_1.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! Test the fix for comment #8 of PR41478, in which copying +! allocatable scalar components caused a segfault. +! +! Contributed by Tobias Burnus +! +program main + type :: container_t + integer, allocatable :: entry + end type container_t + type(container_t), dimension(1) :: a1, a2 + allocate (a1(1)%entry, a2(1)%entry) + a2(1)%entry = 1 + a1(1:1) = pack (a2(1:1), mask = [.true.]) + deallocate (a2(1)%entry) + if (a1(1)%entry .ne. 1) STOP 1 +end program main diff --git a/Fortran/gfortran/regression/alloc_comp_std.f90 b/Fortran/gfortran/regression/alloc_comp_std.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_std.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! Check that we don't accept allocatable components for -std=f95 (PR 20541) +! +program main + + type :: foo + integer, allocatable :: bar(:) ! { dg-error "ALLOCATABLE attribute" } + + integer :: x ! Just to avoid "extra" error messages about empty type. + end type foo + +end program main diff --git a/Fortran/gfortran/regression/alloc_comp_transformational_1.f90 b/Fortran/gfortran/regression/alloc_comp_transformational_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_comp_transformational_1.f90 @@ -0,0 +1,80 @@ +! { dg-do run } +! Tests the fix for PR41478, in which double frees would occur because +! transformational intrinsics did not copy the allocatable components +! so that they were (sometimes) freed twice on exit. In addition, +! The original allocatable components of a1 were not freed, so that +! memory leakage occurred. +! +! Contributed by Juergen Reuter +! + type :: container_t + integer, dimension(:), allocatable :: entry + integer index + end type container_t + call foo + call bar +contains +! +! This is the reported problem. +! + subroutine foo + type(container_t), dimension(4) :: a1, a2, a3 + integer :: i + do i = 1, 4 + allocate (a1(i)%entry (2), a2(i)%entry (2), a3(i)%entry (2)) + a1(i)%entry = [1,2] + a2(i)%entry = [3,4] + a3(i)%entry = [4,5] + a1(i)%index = i + a2(i)%index = i + a3(i)%index = i + end do + a1(1:2) = pack (a2, [.true., .false., .true., .false.]) + do i = 1, 4 + if (.not.allocated (a1(i)%entry)) STOP 1 + if (i .gt. 2) then + if (any (a1(i)%entry .ne. [1,2])) STOP 2 + else + if (any (a1(i)%entry .ne. [3,4])) STOP 3 + end if + end do +! +! Now check unpack +! + a1 = unpack (a1, [.true., .true., .false., .false.], a3) + if (any (a1%index .ne. [1,3,3,4])) STOP 4 + do i = 1, 4 + if (.not.allocated (a1(i)%entry)) STOP 5 + if (i .gt. 2) then + if (any (a1(i)%entry .ne. [4,5])) STOP 6 + else + if (any (a1(i)%entry .ne. [3,4])) STOP 7 + end if + end do + end subroutine +! +! Other all transformational intrinsics display it. Having done +! PACK and UNPACK, just use TRANSPOSE as a demonstrator. +! + subroutine bar + type(container_t), dimension(2,2) :: a1, a2 + integer :: i, j + do i = 1, 2 + do j = 1, 2 + allocate (a1(i, j)%entry (2), a2(i, j)%entry (2)) + a1(i, j)%entry = [i,j] + a2(i, j)%entry = [i,j] + a1(i,j)%index = j + (i - 1)*2 + a2(i,j)%index = j + (i - 1)*2 + end do + end do + a1 = transpose (a2) + do i = 1, 2 + do j = 1, 2 + if (a1(i,j)%index .ne. i + (j - 1)*2) STOP 8 + if (any (a1(i,j)%entry .ne. [j,i])) STOP 9 + end do + end do + end subroutine +end + diff --git a/Fortran/gfortran/regression/alloc_deferred_comp_1.f90 b/Fortran/gfortran/regression/alloc_deferred_comp_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/alloc_deferred_comp_1.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! +! Test the fix for PR99125, where the array reference in the print +! statement caused an ICE because the gimplifier complained about '0' +! being used as an lvalue. +! +! Contributed by Gerhard Steinmetz +! +program p + type t + character(:), allocatable :: a(:) + end type + type(t) :: x + character(8) :: c(3) = ['12 45 78','23 56 89','34 67 90'] + x%a = c + if (any (x%a(2:3) .ne. ['23 56 89','34 67 90'])) stop 1 + if (any (x%a(2:3)(4:5) .ne. ['56','67'])) stop 2 ! Bizarrely this worked. +end diff --git a/Fortran/gfortran/regression/allocatable_dummy_1.f90 b/Fortran/gfortran/regression/allocatable_dummy_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_dummy_1.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! Test procedures with allocatable dummy arguments +program alloc_dummy + + implicit none + integer, allocatable :: a(:) + integer, allocatable :: b(:) + + call init(a) + if (.NOT.allocated(a)) STOP 1 + if (.NOT.all(a == [ 1, 2, 3 ])) STOP 2 + + call useit(a, b) + if (.NOT.all(b == [ 1, 2, 3 ])) STOP 3 + + if (.NOT.all(whatever(a) == [ 1, 2, 3 ])) STOP 4 + + call kill(a) + if (allocated(a)) STOP 5 + + call kill(b) + if (allocated(b)) STOP 6 + +contains + + subroutine init(x) + integer, allocatable, intent(out) :: x(:) + allocate(x(3)) + x = [ 1, 2, 3 ] + end subroutine init + + subroutine useit(x, y) + integer, allocatable, intent(in) :: x(:) + integer, allocatable, intent(out) :: y(:) + if (allocated(y)) STOP 7 + call init(y) + y = x + end subroutine useit + + function whatever(x) + integer, allocatable :: x(:) + integer :: whatever(size(x)) + + whatever = x + end function whatever + + subroutine kill(x) + integer, allocatable, intent(out) :: x(:) + end subroutine kill + +end program alloc_dummy diff --git a/Fortran/gfortran/regression/allocatable_dummy_2.f90 b/Fortran/gfortran/regression/allocatable_dummy_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_dummy_2.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! Check a few constraints for ALLOCATABLE dummy arguments. +program alloc_dummy + + implicit none + integer :: a(5) + + call init(a) ! { dg-error "must be ALLOCATABLE" } + +contains + + subroutine init(x) + integer, allocatable, intent(out) :: x(:) + end subroutine init + + subroutine init2(x) + integer, allocatable, intent(in) :: x(:) + + allocate(x(3)) ! { dg-error "variable definition context" } + end subroutine init2 + + subroutine kill(x) + integer, allocatable, intent(in) :: x(:) + + deallocate(x) ! { dg-error "variable definition context" } + end subroutine kill + +end program alloc_dummy diff --git a/Fortran/gfortran/regression/allocatable_dummy_3.f90 b/Fortran/gfortran/regression/allocatable_dummy_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_dummy_3.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! PR 28416: Check that allocatable dummies can be passed onwards as non-assumed +! shape arg. +program main + + implicit none + integer, allocatable :: a(:) + + interface + subroutine foo(v_out) + integer, allocatable :: v_out(:) + end subroutine foo + end interface + + call foo(a) + if (any(a /= [ 1, 2, 3 ])) STOP 1 + +end program + + +subroutine foo(v_out) + implicit none + integer, allocatable :: v_out(:) + + allocate(v_out(3)) + call bar(v_out, size(v_out)) +end subroutine foo + + +subroutine bar(v, N) + implicit none + integer :: N + integer :: v(N) + integer :: i + + do i = 1, N + v(i) = i + end do +end subroutine bar diff --git a/Fortran/gfortran/regression/allocatable_function_1.f90 b/Fortran/gfortran/regression/allocatable_function_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_function_1.f90 @@ -0,0 +1,110 @@ +! { dg-do run } +! { dg-options "-O2 -fdump-tree-original" } +! Test ALLOCATABLE functions; the primary purpose here is to check that +! each of the various types of reference result in the function result +! being deallocated, using _gfortran_internal_free. +! The companion, allocatable_function_1r.f90, executes this program. +! +subroutine moobar (a) + integer, intent(in) :: a(:) + + if (.not.all(a == [ 1, 2, 3 ])) STOP 1 +end subroutine moobar + +function foo2 (n) + integer, intent(in) :: n + integer, allocatable :: foo2(:) + integer :: i + allocate (foo2(n)) + do i = 1, n + foo2(i) = i + end do +end function foo2 + +module m +contains + function foo3 (n) + integer, intent(in) :: n + integer, allocatable :: foo3(:) + integer :: i + allocate (foo3(n)) + do i = 1, n + foo3(i) = i + end do + end function foo3 +end module m + +program alloc_fun + + use m + implicit none + + integer :: a(3) + + interface + subroutine moobar (a) + integer, intent(in) :: a(:) + end subroutine moobar + end interface + + interface + function foo2 (n) + integer, intent(in) :: n + integer, allocatable :: foo2(:) + end function foo2 + end interface + +! 2 _gfortran_internal_free's + if (.not.all(foo1(3) == [ 1, 2, 3 ])) STOP 2 + a = foo1(size(a)) + +! 1 _gfortran_internal_free + if (.not.all(a == [ 1, 2, 3 ])) STOP 3 + call foobar(foo1(3)) + +! 1 _gfortran_internal_free + if (.not.all(2*bar(size(a)) + 5 == [ 7, 9, 11 ])) STOP 4 + +! Although the rhs determines the loop size, the lhs reference is +! evaluated, in case it has side-effects or is needed for bounds checking. +! 3 _gfortran_internal_free's + a(1:size (bar (3))) = 2*bar(size(a)) + 2 + a(size (bar (3))) + if (.not.all(a == [ 7, 9, 11 ])) STOP 5 + +! 3 _gfortran_internal_free's + call moobar(foo1(3)) ! internal function + call moobar(foo2(3)) ! module function + call moobar(foo3(3)) ! explicit interface + +! 9 _gfortran_internal_free's in total +contains + + subroutine foobar (a) + integer, intent(in) :: a(:) + + if (.not.all(a == [ 1, 2, 3 ])) STOP 6 + end subroutine foobar + + function foo1 (n) + integer, intent(in) :: n + integer, allocatable :: foo1(:) + integer :: i + allocate (foo1(n)) + do i = 1, n + foo1(i) = i + end do + end function foo1 + + function bar (n) result(b) + integer, intent(in) :: n + integer, target, allocatable :: b(:) + integer :: i + + allocate (b(n)) + do i = 1, n + b(i) = i + end do + end function bar + +end program alloc_fun +! { dg-final { scan-tree-dump-times "free" 10 "original" } } diff --git a/Fortran/gfortran/regression/allocatable_function_10.f90 b/Fortran/gfortran/regression/allocatable_function_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_function_10.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! +! Test the fix for PR78293. The deallocations are present at the +! end of the main programme to aid memory leak searching. The +! allocation in 'tt' leaked memory from an intermediate temporary +! for the array constructor. +! +! Contributed by Andrew Benson +! +module m + implicit none + + type t + integer, allocatable, dimension(:) :: r + end type t + +contains + + function tt(a,b) + implicit none + type(t), allocatable, dimension(:) :: tt + type(t), intent(in), dimension(:) :: a,b + allocate(tt, source = [a,b]) + end function tt + + function ts(arg) + implicit none + type(t), allocatable, dimension(:) :: ts + integer, intent(in) :: arg(:) + allocate(ts(1)) + allocate(ts(1)%r, source = arg) + return + end function ts + +end module m + +program p + use m + implicit none + type(t), dimension(2) :: c + c=tt(ts([99,199,1999]),ts([42,142])) + if (any (c(1)%r .ne. [99,199,1999])) STOP 1 + if (any (c(2)%r .ne. [42,142])) STOP 2 + deallocate(c(1)%r) + deallocate(c(2)%r) +end program p diff --git a/Fortran/gfortran/regression/allocatable_function_2.f90 b/Fortran/gfortran/regression/allocatable_function_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_function_2.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! Test constraints on ALLOCATABLE functions +program alloc_fun + +contains + + elemental function foo (n) + integer, intent(in) :: n + integer, allocatable :: foo(:) ! { dg-error "ALLOCATABLE .* ELEMENTAL" } + end function foo + +end program alloc_fun diff --git a/Fortran/gfortran/regression/allocatable_function_3.f90 b/Fortran/gfortran/regression/allocatable_function_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_function_3.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! Tests the fix for PR33986, in which the call to scram would call +! an ICE because allocatable result actuals had not been catered for. +! +! Contributed by Damian Rouson +! +function transform_to_spectral_from() result(spectral) + integer, allocatable :: spectral(:) + allocate(spectral(2)) + call scram(spectral) +end function transform_to_spectral_from + +subroutine scram (x) + integer x(2) + x = (/1,2/) +end subroutine + + interface + function transform_to_spectral_from() result(spectral) + integer, allocatable :: spectral(:) + end function transform_to_spectral_from + end interface + if (any (transform_to_spectral_from () .ne. (/1,2/))) STOP 1 +end diff --git a/Fortran/gfortran/regression/allocatable_function_4.f90 b/Fortran/gfortran/regression/allocatable_function_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_function_4.f90 @@ -0,0 +1,55 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/37626 +! Contributed by Rich Townsend +! +! The problem was an ICE when trying to deallocate the +! result variable "x_unique". +! +function unique_A (x, sorted) result (x_unique) + implicit none + character(*), dimension(:), intent(in) :: x + logical, intent(in), optional :: sorted + character(LEN(x)), dimension(:), allocatable :: x_unique + + logical :: sorted_ + character(LEN(x)), dimension(SIZE(x)) :: x_sorted + integer :: n_x + logical, dimension(SIZE(x)) :: mask + + integer, external :: b3ss_index + +! Set up sorted_ + + if(PRESENT(sorted)) then + sorted_ = sorted + else + sorted_ = .FALSE. + endif + +! If necessary, sort x + + if(sorted_) then + x_sorted = x + else + x_sorted = x(b3ss_index(x)) + endif + +! Set up the unique array + + n_x = SIZE(x) + + mask = (/.TRUE.,x_sorted(2:n_x) /= x_sorted(1:n_x-1)/) + + allocate(x_unique(COUNT(mask))) + + x_unique = PACK(x_sorted, MASK=mask) + +! Finish + + return +end function unique_A + +! { dg-final { scan-tree-dump-times "__builtin_free" 5 "original" } } + diff --git a/Fortran/gfortran/regression/allocatable_function_5.f90 b/Fortran/gfortran/regression/allocatable_function_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_function_5.f90 @@ -0,0 +1,48 @@ +! { dg-do run } +! Tests function return of deferred length scalars. +! +! Contributed by Paul Thomas +! +module m +contains + function mfoo (carg) result(res) + character (:), allocatable :: res + character (*) :: carg + res = carg(2:4) + end function + function mbar (carg) + character (:), allocatable :: mbar + character (*) :: carg + mbar = carg(2:13) + end function +end module + + use m + character (:), allocatable :: lhs + lhs = foo ("foo calling ") + if (lhs .ne. "foo") STOP 1 + if (len (lhs) .ne. 3) STOP 2 + deallocate (lhs) + lhs = bar ("bar calling - baaaa!") + if (lhs .ne. "bar calling") STOP 3 + if (len (lhs) .ne. 12) STOP 4 + deallocate (lhs) + lhs = mfoo ("mfoo calling ") + if (lhs .ne. "foo") STOP 5 + if (len (lhs) .ne. 3) STOP 6 + deallocate (lhs) + lhs = mbar ("mbar calling - baaaa!") + if (lhs .ne. "bar calling") STOP 7 + if (len (lhs) .ne. 12) STOP 8 +contains + function foo (carg) result(res) + character (:), allocatable :: res + character (*) :: carg + res = carg(1:3) + end function + function bar (carg) + character (:), allocatable :: bar + character (*) :: carg + bar = carg(1:12) + end function +end diff --git a/Fortran/gfortran/regression/allocatable_function_6.f90 b/Fortran/gfortran/regression/allocatable_function_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_function_6.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! +! PR fortran/56138 +! +! Contributed by John Chludzinski, using the code of John Reid +! +implicit none +CHARACTER(LEN=:),ALLOCATABLE :: str +if (s_to_c("ABCdef") /= "ABCdef" .or. len(s_to_c("ABCdef")) /= 6) STOP 1 +str = s_to_c("ABCdef") +if (str /= "ABCdef" .or. len(str) /= 6) STOP 2 +str(1:3) = s_to_c("123") +if (str /= "123def" .or. len(str) /= 6) STOP 3 + +contains + +PURE FUNCTION s_to_c(string) + CHARACTER(LEN=*),INTENT(IN) :: string + CHARACTER(LEN=:),ALLOCATABLE :: s_to_c + s_to_c = string +ENDFUNCTION s_to_c +end diff --git a/Fortran/gfortran/regression/allocatable_function_7.f90 b/Fortran/gfortran/regression/allocatable_function_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_function_7.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! +! PR fortran/56138 +! +! Contributed by Dominique d'Humieres and John Chludzinski, +! using the code of John Reid +! +implicit none +interface +PURE FUNCTION s_to_c(string) + CHARACTER(LEN=*),INTENT(IN) :: string + CHARACTER(LEN=:),ALLOCATABLE :: s_to_c +ENDFUNCTION s_to_c +end interface +CHARACTER(LEN=:),ALLOCATABLE :: str +if (s_to_c("ABCdef") /= "ABCdef" .or. len(s_to_c("ABCdef")) /= 6) STOP 1 +str = s_to_c("ABCdef") +if (str /= "ABCdef" .or. len(str) /= 6) STOP 2 +str(1:3) = s_to_c("123") +if (str /= "123def" .or. len(str) /= 6) STOP 3 + +end + +PURE FUNCTION s_to_c(string) + CHARACTER(LEN=*),INTENT(IN) :: string + CHARACTER(LEN=:),ALLOCATABLE :: s_to_c + s_to_c = string +END FUNCTION s_to_c diff --git a/Fortran/gfortran/regression/allocatable_function_8.f90 b/Fortran/gfortran/regression/allocatable_function_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_function_8.f90 @@ -0,0 +1,60 @@ +! { dg-do run } +! { dg-require-visibility "" } +! Test the fix for PR61459 and PR58883. +! +! Contributed by John Wingate +! and Tao Song +! +module a + + implicit none + private + public :: f_segfault, f_segfault_plus, f_workaround + integer, dimension(2,2) :: b = reshape([1,-1,1,1],[2,2]) + +contains + + function f_segfault(x) + real, dimension(:), allocatable :: f_segfault + real, dimension(:), intent(in) :: x + allocate(f_segfault(2)) + f_segfault = matmul(b,x) + end function f_segfault + +! Sefaulted without the ALLOCATE as well. + function f_segfault_plus(x) + real, dimension(:), allocatable :: f_segfault_plus + real, dimension(:), intent(in) :: x + f_segfault_plus = matmul(b,x) + end function f_segfault_plus + + function f_workaround(x) + real, dimension(:), allocatable :: f_workaround + real, dimension(:), intent(in) :: x + real, dimension(:), allocatable :: tmp + allocate(f_workaround(2),tmp(2)) + tmp = matmul(b,x) + f_workaround = tmp + end function f_workaround + +end module a + +program main + use a + implicit none + real, dimension(2) :: x = 1.0, y +! PR61459 + y = f_workaround (x) + if (any (f_segfault (x) .ne. y)) STOP 1 + if (any (f_segfault_plus (x) .ne. y)) STOP 2 +! PR58883 + if (any (foo () .ne. reshape([1,2,3,4,5,6,7,8],[2,4]))) STOP 3 +contains + function foo() + integer, allocatable :: foo(:,:) + integer, allocatable :: temp(:) + + temp = [1,2,3,4,5,6,7,8] + foo = reshape(temp,[2,4]) + end function +end program main diff --git a/Fortran/gfortran/regression/allocatable_function_9.f90 b/Fortran/gfortran/regression/allocatable_function_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_function_9.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! +! PR fortran/55603 +! Check that the allocatable result is properly freed after use. +! +! Contributed by Damian Rouson + + type foo + end type + type(foo) a + a = bar() +contains + function bar() + type(foo), allocatable :: bar + allocate(bar) + end function +end diff --git a/Fortran/gfortran/regression/allocatable_module_1.f90 b/Fortran/gfortran/regression/allocatable_module_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_module_1.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! PR 36934 - this used to give a spurious error and segfault with a +! patch that wasn't complete +! Test case contributed by Philip Mason + +module fred1 +real, allocatable :: default_clocks(:) +end module fred1 + +module fred2 +real, allocatable :: locks(:) +end module fred2 + +program fred +use fred1 +use fred2 +end program fred diff --git a/Fortran/gfortran/regression/allocatable_scalar_1.f90 b/Fortran/gfortran/regression/allocatable_scalar_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_scalar_1.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! +! PR 40996: [F03] ALLOCATABLE scalars +! +! Contributed by Janus Weil + +implicit none +real, allocatable :: scalar + +allocate(scalar) +scalar = exp(1.) +print *,scalar +if (.not. allocated(scalar)) STOP 1 +deallocate(scalar) +if (allocated(scalar)) STOP 2 + +end + diff --git a/Fortran/gfortran/regression/allocatable_scalar_10.f90 b/Fortran/gfortran/regression/allocatable_scalar_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_scalar_10.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! +! PR 42647: Missed initialization/dealloc of allocatable scalar DT with allocatable component +! +! Contributed by Tobias Burnus + +type t + integer, allocatable :: p +end type t +type(t), allocatable :: a + +deallocate(a,stat=istat) +if (istat == 0) STOP 1 +end diff --git a/Fortran/gfortran/regression/allocatable_scalar_11.f90 b/Fortran/gfortran/regression/allocatable_scalar_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_scalar_11.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR fortran/46484 +! + +function g() + implicit none + integer, allocatable :: g + call int() + print *, loc(g) ! OK +contains + subroutine int() + print *, loc(g) ! OK + print *, allocated(g) ! OK + end subroutine int +end function + +implicit none +integer, allocatable :: x +print *, allocated(f) ! { dg-error "must be a variable" } +print *, loc(f) ! OK +contains +function f() + integer, allocatable :: f + print *, loc(f) ! OK + print *, allocated(f) ! OK +end function +end diff --git a/Fortran/gfortran/regression/allocatable_scalar_12.f90 b/Fortran/gfortran/regression/allocatable_scalar_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_scalar_12.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! +! PR fortran/47421 +! +! Don't auto-deallocatable scalar character allocatables. +! +implicit none +character(len=5), allocatable :: str +allocate(str) +str = '1bcde' +if(str /= '1bcde') STOP 1 +call sub(str,len(str)) +if(str /= '1bcde') STOP 2 +call subOUT(str,len(str)) +if (len(str) /= 5) STOP 3 +if(allocated(str)) STOP 4 +contains + subroutine sub(x,n) + integer :: n + character(len=n), allocatable :: x + if(len(x) /= 5) STOP 5 + if(x /= '1bcde') STOP 6 + end subroutine sub + subroutine subOUT(x,n) + integer :: n + character(len=n), allocatable,intent(out) :: x + if(allocated(x)) STOP 7 + if(len(x) /= 5) STOP 8 + end subroutine subOUT +end diff --git a/Fortran/gfortran/regression/allocatable_scalar_13.f90 b/Fortran/gfortran/regression/allocatable_scalar_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_scalar_13.f90 @@ -0,0 +1,70 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! Test the fix for PR66079. The original problem was with the first +! allocate statement. The rest of this testcase fixes problems found +! whilst working on it! +! +! Reported by Damian Rouson +! + type subdata + integer, allocatable :: b + endtype +! block + call newRealVec +! end block +contains + subroutine newRealVec + type(subdata), allocatable :: d, e, f + character(:), allocatable :: g, h, i + character(8), allocatable :: j + allocate(d,source=subdata(1)) ! memory was lost, now OK + allocate(e,source=d) ! OK + allocate(f,source=create (99)) ! memory was lost, now OK + if (d%b .ne. 1) STOP 1 + if (e%b .ne. 1) STOP 2 + if (f%b .ne. 99) STOP 3 + allocate (g, source = greeting1("good day")) + if (g .ne. "good day") STOP 4 + allocate (h, source = greeting2("hello")) + if (h .ne. "hello") STOP 5 + allocate (i, source = greeting3("hiya!")) + if (i .ne. "hiya!") STOP 6 + call greeting4 (j, "Goodbye ") ! Test that dummy arguments are OK + if (j .ne. "Goodbye ") STOP 7 + end subroutine + + function create (arg) result(res) + integer :: arg + type(subdata), allocatable :: res, res1 + allocate(res, res1, source = subdata(arg)) + end function + + function greeting1 (arg) result(res) ! memory was lost, now OK + character(*) :: arg + Character(:), allocatable :: res + allocate(res, source = arg) + end function + + function greeting2 (arg) result(res) + character(5) :: arg + Character(:), allocatable :: res + allocate(res, source = arg) + end function + + function greeting3 (arg) result(res) + character(5) :: arg + Character(5), allocatable :: res, res1 + allocate(res, res1, source = arg) ! Caused an ICE + if (res1 .ne. res) STOP 8 + end function + + subroutine greeting4 (res, arg) + character(8), intent(in) :: arg + Character(8), allocatable, intent(out) :: res + allocate(res, source = arg) ! Caused an ICE + end subroutine +end +! { dg-final { scan-tree-dump-times "builtin_malloc" 20 "original" } } +! { dg-final { scan-tree-dump-times "builtin_free" 21 "original" } } + diff --git a/Fortran/gfortran/regression/allocatable_scalar_14.f90 b/Fortran/gfortran/regression/allocatable_scalar_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_scalar_14.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! +! Test the fix for PR64120 in which the initialisation of the +! string length of 's' was not being done. +! +! Contributed by Francois-Xavier Coudert +! + call g(1) + call g(2) +contains + subroutine g(x) + integer :: x + character(len=x), allocatable :: s + allocate(s) + if (len(s) .ne. x) stop x + end subroutine +end diff --git a/Fortran/gfortran/regression/allocatable_scalar_2.f90 b/Fortran/gfortran/regression/allocatable_scalar_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_scalar_2.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-std=f95" } + +! Parsing of finalizer procedure definitions. +! While ALLOCATABLE scalars are not implemented, this even used to ICE. +! Thanks Tobias Burnus for the test! + +integer, allocatable :: x ! { dg-error "may not be ALLOCATABLE" } + +end + diff --git a/Fortran/gfortran/regression/allocatable_scalar_3.f90 b/Fortran/gfortran/regression/allocatable_scalar_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_scalar_3.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! +! PR 40996: [F03] ALLOCATABLE scalars +! +! Contributed by Janus Weil + +implicit none + +type :: t + integer, allocatable :: i +end type + +type(t)::x + +allocate(x%i) + +x%i = 13 +print *,x%i +if (.not. allocated(x%i)) STOP 1 + +deallocate(x%i) + +if (allocated(x%i)) STOP 2 + +end diff --git a/Fortran/gfortran/regression/allocatable_scalar_4.f90 b/Fortran/gfortran/regression/allocatable_scalar_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_scalar_4.f90 @@ -0,0 +1,95 @@ +! { dg-do run } +! +! PR fortran/41872 +! +! +program test + implicit none + integer, allocatable :: a + integer, allocatable :: b + allocate(a) + call foo(a) + if(.not. allocated(a)) STOP 1 + if (a /= 5) STOP 2 + + call bar(a) + if (a /= 7) STOP 3 + + deallocate(a) + if(allocated(a)) STOP 4 + call check3(a) + if(.not. allocated(a)) STOP 5 + if(a /= 6874) STOP 6 + call check4(a) + if(.not. allocated(a)) STOP 7 + if(a /= -478) STOP 8 + + allocate(b) + b = 7482 + call checkOptional(.false.,.true., 7482) + if (b /= 7482) STOP 9 + call checkOptional(.true., .true., 7482, b) + if (b /= 46) STOP 10 +contains + subroutine foo(a) + integer, allocatable, intent(out) :: a + if(allocated(a)) STOP 11 + allocate(a) + a = 5 + end subroutine foo + + subroutine bar(a) + integer, allocatable, intent(inout) :: a + if(.not. allocated(a)) STOP 12 + if (a /= 5) STOP 13 + a = 7 + end subroutine bar + + subroutine check3(a) + integer, allocatable, intent(inout) :: a + if(allocated(a)) STOP 14 + allocate(a) + a = 6874 + end subroutine check3 + + subroutine check4(a) + integer, allocatable, intent(inout) :: a + if(.not.allocated(a)) STOP 15 + if (a /= 6874) STOP 1 + deallocate(a) + if(allocated(a)) STOP 16 + allocate(a) + if(.not.allocated(a)) STOP 17 + a = -478 + end subroutine check4 + + subroutine checkOptional(prsnt, alloc, val, x) + logical, intent(in) :: prsnt, alloc + integer, allocatable, optional :: x + integer, intent(in) :: val + if (present(x) .neqv. prsnt) STOP 18 + if (present(x)) then + if (allocated(x) .neqv. alloc) STOP 19 + end if + if (present(x)) then + if (allocated(x)) then + if (x /= val) STOP 20 + end if + end if + call checkOptional2(x) + if (present(x)) then + if (.not. allocated(x)) STOP 21 + if (x /= -6784) STOP 22 + x = 46 + end if + call checkOptional2() + end subroutine checkOptional + subroutine checkOptional2(x) + integer, allocatable, optional, intent(out) :: x + if (present(x)) then + if (allocated(x)) STOP 23 + allocate(x) + x = -6784 + end if + end subroutine checkOptional2 +end program test diff --git a/Fortran/gfortran/regression/allocatable_scalar_5.f90 b/Fortran/gfortran/regression/allocatable_scalar_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_scalar_5.f90 @@ -0,0 +1,55 @@ +! { dg-do run } +! { dg-options "-Wall -pedantic" } +! +! PR fortran/41872; updated due to PR fortran/46484 +! +! More tests for allocatable scalars +! +program test + implicit none + integer, allocatable :: a + integer :: b + + if (allocated (a)) STOP 1 + b = 7 + b = func(.true.) + if (b /= 5332) STOP 2 + b = 7 + b = func(.true.) + 1 + if (b /= 5333) STOP 3 + + call intout (a, .false.) + if (allocated (a)) STOP 4 + call intout (a, .true.) + if (.not.allocated (a)) STOP 5 + if (a /= 764) STOP 6 + call intout2 (a) + if (allocated (a)) STOP 7 + +contains + + function func (alloc) + integer, allocatable :: func + logical :: alloc + if (allocated (func)) STOP 8 + if (alloc) then + allocate(func) + func = 5332 + end if + end function func + + subroutine intout (dum, alloc) + implicit none + integer, allocatable,intent(out) :: dum + logical :: alloc + if (allocated (dum)) STOP 9 + if (alloc) then + allocate (dum) + dum = 764 + end if + end subroutine intout + + subroutine intout2 (dum) ! { dg-warning "declared INTENT.OUT. but was not set" } + integer, allocatable,intent(out) :: dum + end subroutine intout2 +end program test diff --git a/Fortran/gfortran/regression/allocatable_scalar_6.f90 b/Fortran/gfortran/regression/allocatable_scalar_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_scalar_6.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! { dg-options "-Wall -pedantic" } +! +! PR fortran/41872 +! +! (De)allocate tests +! +program test + implicit none + integer, allocatable :: a, b, c + integer :: stat + stat=99 + allocate(a, stat=stat) + if (stat /= 0) STOP 1 + allocate(a, stat=stat) + if (stat == 0) STOP 2 + + allocate (b) + deallocate (b, stat=stat) + if (stat /= 0) STOP 3 + deallocate (b, stat=stat) + if (stat == 0) STOP 4 + + deallocate (c, stat=stat) + if (stat == 0) STOP 5 +end program test diff --git a/Fortran/gfortran/regression/allocatable_scalar_7.f90 b/Fortran/gfortran/regression/allocatable_scalar_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_scalar_7.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! +! PR fortran/41872 +! +! Allocatable scalars with SAVE +! +program test + implicit none + call sub (0) + call sub (1) + call sub (2) +contains + subroutine sub (no) + integer, intent(in) :: no + integer, allocatable, save :: a + if (no == 0) then + if (allocated (a)) STOP 1 + allocate (a) + else if (no == 1) then + if (.not. allocated (a)) STOP 2 + deallocate (a) + else + if (allocated (a)) STOP 3 + end if + end subroutine sub +end program test diff --git a/Fortran/gfortran/regression/allocatable_scalar_8.f90 b/Fortran/gfortran/regression/allocatable_scalar_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_scalar_8.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! +! PR fortran/41872 +! +! Character functions returning allocatable scalars +! +program test + implicit none + if (func () /= 'abc') STOP 1 +contains + function func() result (str) + character(len=3), allocatable :: str + if (allocated (str)) STOP 2 + allocate (str) + str = 'abc' + end function func +end program test diff --git a/Fortran/gfortran/regression/allocatable_scalar_9.f90 b/Fortran/gfortran/regression/allocatable_scalar_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_scalar_9.f90 @@ -0,0 +1,55 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! PR 42647: Missed initialization/dealloc of allocatable scalar DT with allocatable component +! +! Contributed by Tobias Burnus + +module m +type st + integer , allocatable :: a1 +end type st +type at + integer , allocatable :: a2(:) +end type at + +type t1 + type(st), allocatable :: b1 +end type t1 +type t2 + type(st), allocatable :: b2(:) +end type t2 +type t3 + type(at), allocatable :: b3 +end type t3 +type t4 + type(at), allocatable :: b4(:) +end type t4 +end module m + +use m +block ! Start new scoping unit as otherwise the vars are implicitly SAVEd +type(t1) :: na1, a1, aa1(:) +type(t2) :: na2, a2, aa2(:) +type(t3) :: na3, a3, aa3(:) +type(t4) :: na4, a4, aa4(:) + +allocatable :: a1, a2, a3, a4, aa1, aa2, aa3,aa4 + +if(allocated(a1)) STOP 1 +if(allocated(a2)) STOP 2 +if(allocated(a3)) STOP 3 +if(allocated(a4)) STOP 4 +if(allocated(aa1)) STOP 5 +if(allocated(aa2)) STOP 6 +if(allocated(aa3)) STOP 7 +if(allocated(aa4)) STOP 8 + +if(allocated(na1%b1)) STOP 9 +if(allocated(na2%b2)) STOP 10 +if(allocated(na3%b3)) STOP 11 +if(allocated(na4%b4)) STOP 12 +end block +end + +! { dg-final { scan-tree-dump-times "__builtin_free" 54 "original" } } diff --git a/Fortran/gfortran/regression/allocatable_uninitialized_1.f90 b/Fortran/gfortran/regression/allocatable_uninitialized_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocatable_uninitialized_1.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "-O -Wall" } +program main + real,allocatable:: a(:),b(:) + + a(1)=2*b(1) ! { dg-warning "uninitialized" } + +end diff --git a/Fortran/gfortran/regression/allocate_alloc_opt_1.f90 b/Fortran/gfortran/regression/allocate_alloc_opt_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_alloc_opt_1.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +program a + + implicit none + + real x + integer j, k, n(4) + character(len=70) err + character(len=70), allocatable :: error(:) + + integer, allocatable :: i(:) + + type b + integer, allocatable :: c(:), d(:) + end type b + + type(b) e, f(3) + + allocate(i(2), stat=x) ! { dg-error "must be a scalar INTEGER" } + allocate(i(2), stat=j, stat=k) ! { dg-error "Redundant STAT" } + allocate(i(2)) + allocate(i(2))) ! { dg-error "Syntax error in ALLOCATE" } + allocate(i(2), errmsg=err, errmsg=err) ! { dg-error "Redundant ERRMSG" } + allocate(i(2), errmsg=err) ! { dg-warning "useless without a STAT" } + allocate(i(2), stat=j, errmsg=x) ! { dg-error "shall be a scalar default CHARACTER" } + + allocate(err) ! { dg-error "neither a data pointer nor an allocatable" } + + allocate(error(2),stat=j,errmsg=error(1)) ! { dg-error "shall not be ALLOCATEd within" } + allocate(i(2), stat = i(1)) ! { dg-error "shall not be ALLOCATEd within" } + + allocate(n) ! { dg-error "must be ALLOCATABLE or a POINTER" } + + allocate(i(2), i(2)) ! { dg-error "Allocate-object at" } + + ! These should not fail the check for duplicate alloc-objects. + allocate(f(1)%c(2), f(2)%d(2)) + allocate(e%c(2), e%d(2)) + +end program a diff --git a/Fortran/gfortran/regression/allocate_alloc_opt_10.f90 b/Fortran/gfortran/regression/allocate_alloc_opt_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_alloc_opt_10.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! +! PR 43388: [F2008][OOP] ALLOCATE with MOLD= +! +! Contributed by Janus Weil + +type :: t1 + integer :: i +end type + +type,extends(t1) :: t2 + integer :: j = 4 +end type + +class(t1),allocatable :: x,y +type(t2) :: z + + +!!! first example (static) + +z%j = 5 +allocate(x,MOLD=z) + +select type (x) +type is (t2) + print *,x%j + if (x%j/=4) STOP 1 + x%j = 5 +class default + STOP 1 +end select + + +!!! second example (dynamic, PR 44541) + +allocate(y,MOLD=x) + +select type (y) +type is (t2) + print *,y%j + if (y%j/=4) STOP 2 +class default + STOP 2 +end select + +end diff --git a/Fortran/gfortran/regression/allocate_alloc_opt_11.f90 b/Fortran/gfortran/regression/allocate_alloc_opt_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_alloc_opt_11.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! +! PR fortran/44556 +! +! Contributed by Jonathan Hogg and Steve Kargl. +! +program oh_my + implicit none + type a + integer, allocatable :: b(:), d(:) + character(len=80) :: err + character(len=80), allocatable :: str(:) + integer :: src + end type a + + integer j + type(a) :: c + c%err = 'ok' + allocate(c%d(1)) + allocate(c%b(2), errmsg=c%err, stat=c%d(1)) ! OK + deallocate(c%b, errmsg=c%err, stat=c%d(1)) ! OK + allocate(c%b(2), errmsg=c%err, stat=c%b(1)) ! { dg-error "the same ALLOCATE statement" } + deallocate(c%b, errmsg=c%err, stat=c%b(1)) ! { dg-error "the same DEALLOCATE statement" } + allocate(c%str(2), errmsg=c%str(1), stat=j) ! { dg-error "the same ALLOCATE statement" } + deallocate(c%str, errmsg=c%str(1), stat=j) ! { dg-error "the same DEALLOCATE statement" } +end program oh_my diff --git a/Fortran/gfortran/regression/allocate_alloc_opt_12.f90 b/Fortran/gfortran/regression/allocate_alloc_opt_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_alloc_opt_12.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! PR 45507: [4.6 Regression] Bogus Error: Can't convert TYPE(c_ptr) to INTEGER(4) +! +! Contributed by Andrew Benson + + use, intrinsic :: iso_c_binding + + type :: cType + type(c_ptr) :: accelPtr = c_null_ptr + end type cType + + type(cType), allocatable, dimension(:) :: filters + class(cType), allocatable :: f + + allocate(filters(1)) + allocate(f,MOLD=filters(1)) + +end diff --git a/Fortran/gfortran/regression/allocate_alloc_opt_13.f90 b/Fortran/gfortran/regression/allocate_alloc_opt_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_alloc_opt_13.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR fortran/51953 +! +! +type t +end type t + +class(t), allocatable :: a, c(:), e(:) +class(t), pointer :: b, d(:) + +allocate (a, b, source=c(1)) +allocate (c(4), d(6), source=e) + +allocate (a, b, mold=f()) +allocate (c(1), d(6), mold=g()) + +allocate (a, b, source=f()) +allocate (c(1), d(6), source=g()) + +contains +function f() + class(t), allocatable :: f +end function +function g() + class(t), allocatable :: g(:) +end function +end diff --git a/Fortran/gfortran/regression/allocate_alloc_opt_14.f90 b/Fortran/gfortran/regression/allocate_alloc_opt_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_alloc_opt_14.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +program p + integer, allocatable :: arr(:) + integer :: stat + character(len=128, kind=4) :: errmsg = ' ' + allocate (arr(3), stat=stat, errmsg=errmsg) ! { dg-error "shall be a scalar default CHARACTER" } + print *, allocated(arr), stat, trim(errmsg) +end diff --git a/Fortran/gfortran/regression/allocate_alloc_opt_15.f90 b/Fortran/gfortran/regression/allocate_alloc_opt_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_alloc_opt_15.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } +! PR fortran/91300 - runtime error message with allocate and errmsg= +! Contributed by zed.three + +program bigarray_prog + use, intrinsic :: iso_c_binding, only: C_INTPTR_T + implicit none + real(4), dimension(:), allocatable :: array, bigarray + integer :: stat1, stat2 + character(len=100) :: errmsg1, errmsg2 + character(*), parameter :: no_error = "no error" + integer(8), parameter :: n1 = huge (1_4) / 3 ! request more than 2GB + integer(8), parameter :: n2 = huge (1_C_INTPTR_T) / 4 ! "safe" for 64bit + integer(8), parameter :: bignumber = max (n1, n2) + + stat1 = -1 + stat2 = -1 + errmsg1 = no_error + errmsg2 = no_error + allocate (array(1), stat=stat1, errmsg=errmsg1) + if (stat1 /= 0 ) stop 1 + if (errmsg1 /= no_error) stop 1 + + ! Obtain stat, errmsg for attempt to allocate an allocated object + allocate (array(1), stat=stat1, errmsg=errmsg1) + if (stat1 == 0 ) stop 2 + if (errmsg1 == no_error) stop 2 + + ! Try to allocate very large object + allocate (bigarray(bignumber), stat=stat2, errmsg=errmsg2) + if (stat2 /= 0) then + print *, "stat1 =", stat1 + print *, "errmsg: ", trim (errmsg1) + print *, "stat2 =", stat2 + print *, "errmsg: ", trim (errmsg2) + ! Ensure different results for stat, errmsg variables (all compilers) + if (stat2 == stat1 ) stop 3 + if (errmsg2 == no_error .or. errmsg2 == errmsg1) stop 4 + + ! Finally verify gfortran-specific error messages + if (errmsg1 /= "Attempt to allocate an allocated object") stop 5 + if (errmsg2 /= "Insufficient virtual memory" ) stop 6 + end if + +end program bigarray_prog + +! { dg-final { scan-tree-dump-times "Attempt to allocate an allocated object" 4 "original" } } +! { dg-final { scan-tree-dump-times "Insufficient virtual memory" 4 "original" } } diff --git a/Fortran/gfortran/regression/allocate_alloc_opt_2.f90 b/Fortran/gfortran/regression/allocate_alloc_opt_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_alloc_opt_2.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +subroutine sub(i, j, err) + implicit none + character(len=*), intent(in) :: err + integer, intent(in) :: j + integer, intent(in), allocatable :: i(:) + integer, allocatable :: m(:) + integer n + allocate(i(2)) ! { dg-error "variable definition context" } + allocate(m(2), stat=j) ! { dg-error "variable definition context" } + allocate(m(2),stat=n,errmsg=err) ! { dg-error "variable definition context" } +end subroutine sub diff --git a/Fortran/gfortran/regression/allocate_alloc_opt_3.f90 b/Fortran/gfortran/regression/allocate_alloc_opt_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_alloc_opt_3.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +program a + + implicit none + + integer n + character(len=70) e1 + character(len=30) e2 + integer, allocatable :: i(:) + + e1 = 'No error' + allocate(i(4), stat=n, errmsg=e1) + if (trim(e1) /= 'No error') STOP 1 + deallocate(i) + + e2 = 'No error' + allocate(i(4),stat=n, errmsg=e2) + if (trim(e2) /= 'No error') STOP 2 + deallocate(i) + + + e1 = 'No error' + allocate(i(4), stat=n, errmsg=e1) + allocate(i(4), stat=n, errmsg=e1) + if (trim(e1) /= 'Attempt to allocate an allocated object') STOP 3 + deallocate(i) + + e2 = 'No error' + allocate(i(4), stat=n, errmsg=e2) + allocate(i(4), stat=n, errmsg=e2) + if (trim(e2) /= 'Attempt to allocate an allocat') STOP 4 + +end program a diff --git a/Fortran/gfortran/regression/allocate_alloc_opt_4.f90 b/Fortran/gfortran/regression/allocate_alloc_opt_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_alloc_opt_4.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +program a + + implicit none + + integer n, m(3,3) + integer(kind=8) k + integer, allocatable :: i(:), j(:) + real, allocatable :: x(:) + + n = 42 + m = n + k = 1_8 + + allocate(i(4), source=42, source=n) ! { dg-error "Redundant SOURCE tag found" } + + allocate(integer(4) :: i(4), source=n) ! { dg-error "conflicts with the typespec" } + + allocate(i(4), j(n), source=n) ! { dg-error "Fortran 2008: SOURCE tag at .1. with more than a single allocate object" } + + allocate(x(4), source=n) ! { dg-error "type incompatible with" } + + allocate(i(4), source=m) ! { dg-error "must be scalar or have the same rank" } + + allocate(i(4), source=k) ! { dg-error "shall have the same kind type" } + +end program a diff --git a/Fortran/gfortran/regression/allocate_alloc_opt_5.f90 b/Fortran/gfortran/regression/allocate_alloc_opt_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_alloc_opt_5.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +program a + + implicit none + + integer n + character(len=70) str + integer, allocatable :: i(:) + + n = 42 + allocate(i(4), source=n) ! { dg-error "Fortran 2003: SOURCE tag" } + allocate(i(4), stat=n, errmsg=str) ! { dg-error "Fortran 2003: ERRMSG tag" } + +end program a diff --git a/Fortran/gfortran/regression/allocate_alloc_opt_6.f90 b/Fortran/gfortran/regression/allocate_alloc_opt_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_alloc_opt_6.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +program a + + implicit none + + type :: mytype + real :: r + integer :: i + end type mytype + + integer n + integer, allocatable :: i(:) + real z + real, allocatable :: x(:) + type(mytype), pointer :: t + + n = 42 + z = 99. + + allocate(i(4), source=n) + if (any(i /= 42)) STOP 1 + + allocate(x(4), source=z) + if (any(x /= 99.)) STOP 2 + + allocate(t, source=mytype(1.0,2)) + if (t%r /= 1. .or. t%i /= 2) STOP 3 + + deallocate(i) + allocate(i(3), source=(/1, 2, 3/)) + if (i(1) /= 1 .or. i(2) /= 2 .or. i(3) /= 3) STOP 4 + + call sub1(i) + +end program a + +subroutine sub1(j) + integer, intent(in) :: j(*) + integer, allocatable :: k(:) + allocate(k(2), source=j(1:2)) + if (k(1) /= 1 .or. k(2) /= 2) STOP 5 +end subroutine sub1 diff --git a/Fortran/gfortran/regression/allocate_alloc_opt_7.f90 b/Fortran/gfortran/regression/allocate_alloc_opt_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_alloc_opt_7.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! +! PR 44207: ICE with ALLOCATABLE components and SOURCE +! +! Contributed by Hans-Werner Boschmann + +program ice_prog + +type::ice_type + integer,dimension(:),allocatable::list +end type ice_type + +type(ice_type)::this +integer::dim=10,i + +allocate(this%list(dim),source=[(i,i=1,dim)]) + +end program ice_prog diff --git a/Fortran/gfortran/regression/allocate_alloc_opt_8.f90 b/Fortran/gfortran/regression/allocate_alloc_opt_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_alloc_opt_8.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR 43388: [F2008][OOP] ALLOCATE with MOLD= +! +! Contributed by Janus Weil + +type :: t +end type + +class(t),allocatable :: x +type(t) :: z + +allocate(x,MOLD=z) ! { dg-error "MOLD tag at" } + +end diff --git a/Fortran/gfortran/regression/allocate_alloc_opt_9.f90 b/Fortran/gfortran/regression/allocate_alloc_opt_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_alloc_opt_9.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! PR 43388: [F2008][OOP] ALLOCATE with MOLD= +! +! Contributed by Janus Weil + +type :: t +end type + +type :: u +end type + +class(t),allocatable :: x +type(t) :: z1,z2 +type(u) :: z3 + +allocate(x,MOLD=z1,MOLD=z2) ! { dg-error "Redundant MOLD tag" } +allocate(x,SOURCE=z1,MOLD=z2) ! { dg-error "conflicts with SOURCE tag" } +allocate(t::x,MOLD=z1) ! { dg-error "conflicts with the typespec" } + +allocate(x,MOLD=z3) ! { dg-error "is type incompatible" } + +end diff --git a/Fortran/gfortran/regression/allocate_assumed_charlen_1.f90 b/Fortran/gfortran/regression/allocate_assumed_charlen_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_assumed_charlen_1.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! +! PR82934: Segfault on compilation in trans-stmt.c:5919(8.0.0). +! The original report only had one item in the allocate list. This +! has been doubled up to verify that the correct string length is +! is used in the allocation. +! +! Contributed by FortranFan on clf. +! + character(len=42), allocatable :: foo + character(len=22), allocatable :: foofoo + + call alloc( foo , foofoo) + + if (len(foo) .ne. 42) STOP 1 + if (len(foofoo) .ne. 22) STOP 2 + +contains + + subroutine alloc( bar, barbar ) + + character(len=*), allocatable :: bar, barbar + + allocate( character(len=*) :: bar , barbar) ! <= Here! + + end subroutine + +end diff --git a/Fortran/gfortran/regression/allocate_assumed_charlen_2.f90 b/Fortran/gfortran/regression/allocate_assumed_charlen_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_assumed_charlen_2.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! PR fortran/82934 +! PR fortran/83318 +program a + character(len=42), allocatable :: f + character(len=22), allocatable :: ff + call alloc(f, ff) + if (len(f) .ne. 42) STOP 1 + if (len(ff) .ne. 22) STOP 2 +contains + subroutine alloc( a, b ) + character(len=*), allocatable :: a + character(len=22), allocatable :: b + character(len=:), allocatable :: c + character, allocatable :: d + allocate(character(len=*)::a,b) ! { dg-error "Incompatible allocate-object" } + allocate(character(len=*)::c) ! { dg-error "Incompatible allocate-object" } + allocate(character(len=*)::d) ! { dg-error "Incompatible allocate-object" } + end subroutine +end program a diff --git a/Fortran/gfortran/regression/allocate_assumed_charlen_3.f90 b/Fortran/gfortran/regression/allocate_assumed_charlen_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_assumed_charlen_3.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR Fortran/83741 +! Contributed by Gerhard Steinmetz +program p + allocate (character(*) :: x) ! { dg-error "Incompatible allocate-object" } +end + diff --git a/Fortran/gfortran/regression/allocate_assumed_charlen_4.f90 b/Fortran/gfortran/regression/allocate_assumed_charlen_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_assumed_charlen_4.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! +! Test the fix for PR82923, in which an ICE occurred because the +! character length from 'getchars' scope was being used in the +! automatic allocation of 'mine'. +! +! Contributed by "Werner Blokbuster" +! +module m + implicit none +contains + function getchars(my_len,my_size) + integer, intent(in) :: my_len, my_size + character(my_len) :: getchars(my_size) + getchars = 'A-' + end function getchars + + function getchars2(my_len) + integer, intent(in) :: my_len + character(my_len) :: getchars2 + getchars2 = 'B--' + end function getchars2 +end module m + +program testca + use m, only: getchars, getchars2 + implicit none + character(:), allocatable :: mine(:) + character(:), allocatable :: mine2 + integer :: i + + ! ICE occured at this line: + mine = getchars(2,4) + if (any (mine .ne. [('A-', i = 1, 4)])) stop 1 + + ! The scalar version was fine and this will keep it so: + mine2 = getchars2(3) + if (mine2 .ne. 'B--') stop 2 +end program testca diff --git a/Fortran/gfortran/regression/allocate_char_star_scalar_1.f90 b/Fortran/gfortran/regression/allocate_char_star_scalar_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_char_star_scalar_1.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! Tests the patch for PR26038 that used to ICE in gfc_trans_allocate +! for the want of a string_length to pass to the library. +! Contributed by hjl@lucon.org && Erik Edelmann +module moo + +contains + + subroutine foo(self) + character(*) :: self + pointer :: self + + nullify(self) + allocate(self) ! Used to ICE here + print *, len(self) + end subroutine + +end module moo + + +program hum + + use moo + + character(5), pointer :: p + character(10), pointer :: q + + call foo(p) + call foo(q) + +end program hum diff --git a/Fortran/gfortran/regression/allocate_class_1.f90 b/Fortran/gfortran/regression/allocate_class_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_class_1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! PR 47085: [OOP] Problem in allocate( SOURCE=) for polymorphic component +! +! Contributed by Janus Weil + + type :: t0 + end type + class(t0) :: x ! { dg-error "must be dummy, allocatable or pointer" } + allocate(x) ! { dg-error "is neither a data pointer nor an allocatable variable" } + end diff --git a/Fortran/gfortran/regression/allocate_class_2.f90 b/Fortran/gfortran/regression/allocate_class_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_class_2.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR 52552: [OOP] ICE when trying to allocate non-allocatable object giving a dynamic type +! +! Contributed by + + + type t + integer :: i + end type + + class(t) :: o ! { dg-error "must be dummy, allocatable or pointer" } + + allocate(t::o) ! { dg-error "is neither a data pointer nor an allocatable variable" } + +end diff --git a/Fortran/gfortran/regression/allocate_class_3.f90 b/Fortran/gfortran/regression/allocate_class_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_class_3.f90 @@ -0,0 +1,107 @@ +! { dg-do run } +! Tests the fix for PR59414, comment #3, in which the allocate +! expressions were not correctly being stripped to provide the +! vpointer as an lhs to the pointer assignment of the vptr from +! the SOURCE expression. +! +! Contributed by Antony Lewis +! +module ObjectLists + implicit none + + type :: t + integer :: i + end type + + type Object_array_pointer + class(t), pointer :: p(:) + end type + +contains + + subroutine AddArray1 (P, Pt) + class(t) :: P(:) + class(Object_array_pointer) :: Pt + + select type (Pt) + class is (Object_array_pointer) + if (associated (Pt%P)) deallocate (Pt%P) + allocate(Pt%P(1:SIZE(P)), source=P) + end select + end subroutine + + subroutine AddArray2 (P, Pt) + class(t) :: P(:) + class(Object_array_pointer) :: Pt + + select type (Pt) + type is (Object_array_pointer) + if (associated (Pt%P)) deallocate (Pt%P) + allocate(Pt%P(1:SIZE(P)), source=P) + end select + end subroutine + + subroutine AddArray3 (P, Pt) + class(t) :: P + class(Object_array_pointer) :: Pt + + select type (Pt) + class is (Object_array_pointer) + if (associated (Pt%P)) deallocate (Pt%P) + allocate(Pt%P(1:4), source=P) + end select + end subroutine + + subroutine AddArray4 (P, Pt) + type(t) :: P(:) + class(Object_array_pointer) :: Pt + + select type (Pt) + class is (Object_array_pointer) + if (associated (Pt%P)) deallocate (Pt%P) + allocate(Pt%P(1:SIZE(P)), source=P) + end select + end subroutine +end module + + use ObjectLists + type(Object_array_pointer), pointer :: Pt + class(t), pointer :: P(:) + + allocate (P(2), source = [t(1),t(2)]) + allocate (Pt, source = Object_array_pointer(NULL())) + call AddArray1 (P, Pt) + select type (x => Pt%p) + type is (t) + if (any (x%i .ne. [1,2])) STOP 1 + end select + deallocate (P) + deallocate (pt) + + allocate (P(3), source = [t(3),t(4),t(5)]) + allocate (Pt, source = Object_array_pointer(NULL())) + call AddArray2 (P, Pt) + select type (x => Pt%p) + type is (t) + if (any (x%i .ne. [3,4,5])) STOP 2 + end select + deallocate (P) + deallocate (pt) + + allocate (Pt, source = Object_array_pointer(NULL())) + call AddArray3 (t(6), Pt) + select type (x => Pt%p) + type is (t) + if (any (x%i .ne. [6,6,6,6])) STOP 3 + end select + deallocate (pt) + + allocate (Pt, source = Object_array_pointer(NULL())) + call AddArray4 ([t(7), t(8)], Pt) + select type (x => Pt%p) + type is (t) + if (any (x%i .ne. [7,8])) STOP 4 + end select + deallocate (pt) + end + diff --git a/Fortran/gfortran/regression/allocate_class_4.f90 b/Fortran/gfortran/regression/allocate_class_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_class_4.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! +! Part of PR 51946, but breaks easily, therefore introduce its own test +! Authors: Damian Rouson , +! Dominique Pelletier +! Contributed by: Andre Vehreschild + +module integrable_model_module + + implicit none + + type, abstract, public :: integrable_model + contains + procedure(default_constructor), deferred :: empty_instance + end type + + abstract interface + function default_constructor(this) result(blank_slate) + import :: integrable_model + class(integrable_model), intent(in) :: this + class(integrable_model), allocatable :: blank_slate + end function + end interface + + contains + + subroutine integrate(this) + class(integrable_model), intent(inout) :: this + class(integrable_model), allocatable :: residual + allocate(residual, source=this%empty_instance()) + end subroutine + +end module integrable_model_module diff --git a/Fortran/gfortran/regression/allocate_deferred_char_scalar_1.f03 b/Fortran/gfortran/regression/allocate_deferred_char_scalar_1.f03 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_deferred_char_scalar_1.f03 @@ -0,0 +1,269 @@ +! { dg-do run } +! +! Automatic reallocate on assignment, deferred length parameter for char +! +! PR fortran/45170 +! PR fortran/35810 +! PR fortran/47350 +! +! Contributed by Tobias Burnus +! +program test + implicit none + call mold_check() + call mold_check4() + call source_check() + call source_check4() + call ftn_test() + call ftn_test4() + call source3() +contains + subroutine source_check() + character(len=:), allocatable :: str, str2 + target :: str + character(len=8) :: str3 + character(len=:), pointer :: str4, str5 + nullify(str4) + str3 = 'AbCdEfGhIj' + if(allocated(str)) STOP 1 + allocate(str, source=str3) + if(.not.allocated(str)) STOP 2 + if(len(str) /= 8) STOP 3 + if(str /= 'AbCdEfGh') STOP 4 + if(associated(str4)) STOP 5 + str4 => str + if(str4 /= str .or. len(str4)/=8) STOP 6 + if(.not.associated(str4, str)) STOP 7 + str4 => null() + str = '12a56b78' + if(str4 == '12a56b78') STOP 8 + str4 = 'ABCDEFGH' + if(str == 'ABCDEFGH') STOP 9 + allocate(str5, source=str) + if(associated(str5, str)) STOP 10 + if(str5 /= '12a56b78' .or. len(str5)/=8) STOP 11 + str = 'abcdef' + if(str5 == 'abcdef') STOP 12 + str5 = 'ABCDEF' + if(str == 'ABCDEF') STOP 13 + end subroutine source_check + subroutine source_check4() + character(kind=4,len=:), allocatable :: str, str2 + target :: str + character(kind=4,len=8) :: str3 + character(kind=4,len=:), pointer :: str4, str5 + nullify(str4) + str3 = 4_'AbCdEfGhIj' + if(allocated(str)) STOP 14 + allocate(str, source=str3) + if(.not.allocated(str)) STOP 15 + if(len(str) /= 8) STOP 16 + if(str /= 4_'AbCdEfGh') STOP 17 + if(associated(str4)) STOP 18 + str4 => str + if(str4 /= str .or. len(str4)/=8) STOP 19 + if(.not.associated(str4, str)) STOP 20 + str4 => null() + str = 4_'12a56b78' + if(str4 == 4_'12a56b78') STOP 21 + str4 = 4_'ABCDEFGH' + if(str == 4_'ABCDEFGH') STOP 22 + allocate(str5, source=str) + if(associated(str5, str)) STOP 23 + if(str5 /= 4_'12a56b78' .or. len(str5)/=8) STOP 24 + str = 4_'abcdef' + if(str5 == 4_'abcdef') STOP 25 + str5 = 4_'ABCDEF' + if(str == 4_'ABCDEF') STOP 26 + end subroutine source_check4 + subroutine mold_check() + character(len=:), allocatable :: str, str2 + character(len=8) :: str3 + character(len=:), pointer :: str4, str5 + nullify(str4) + str2 = "ABCE" + ALLOCATE( str, MOLD=str3) + if (len(str) /= 8) STOP 27 + DEALLOCATE(str) + ALLOCATE( str, MOLD=str2) + if (len(str) /= 4) STOP 28 + + IF (associated(str4)) STOP 29 + ALLOCATE( str4, MOLD=str3) + IF (.not.associated(str4)) STOP 30 + str4 = '12345678' + if (len(str4) /= 8) STOP 31 + if(str4 /= '12345678') STOP 32 + DEALLOCATE(str4) + ALLOCATE( str4, MOLD=str2) + str4 = 'ABCD' + if (len(str4) /= 4) STOP 33 + if (str4 /= 'ABCD') STOP 34 + str5 => str4 + if(.not.associated(str4,str5)) STOP 35 + if(len(str5) /= 4 .or. len(str4) /= len(str5)) STOP 36 + if(str5 /= str4) STOP 37 + deallocate(str4) + end subroutine mold_check + subroutine mold_check4() + character(len=:,kind=4), allocatable :: str, str2 + character(len=8,kind=4) :: str3 + character(len=:,kind=4), pointer :: str4, str5 + nullify(str4) + str2 = 4_"ABCE" + ALLOCATE( str, MOLD=str3) + if (len(str) /= 8) STOP 38 + DEALLOCATE(str) + ALLOCATE( str, MOLD=str2) + if (len(str) /= 4) STOP 39 + + IF (associated(str4)) STOP 40 + ALLOCATE( str4, MOLD=str3) + IF (.not.associated(str4)) STOP 41 + str4 = 4_'12345678' + if (len(str4) /= 8) STOP 42 + if(str4 /= 4_'12345678') STOP 43 + DEALLOCATE(str4) + ALLOCATE( str4, MOLD=str2) + str4 = 4_'ABCD' + if (len(str4) /= 4) STOP 44 + if (str4 /= 4_'ABCD') STOP 45 + str5 => str4 + if(.not.associated(str4,str5)) STOP 46 + if(len(str5) /= 4 .or. len(str4) /= len(str5)) STOP 47 + if(str5 /= str4) STOP 48 + deallocate(str4) + end subroutine mold_check4 + subroutine ftn_test() + character(len=:), allocatable :: str_a + character(len=:), pointer :: str_p + nullify(str_p) + call proc_test(str_a, str_p, .false.) + if (str_p /= '123457890abcdef') STOP 49 + if (len(str_p) /= 50) STOP 50 + if (str_a(1:5) /= 'ABCDE ') STOP 51 + if (len(str_a) /= 50) STOP 52 + deallocate(str_p) + str_a = '1245' + if(len(str_a) /= 4) STOP 53 + if(str_a /= '1245') STOP 54 + allocate(character(len=6) :: str_p) + if(len(str_p) /= 6) STOP 55 + str_p = 'AbCdEf' + call proc_test(str_a, str_p, .true.) + if (str_p /= '123457890abcdef') STOP 56 + if (len(str_p) /= 50) STOP 57 + if (str_a(1:5) /= 'ABCDE ') STOP 58 + if (len(str_a) /= 50) STOP 59 + deallocate(str_p) + end subroutine ftn_test + subroutine proc_test(a, p, alloc) + character(len=:), allocatable :: a + character(len=:), pointer :: p + character(len=5), target :: loc + logical :: alloc + if (.not. alloc) then + if(associated(p)) STOP 60 + if(allocated(a)) STOP 61 + else + if(len(a) /= 4) STOP 62 + if(a /= '1245') STOP 63 + if(len(p) /= 6) STOP 64 + if(p /= 'AbCdEf') STOP 65 + deallocate(a) + nullify(p) + end if + allocate(character(len=50) :: a) + a(1:5) = 'ABCDE' + if(len(a) /= 50) STOP 66 + if(a(1:5) /= "ABCDE") STOP 67 + loc = '12345' + p => loc + if (len(p) /= 5) STOP 68 + if (p /= '12345') STOP 69 + p = '12345679' + if (len(p) /= 5) STOP 70 + if (p /= '12345') STOP 71 + p = 'ABC' + if (loc /= 'ABC ') STOP 72 + allocate(p, mold=a) + if (.not.associated(p)) STOP 73 + p = '123457890abcdef' + if (p /= '123457890abcdef') STOP 74 + if (len(p) /= 50) STOP 75 + end subroutine proc_test + subroutine ftn_test4() + character(len=:,kind=4), allocatable :: str_a + character(len=:,kind=4), pointer :: str_p + nullify(str_p) + call proc_test4(str_a, str_p, .false.) + if (str_p /= 4_'123457890abcdef') STOP 76 + if (len(str_p) /= 50) STOP 77 + if (str_a(1:5) /= 4_'ABCDE ') STOP 78 + if (len(str_a) /= 50) STOP 79 + deallocate(str_p) + str_a = 4_'1245' + if(len(str_a) /= 4) STOP 80 + if(str_a /= 4_'1245') STOP 81 + allocate(character(len=6, kind = 4) :: str_p) + if(len(str_p) /= 6) STOP 82 + str_p = 4_'AbCdEf' + call proc_test4(str_a, str_p, .true.) + if (str_p /= 4_'123457890abcdef') STOP 83 + if (len(str_p) /= 50) STOP 84 + if (str_a(1:5) /= 4_'ABCDE ') STOP 85 + if (len(str_a) /= 50) STOP 86 + deallocate(str_p) + end subroutine ftn_test4 + subroutine proc_test4(a, p, alloc) + character(len=:,kind=4), allocatable :: a + character(len=:,kind=4), pointer :: p + character(len=5,kind=4), target :: loc + logical :: alloc + if (.not. alloc) then + if(associated(p)) STOP 87 + if(allocated(a)) STOP 88 + else + if(len(a) /= 4) STOP 89 + if(a /= 4_'1245') STOP 90 + if(len(p) /= 6) STOP 91 + if(p /= 4_'AbCdEf') STOP 92 + deallocate(a) + nullify(p) + end if + allocate(character(len=50,kind=4) :: a) + a(1:5) = 4_'ABCDE' + if(len(a) /= 50) STOP 93 + if(a(1:5) /= 4_"ABCDE") STOP 94 + loc = '12345' + p => loc + if (len(p) /= 5) STOP 95 + if (p /= 4_'12345') STOP 96 + p = 4_'12345679' + if (len(p) /= 5) STOP 97 + if (p /= 4_'12345') STOP 98 + p = 4_'ABC' + if (loc /= 4_'ABC ') STOP 99 + allocate(p, mold=a) + if (.not.associated(p)) STOP 100 + p = 4_'123457890abcdef' + if (p /= 4_'123457890abcdef') STOP 101 + if (len(p) /= 50) STOP 102 + end subroutine proc_test4 + subroutine source3() + character(len=:, kind=1), allocatable :: a1 + character(len=:, kind=4), allocatable :: a4 + character(len=:, kind=1), pointer :: p1 + character(len=:, kind=4), pointer :: p4 + allocate(a1, source='ABC') ! << ICE + if(len(a1) /= 3 .or. a1 /= 'ABC') STOP 103 + allocate(a4, source=4_'12345') ! << ICE + if(len(a4) /= 5 .or. a4 /= 4_'12345') STOP 104 + allocate(p1, mold='AB') ! << ICE + if(len(p1) /= 2) STOP 105 + allocate(p4, mold=4_'145') ! << ICE + if(len(p4) /= 3) STOP 106 + end subroutine source3 +end program test +! Spurious -Wstringop-overflow warning with -O1 +! { dg-prune-output "\\\[-Wstringop-overflow=]" } diff --git a/Fortran/gfortran/regression/allocate_deferred_char_scalar_2.f03 b/Fortran/gfortran/regression/allocate_deferred_char_scalar_2.f03 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_deferred_char_scalar_2.f03 @@ -0,0 +1,21 @@ +! { dg-do run } +! Test the fix for PR47519, in which the character length was not +! calculated for the SOURCE expressions below and an ICE resulted. +! +! Contributed by Tobias Burnus +! +program note7_35 + implicit none + character(:), allocatable :: name + character(:), allocatable :: src + integer n + n = 10 + allocate(name, SOURCE=repeat('x',n)) + if (name .ne. 'xxxxxxxxxx') STOP 1 + if (len (name) .ne. 10 ) STOP 2 + deallocate(name) + src = 'xyxy' + allocate(name, SOURCE=repeat(src,n)) + if (name(37:40) .ne. 'xyxy') STOP 3 + if (len (name) .ne. 40 ) STOP 4 +end program note7_35 diff --git a/Fortran/gfortran/regression/allocate_derived_1.f90 b/Fortran/gfortran/regression/allocate_derived_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_derived_1.f90 @@ -0,0 +1,50 @@ +! { dg-do compile } +! +! ALLOCATE statements with derived type specification +! +! Contributed by Janus Weil + + type :: t1 + integer :: i + end type + + type, extends(t1) :: t2 + real :: r + end type + + type, extends(t2) :: t3 + real :: q + end type + + type, abstract :: u0 + logical :: nothing + end type + + type :: v1 + real :: r + end type + + class(t1),dimension(:),allocatable :: x + type(t2),dimension(:),allocatable :: y + class(t3),dimension(:),allocatable :: z + + allocate( x(1)) + allocate(t1 :: x(2)) + allocate(t2 :: x(3)) + allocate(t3 :: x(4)) + allocate(tx :: x(5)) ! { dg-error "Error in type-spec at" } + allocate(u0 :: x(6)) ! { dg-error "may not be ABSTRACT" } + allocate(v1 :: x(7)) ! { dg-error "is type incompatible with typespec" } + + allocate( y(1)) + allocate(t1 :: y(2)) ! { dg-error "is type incompatible with typespec" } + allocate(t2 :: y(3)) + allocate(t3 :: y(3)) ! { dg-error "is type incompatible with typespec" } + + allocate( z(1)) + allocate(t1 :: z(2)) ! { dg-error "is type incompatible with typespec" } + allocate(t2 :: z(3)) ! { dg-error "is type incompatible with typespec" } + allocate(t3 :: z(4)) + +end + diff --git a/Fortran/gfortran/regression/allocate_derived_2.f90 b/Fortran/gfortran/regression/allocate_derived_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_derived_2.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! +! PR 42888: [4.5 Regression] ICE in fold_convert_loc, at fold-const.c:2670 +! +! Contributed by Harald Anlauf + + implicit none + + type t + integer :: X = -999.0 ! Real initializer! + end type t + + type(t), allocatable :: x + class(t), allocatable :: y,z + + allocate (x) + allocate (y) + allocate (t::z) + +end diff --git a/Fortran/gfortran/regression/allocate_derived_3.f90 b/Fortran/gfortran/regression/allocate_derived_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_derived_3.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! +! PR 44929: [OOP] Parsing error of derived type name starting with 'REAL' +! +! Contributed by Satish.BD + + type :: real_type + end type + class(real_type), allocatable :: obj + real(8), allocatable :: r8 + + allocate(real_type :: obj) + + allocate( real(kind=8) :: r8) + allocate(real(8) :: r8 ) + +end diff --git a/Fortran/gfortran/regression/allocate_derived_4.f90 b/Fortran/gfortran/regression/allocate_derived_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_derived_4.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! PR 45577: [4.6 Regression] Bogus(?) "... type incompatible with source-expr ..." error +! +! Contributed by Dominique d'Humieres + +program main + +type b_obj + integer,allocatable :: c(:) + real :: r = 5. +end type b_obj + +type (b_obj),allocatable :: b(:) +integer,allocatable :: c(:) + +allocate(b(3),c(3)) + +end program main diff --git a/Fortran/gfortran/regression/allocate_derived_5.f90 b/Fortran/gfortran/regression/allocate_derived_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_derived_5.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! +! PR 45828: [4.6 Regression] No default initialization of derived type members? +! +! Contributed by Juha + +program fail1 + type a + integer :: i + end type a + + type b + type(a) :: acomp = a(5) + end type b + + type(b), allocatable :: c(:) + + allocate(c(1)) + if (c(1) % acomp % i /= 5) STOP 1 +end program fail1 diff --git a/Fortran/gfortran/regression/allocate_error_1.f90 b/Fortran/gfortran/regression/allocate_error_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_error_1.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! { dg-shouldfail "runtime error" } +! { dg-output "At line 13.*Attempting to allocate .* 'arr'" } + +! PR fortran/37507 +! Check that locus is printed for ALLOCATE errors. + +PROGRAM main + IMPLICIT NONE + INTEGER, ALLOCATABLE :: arr(:) + + ALLOCATE (arr(5)) + ALLOCATE (arr(6)) +END PROGRAM main diff --git a/Fortran/gfortran/regression/allocate_error_2.f90 b/Fortran/gfortran/regression/allocate_error_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_error_2.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +program main + type t1 + integer, allocatable :: x(:) + integer, allocatable :: y(:) + end type t1 + type(t1), allocatable :: v(:) + allocate (v(3), v(4)) ! { dg-error "Allocate-object at \\(1\\) also appears at \\(2\\)" } + allocate (v(1), v(1)%x(2)) ! { dg-error "Allocate-object at \\(1\\) is subobject of object at \\(2\\)" } + allocate (v(1)%x(2), v(1)) ! { dg-error "Allocate-object at \\(1\\) is subobject of object at \\(2\\)" } + allocate (v(1)%y(2), v(1)%x(1)) + allocate (v(2)%x(3), v(2)%x(3)) ! { dg-error "Allocate-object at \\(1\\) also appears at \\(2\\)" } + allocate (v(1)%x(3), v(2)%x(3)) + deallocate (v, v) ! { dg-error "Allocate-object at \\(1\\) also appears at \\(2\\)" } + deallocate (v, v(1)%x) ! { dg-error "Allocate-object at \\(1\\) is subobject of object at \\(2\\)" } + deallocate (v(1)%x, v) ! { dg-error "Allocate-object at \\(1\\) is subobject of object at \\(2\\)" } + deallocate (v(1)%y, v(1)%x) + deallocate (v(2)%x, v(2)%x) ! { dg-error "Allocate-object at \\(1\\) also appears at \\(2\\)" } + deallocate (v(1)%x, v(2)%x) +end program main diff --git a/Fortran/gfortran/regression/allocate_error_3.f90 b/Fortran/gfortran/regression/allocate_error_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_error_3.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! +! PR 49708: [4.5/4.6/4.7 Regression] ICE with allocate and no dimensions +! +! Contributed by + + real, pointer :: x(:) + allocate(x) ! { dg-error "Array specification required" } +end diff --git a/Fortran/gfortran/regression/allocate_error_4.f90 b/Fortran/gfortran/regression/allocate_error_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_error_4.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! PR fortran/55314 - the second allocate statement was rejected. + +program main + implicit none + integer :: max_nb + type comm_mask + integer(4), pointer :: mask(:) + end type comm_mask + type (comm_mask), allocatable, save :: encode(:,:) + max_nb=2 + allocate( encode(1:1,1:max_nb)) + allocate( encode(1,1)%mask(1),encode(1,2)%mask(1)) + deallocate( encode(1,1)%mask,encode(1,2)%mask) + allocate( encode(1,1)%mask(1),encode(1,1)%mask(1)) ! { dg-error "also appears at" } +end program main diff --git a/Fortran/gfortran/regression/allocate_error_5.f90 b/Fortran/gfortran/regression/allocate_error_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_error_5.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! { dg-additional-options "-fcheck=mem" } +! { dg-shouldfail "Fortran runtime error: Assignment of scalar to unallocated array" } +! +! This omission was encountered in the course of fixing PR54070. Whilst this is a +! very specific case, others such as allocatable components have been tested. +! +! Contributed by Tobias Burnus +! +function g(a) result (res) + character(len=*) :: a + character(len=:),allocatable :: res(:) + res = a ! Since 'res' is not allocated, a runtime error should occur. +end function + + interface + function g(a) result(res) + character(len=*) :: a + character(len=:),allocatable :: res(:) + end function + end interface + print *, g("ABC") +end diff --git a/Fortran/gfortran/regression/allocate_error_6.f90 b/Fortran/gfortran/regression/allocate_error_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_error_6.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! { dg-additional-options "-fcheck=mem" } +! { dg-shouldfail "Fortran runtime error: Assignment of scalar to unallocated array" } +! +! This omission was encountered in the course of fixing PR54070. Whilst this is a +! very specific case, others such as allocatable components have been tested. +! +! Contributed by Tobias Burnus +! +function g(a) result (res) + real :: a + real,allocatable :: res(:) + res = a ! Since 'res' is not allocated, a runtime error should occur. +end function + + interface + function g(a) result(res) + real :: a + real,allocatable :: res(:) + end function + end interface +! print *, g(2.0) +! call foo + call foofoo +contains + subroutine foo + type bar + real, allocatable, dimension(:) :: r + end type + type (bar) :: foobar + foobar%r = 1.0 + end subroutine + subroutine foofoo + type barfoo + character(:), allocatable, dimension(:) :: c + end type + type (barfoo) :: foobarfoo + foobarfoo%c = "1.0" + end subroutine +end diff --git a/Fortran/gfortran/regression/allocate_error_7.f90 b/Fortran/gfortran/regression/allocate_error_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_error_7.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! +! Code contributed by Gerhard Steinmetz +! +program pr82620 + type t(a) + integer, len :: a + end type + type(t(:)), allocatable :: x, y + allocate(t(4) :: x) + allocate)t(7) :: y) ! { dg-error "Syntax error in ALLOCATE" } +end program pr82620 diff --git a/Fortran/gfortran/regression/allocate_scalar_with_shape.f90 b/Fortran/gfortran/regression/allocate_scalar_with_shape.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_scalar_with_shape.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR fortran/41940 + +integer, allocatable :: a +TYPE :: x + integer, allocatable :: a +END TYPE +TYPE (x) :: y + +allocate(a(4)) ! { dg-error "Shape specification for allocatable scalar" } +allocate(y%a(4)) ! { dg-error "Shape specification for allocatable scalar" } +end + diff --git a/Fortran/gfortran/regression/allocate_stat.f90 b/Fortran/gfortran/regression/allocate_stat.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_stat.f90 @@ -0,0 +1,76 @@ +! { dg-do compile } +! PR fortran/32936 +! +! +function all_res() + implicit none + real, pointer :: gain + integer :: all_res + allocate (gain,STAT=all_res) + deallocate(gain) + call bar() +contains + subroutine bar() + real, pointer :: gain2 + allocate (gain2,STAT=all_res) + deallocate(gain2) + end subroutine bar +end function all_res + +function func() + implicit none + real, pointer :: gain + integer :: all_res2, func + func = 0 +entry all_res2 + allocate (gain,STAT=all_res2) + deallocate(gain) +contains + subroutine test + implicit none + real, pointer :: gain2 + allocate (gain2,STAT=all_res2) + deallocate(gain2) + end subroutine test +end function func + +function func2() result(res) + implicit none + real, pointer :: gain + integer :: res + allocate (gain,STAT=func2) ! { dg-error "requires an argument list" } + deallocate(gain) + res = 0 +end function func2 + +subroutine sub() + implicit none + interface + integer function func2() + end function + end interface + real, pointer :: gain + integer, parameter :: res = 2 + allocate (gain,STAT=func2) ! { dg-error "requires an argument list" } + deallocate(gain) +end subroutine sub + +module test +contains + function one() + integer :: one, two + integer, pointer :: ptr + allocate(ptr, stat=one) + if(one == 0) deallocate(ptr) + entry two + allocate(ptr, stat=two) + if(associated(ptr)) deallocate(ptr) + end function one + subroutine sub() + integer, pointer :: p + allocate(p, stat=one) ! { dg-error "requires an argument list" } + if(associated(p)) deallocate(p) + allocate(p, stat=two) ! { dg-error "requires an argument list" } + if(associated(p)) deallocate(p) + end subroutine sub +end module test diff --git a/Fortran/gfortran/regression/allocate_stat_2.f90 b/Fortran/gfortran/regression/allocate_stat_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_stat_2.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR 41197 +program main + integer, dimension (4) :: ier = 0 + character(len=30), dimension(2) :: er + integer, dimension (:), allocatable :: a + allocate (a (16), stat = ier) ! { dg-error "must be a scalar INTEGER" } + allocate (a (14), stat=ier(1),errmsg=er) ! { dg-error "shall be a scalar default CHARACTER" } +end + diff --git a/Fortran/gfortran/regression/allocate_stat_3.f90 b/Fortran/gfortran/regression/allocate_stat_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_stat_3.f90 @@ -0,0 +1,71 @@ +! { dg-do compile } +! PR fortran/101564 - ICE in resolve_allocate_deallocate + +program p + implicit none + integer, allocatable :: x(:) + integer :: stat + integer, pointer :: A + integer, target :: ptr + real, target :: r + character(80) :: c + type t + integer :: stat + real :: r + complex :: z + end type t + type(t), allocatable :: y + type tc + character(len=:), allocatable :: s + end type tc + type(tc) :: z + allocate (character(42) :: z%s, stat=stat) + allocate (x(2), stat=stat) + deallocate (x, stat=stat) + allocate (A, stat=f()) + deallocate (A, stat=f()) + allocate (A, stat=y%stat) + deallocate (A, stat=y%stat) + allocate (A, stat=stat, errmsg=c(2:79)) + deallocate (A, stat=stat, errmsg=c(2:79)) + allocate (A, stat=stat, errmsg=z%s) + deallocate (A, stat=stat, errmsg=z%s) + allocate (A, stat=stat, errmsg=z%s(2:39)) + deallocate (A, stat=stat, errmsg=z%s(2:39)) + allocate (A, stat=y%r) ! { dg-error "must be a scalar INTEGER variable" } + deallocate (A, stat=y%r) ! { dg-error "must be a scalar INTEGER variable" } + allocate (x(2), stat=stat%kind) ! { dg-error "STAT tag" } + deallocate (x, stat=stat%kind) ! { dg-error "STAT variable" } + allocate (A, stat=A%kind) ! { dg-error "STAT tag" } + deallocate (A, stat=A%kind) ! { dg-error "STAT variable" } + allocate (A, stat=c%len) ! { dg-error "STAT tag" } + deallocate (A, stat=c%len) ! { dg-error "STAT variable" } + allocate (A, stat=y%stat%kind) ! { dg-error "STAT tag" } + deallocate (A, stat=y%stat%kind) ! { dg-error "STAT variable" } + allocate (y, stat=y%stat) ! { dg-error "within the same ALLOCATE statement" } + allocate (y, stat=r) ! { dg-error "must be a scalar INTEGER variable" } + allocate (A, stat=y%z%re) ! { dg-error "must be a scalar INTEGER variable" } + deallocate (A, stat=y%z%im) ! { dg-error "must be a scalar INTEGER variable" } + allocate (y, stat=g()) ! { dg-error "must be a scalar INTEGER variable" } + deallocate (y, stat=g()) ! { dg-error "must be a scalar INTEGER variable" } + allocate (A, stat=f) ! { dg-error "requires an argument list" } + deallocate (A, stat=f) ! { dg-error "requires an argument list" } + allocate (y, stat=g) ! { dg-error "requires an argument list" } + deallocate (y, stat=g) ! { dg-error "requires an argument list" } + allocate (A, stat=z%s%len) ! { dg-error "parameter inquiry" } + deallocate (A, stat=z%s%len) ! { dg-error "parameter inquiry" } + allocate (A, stat=f(), errmsg="") ! { dg-error "ERRMSG variable" } + deallocate (A, stat=f(), errmsg="") ! { dg-error "ERRMSG variable" } + allocate (A, stat=stat, errmsg=z%s%len) ! { dg-error "ERRMSG variable" } + deallocate (A, stat=stat, errmsg=z%s%len) ! { dg-error "ERRMSG variable" } + deallocate (z%s, stat=stat, errmsg=z%s) ! { dg-error "within the same DEALLOCATE statement" } +contains + integer function f() + pointer :: f + f => ptr + end function f + real function g() + pointer :: g + g => r + end function g +end diff --git a/Fortran/gfortran/regression/allocate_with_arrayspec_1.f90 b/Fortran/gfortran/regression/allocate_with_arrayspec_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_arrayspec_1.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } + +MODULE mo_test + + integer :: n = 0 +CONTAINS + + FUNCTION nquery() + INTEGER :: nquery + WRITE (0,*) "hello!" + n = n + 1 + nquery = n + END FUNCTION nquery + +END MODULE mo_test + + +! ---------------------------------------------------------------------- +! MAIN PROGRAM +! ---------------------------------------------------------------------- +PROGRAM example + USE mo_test + INTEGER, ALLOCATABLE :: query_buf(:) + ALLOCATE(query_buf(nquery())) + if (n /= 1 .or. size(query_buf) /= n) STOP 1 +END PROGRAM example + +! { dg-final { scan-tree-dump-times "nquery" 5 "original" } } diff --git a/Fortran/gfortran/regression/allocate_with_mold_1.f90 b/Fortran/gfortran/regression/allocate_with_mold_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_mold_1.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! +! Fixes a bug that emerged from the fix of PR62044 - see the PR. When +! there was no default initializer, code-expr3 was set null and so the +! vpointer was set to the vtable of the declared type, rather than that +! of the MOLD expression. +! +! Contributed by but based on the original PR62044 testcase by +! Paul Thomas +! +module GridImageSilo_Template + implicit none + type, public, abstract :: GridImageSiloTemplate + end type GridImageSiloTemplate +end module GridImageSilo_Template + +module UnstructuredGridImageSilo_Form + use GridImageSilo_Template + implicit none + type, public, extends ( GridImageSiloTemplate ) :: & + UnstructuredGridImageSiloForm + end type UnstructuredGridImageSiloForm +end module UnstructuredGridImageSilo_Form + +module UnstructuredGridImages + use UnstructuredGridImageSilo_Form, & + UnstructuredGridImageForm => UnstructuredGridImageSiloForm +contains + subroutine foo + class (GridImageSiloTemplate), allocatable :: a + type (UnstructuredGridImageForm) :: b + integer :: i = 0 + allocate (a, mold = b) + select type (a) + type is (UnstructuredGridImageForm) + i = 1 + class default + i = 2 + end select + if (i .ne. 1) STOP 1 + end subroutine +end module UnstructuredGridImages + + use UnstructuredGridImages + call foo +end + diff --git a/Fortran/gfortran/regression/allocate_with_mold_2.f90 b/Fortran/gfortran/regression/allocate_with_mold_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_mold_2.f90 @@ -0,0 +1,62 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Test the fix for PR87284 in which the indexing in allocate with mold +! was incorrect for class array initialization and resulted in the valgrind +! error: +! "Conditional jump or move depends on uninitialised value(s)" at line 42. +! +! Contributed by Andrew Baldwin on clf. +! + MODULE INTS_TYPE_MODULE + TYPE, ABSTRACT :: BASE_TYPE + END TYPE BASE_TYPE + + TYPE, EXTENDS (BASE_TYPE) :: INTS_TYPE + INTEGER, ALLOCATABLE :: INTS(:) + END TYPE INTS_TYPE + CONTAINS + SUBROUTINE MOLD_ALLOCATE (IT_OBJS, MOLD_OBJ) + CLASS (BASE_TYPE), ALLOCATABLE, INTENT (OUT) :: IT_OBJS(:) + CLASS (BASE_TYPE), INTENT (IN) :: MOLD_OBJ + + ALLOCATE (IT_OBJS(2), mold = MOLD_OBJ) + + RETURN + END SUBROUTINE MOLD_ALLOCATE + END MODULE INTS_TYPE_MODULE + + PROGRAM MFE + USE INTS_TYPE_MODULE + IMPLICIT NONE + + CLASS (BASE_TYPE), ALLOCATABLE :: IT_OBJS(:) + INTEGER :: I + TYPE (INTS_TYPE) :: MOLD_OBJ + + ALLOCATE (INTS_TYPE :: IT_OBJS(2)) + + SELECT TYPE (IT_OBJS) + TYPE IS (INTS_TYPE) + ALLOCATE (IT_OBJS(1)%INTS(10)) + + ALLOCATE (IT_OBJS(2)%INTS(10)) + END SELECT + + + DEALLOCATE (IT_OBJS) + + CALL MOLD_ALLOCATE (IT_OBJS, MOLD_OBJ) + + IF (ALLOCATED(IT_OBJS)) THEN + IF (SIZE(IT_OBJS) .GE. 2) THEN + SELECT TYPE (IT_OBJS) + TYPE IS (INTS_TYPE) + ALLOCATE (IT_OBJS(1)%INTS(10)) + + ALLOCATE (IT_OBJS(2)%INTS(10)) + END SELECT + END IF + END IF + END PROGRAM MFE +! { dg-final { scan-tree-dump-times "it_objs->_vptr->_size" 1 "original" } } diff --git a/Fortran/gfortran/regression/allocate_with_mold_3.f90 b/Fortran/gfortran/regression/allocate_with_mold_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_mold_3.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! PR fortran/89174 - this used to segfault on execution. +! Test case by Neil Carlson. +module mod + type :: array_data + class(*), allocatable :: mold + contains + procedure :: push + end type +contains + subroutine push(this, value) + class(array_data), intent(inout) :: this + class(*), intent(in) :: value + allocate(this%mold, mold=value) ! <== SEGFAULTS HERE + end subroutine +end module + +use mod +type(array_data) :: foo +call foo%push(42) +end diff --git a/Fortran/gfortran/regression/allocate_with_mold_4.f90 b/Fortran/gfortran/regression/allocate_with_mold_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_mold_4.f90 @@ -0,0 +1,24 @@ +program A_M + implicit none + real, parameter :: C(5:10) = 5.0 + real, dimension (:), allocatable :: A, B + allocate (A(6)) + call Init (A) +contains + subroutine Init ( A ) + real, dimension ( -1 : ), intent ( in ) :: A + integer, dimension ( 1 ) :: lb_B + + allocate (B, mold = A) + if (any (lbound (B) /= lbound (A))) stop 1 + if (any (ubound (B) /= ubound (A))) stop 2 + if (any (shape (B) /= shape (A))) stop 3 + if (size (B) /= size (A)) stop 4 + deallocate (B) + allocate (B, mold = C) + if (any (lbound (B) /= lbound (C))) stop 5 + if (any (ubound (B) /= ubound (C))) stop 6 + if (any (shape (B) /= shape (C))) stop 7 + if (size (B) /= size (C)) stop 8 +end +end diff --git a/Fortran/gfortran/regression/allocate_with_source_1.f90 b/Fortran/gfortran/regression/allocate_with_source_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_1.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! Test the fix for PR47592, in which the SOURCE expression was +! being called twice. +! +! Contributed by Thomas Koenig +! +module foo + implicit none +contains + function bar() + integer bar + integer :: i=9 + i = i + 1 + bar = i + end function bar +end module foo + +program note7_35 + use foo + implicit none + character(:), allocatable :: name + character(:), allocatable :: src + integer n + n = 10 + allocate(name, SOURCE=repeat('x',bar())) + if (name .ne. 'xxxxxxxxxx') STOP 1 + if (len (name) .ne. 10 ) STOP 2 +end program note7_35 diff --git a/Fortran/gfortran/regression/allocate_with_source_10.f08 b/Fortran/gfortran/regression/allocate_with_source_10.f08 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_10.f08 @@ -0,0 +1,51 @@ +!{ dg-do run } +! +! Testcase for pr66927 +! Contributed by Juergen Reuter + +module processes + implicit none + private + + type :: t1_t + real :: p = 0.0 + end type t1_t + + type :: t2_t + private + type(t1_t), dimension(:), allocatable :: p + contains + procedure :: func => t2_func + end type t2_t + + type, public :: t3_t + type(t2_t), public :: int_born + end type t3_t + + public :: evaluate + +contains + + function t2_func (int) result (p) + class(t2_t), intent(in) :: int + type(t1_t), dimension(:), allocatable :: p + allocate(p(5)) + end function t2_func + + subroutine evaluate (t3) + class(t3_t), intent(inout) :: t3 + type(t1_t), dimension(:), allocatable :: p_born + allocate (p_born(1:size(t3%int_born%func ())), & + source = t3%int_born%func ()) + if (.not. allocated(p_born)) STOP 1 + if (size(p_born) /= 5) STOP 2 + end subroutine evaluate + +end module processes + +program pr66927 +use processes +type(t3_t) :: o +call evaluate(o) +end + diff --git a/Fortran/gfortran/regression/allocate_with_source_11.f08 b/Fortran/gfortran/regression/allocate_with_source_11.f08 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_11.f08 @@ -0,0 +1,51 @@ +!{ dg-do run } +! +! Testcase for pr66927, pr67123 +! Contributed by Juergen Reuter + +module processes + implicit none + private + + type :: t1_t + real :: p = 0.0 + end type t1_t + + type :: t2_t + private + type(t1_t), dimension(:), allocatable :: p + contains + procedure :: func => t2_func + end type t2_t + + type, public :: t3_t + type(t2_t), public :: int_born + end type t3_t + + public :: evaluate + +contains + + function t2_func (int) result (p) + class(t2_t), intent(in) :: int + class(t1_t), dimension(:), allocatable :: p + allocate(p(5)) + end function t2_func + + subroutine evaluate (t3) + class(t3_t), intent(inout) :: t3 + type(t1_t), dimension(:), allocatable :: p_born + allocate (p_born(1:size(t3%int_born%func ())), & + source = t3%int_born%func ()) + if (.not. allocated(p_born)) STOP 1 + if (size(p_born) /= 5) STOP 2 + end subroutine evaluate + +end module processes + +program pr66927 +use processes +type(t3_t) :: o +call evaluate(o) +end + diff --git a/Fortran/gfortran/regression/allocate_with_source_12.f03 b/Fortran/gfortran/regression/allocate_with_source_12.f03 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_12.f03 @@ -0,0 +1,38 @@ +! { dg-do run } +! +! Checks the fix for PR67171, where the second ALLOCATE with and array section +! SOURCE produced a zero index based temporary, which threw the assignment. +! +! Contributed by Anton Shterenlikht +! +program z + implicit none + integer, parameter :: DIM1_SIZE = 10 + real, allocatable :: d(:,:), tmp(:,:) + integer :: i, errstat + + allocate (d(DIM1_SIZE, 2), source = 0.0, stat=errstat ) + + d(:,1) = [( real (i), i=1,DIM1_SIZE)] + d(:,2) = [( real(2*i), i=1,DIM1_SIZE)] +! write (*,*) d(1, :) + + call move_alloc (from = d, to = tmp) +! write (*,*) tmp( 1, :) + + allocate (d(DIM1_SIZE / 2, 2), source = tmp(1 : DIM1_SIZE / 2, :) , stat=errstat) + if (any (d .ne. tmp(1:DIM1_SIZE/2,:))) STOP 1 + deallocate (d) + + allocate (d(DIM1_SIZE / 2, 2), source = foo (tmp(1 : DIM1_SIZE / 2, :)) , stat=errstat) + if (any (d .ne. tmp(1 : DIM1_SIZE / 2, :))) STOP 2 + + deallocate (tmp , d) + +contains + function foo (arg) result (res) + real :: arg(:,:) + real :: res(size (arg, 1), size (arg, 2)) + res = arg + end function +end program z diff --git a/Fortran/gfortran/regression/allocate_with_source_13.f03 b/Fortran/gfortran/regression/allocate_with_source_13.f03 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_13.f03 @@ -0,0 +1,220 @@ +! { dg-do compile } +! +! Tests the fix for PR61819. +! +! Contributed by Salvatore Filippone +! +module foo_base_mod + integer, parameter :: foo_ipk_ = kind(1) + integer, parameter :: foo_dpk_ = kind(1.d0) + type foo_d_base_vect_type + real(foo_dpk_), allocatable :: v(:) + contains + procedure :: free => d_base_free + procedure :: get_vect => d_base_get_vect + procedure :: allocate => d_base_allocate + end type foo_d_base_vect_type + + + type foo_d_vect_type + class(foo_d_base_vect_type), allocatable :: v + contains + procedure :: free => d_vect_free + procedure :: get_vect => d_vect_get_vect + end type foo_d_vect_type + + type foo_desc_type + integer(foo_ipk_) :: nl=-1 + end type foo_desc_type + + +contains + + subroutine foo_init(ictxt) + integer :: ictxt + end subroutine foo_init + + + subroutine foo_exit(ictxt) + integer :: ictxt + end subroutine foo_exit + + subroutine foo_info(ictxt,iam,np) + integer(foo_ipk_) :: ictxt,iam,np + iam = 0 + np = 1 + end subroutine foo_info + + subroutine foo_cdall(ictxt,map,info,nl) + integer(foo_ipk_) :: ictxt, info + type(foo_desc_type) :: map + integer(foo_ipk_), optional :: nl + + if (present(nl)) then + map%nl = nl + else + map%nl = 1 + end if + end subroutine foo_cdall + + subroutine foo_cdasb(map,info) + integer(foo_ipk_) :: info + type(foo_desc_type) :: map + if (map%nl < 0) map%nl=1 + end subroutine foo_cdasb + + + subroutine d_base_allocate(this,n) + class(foo_d_base_vect_type), intent(out) :: this + + allocate(this%v(max(1,n))) + + end subroutine d_base_allocate + + subroutine d_base_free(this) + class(foo_d_base_vect_type), intent(inout) :: this + if (allocated(this%v)) & + & deallocate(this%v) + end subroutine d_base_free + + function d_base_get_vect(this) result(res) + class(foo_d_base_vect_type), intent(inout) :: this + real(foo_dpk_), allocatable :: res(:) + + if (allocated(this%v)) then + res = this%v + else + allocate(res(1)) + end if + end function d_base_get_vect + + subroutine d_vect_free(this) + class(foo_d_vect_type) :: this + if (allocated(this%v)) then + call this%v%free() + deallocate(this%v) + end if + end subroutine d_vect_free + + function d_vect_get_vect(this) result(res) + class(foo_d_vect_type) :: this + real(foo_dpk_), allocatable :: res(:) + + if (allocated(this%v)) then + res = this%v%get_vect() + else + allocate(res(1)) + end if + end function d_vect_get_vect + + subroutine foo_geall(v,map,info) + type(foo_d_vect_type), intent(out) :: v + type(foo_Desc_type) :: map + integer(foo_ipk_) :: info + + allocate(foo_d_base_vect_type :: v%v,stat=info) + if (info == 0) call v%v%allocate(map%nl) + end subroutine foo_geall + +end module foo_base_mod + + +module foo_scalar_field_mod + use foo_base_mod + implicit none + + type scalar_field + type(foo_d_vect_type) :: f + type(foo_desc_type), pointer :: map => null() + contains + procedure :: free + end type + + integer(foo_ipk_), parameter :: nx=4,ny=nx, nz=nx + type(foo_desc_type), allocatable, save, target :: map + integer(foo_ipk_) ,save :: NumMy_xy_planes + integer(foo_ipk_) ,parameter :: NumGlobalElements = nx*ny*nz + integer(foo_ipk_) ,parameter :: NumGlobal_xy_planes = nz, Num_xy_points_per_plane = nx*ny + +contains + subroutine initialize_map(ictxt,NumMyElements,info) + integer(foo_ipk_) :: ictxt, NumMyElements, info + info = 0 + if (allocated(map)) deallocate(map,stat=info) + if (info == 0) allocate(map,stat=info) + if (info == 0) call foo_cdall(ictxt,map,info,nl=NumMyElements) + if (info == 0) call foo_cdasb(map,info) + end subroutine initialize_map + + function new_scalar_field(comm) result(this) + type(scalar_field) :: this + integer(foo_ipk_) ,intent(in) :: comm + real(foo_dpk_) ,allocatable :: f_v(:) + integer(foo_ipk_) :: i,j,k,NumMyElements, iam, np, info,ip + integer(foo_ipk_), allocatable :: idxs(:) + call foo_info(comm,iam,np) + NumMy_xy_planes = NumGlobal_xy_planes/np + NumMyElements = NumMy_xy_planes*Num_xy_points_per_plane + if (.not. allocated(map)) call initialize_map(comm,NumMyElements,info) + this%map => map + call foo_geall(this%f,this%map,info) + end function + + subroutine free(this) + class(scalar_field), intent(inout) :: this + integer(foo_ipk_) ::info + write(0,*) 'Freeing scalar_this%f' + call this%f%free() + end subroutine free + +end module foo_scalar_field_mod + +module foo_vector_field_mod + use foo_base_mod + use foo_scalar_field_mod, only : scalar_field,new_scalar_field + implicit none + type vector_field + type(scalar_field) :: u(1) + contains + procedure :: free + end type +contains + function new_vector_field(comm_in) result(this) + type(vector_field) :: this + integer(foo_ipk_), intent(in) :: comm_in + this%u = [new_scalar_field(comm_in)] ! Removing this line eliminates the memory leak + end function + + subroutine free(this) + class(vector_field), intent(inout) :: this + integer :: i + associate(vf=>this%u) + do i=1, size(vf) + write(0,*) 'Freeing vector_this%u(',i,')' + call vf(i)%free() + end do + end associate + end subroutine free + +end module foo_vector_field_mod + +program main + use foo_base_mod + use foo_vector_field_mod,only: vector_field,new_vector_field + use foo_scalar_field_mod,only: map + implicit none + type(vector_field) :: u + type(foo_d_vect_type) :: v + real(foo_dpk_), allocatable :: av(:) + integer(foo_ipk_) :: ictxt, iam, np, i,info + call foo_init(ictxt) + call foo_info(ictxt,iam,np) + u = new_vector_field(ictxt) + call u%free() + do i=1,10 + u = new_vector_field(ictxt) + call u%free() + end do + call u%free() + call foo_exit(ictxt) +end program diff --git a/Fortran/gfortran/regression/allocate_with_source_14.f03 b/Fortran/gfortran/regression/allocate_with_source_14.f03 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_14.f03 @@ -0,0 +1,214 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Tests the fix for PR61830. +! +! Contributed by Salvatore Filippone +! +module foo_base_mod + integer, parameter :: foo_dpk_ = kind(1.d0) + type foo_d_base_vect_type + real(foo_dpk_), allocatable :: v(:) + contains + procedure :: free => d_base_free + procedure :: get_vect => d_base_get_vect + procedure :: allocate => d_base_allocate + end type foo_d_base_vect_type + + + type foo_d_vect_type + class(foo_d_base_vect_type), allocatable :: v + contains + procedure :: free => d_vect_free + procedure :: get_vect => d_vect_get_vect + end type foo_d_vect_type + + type foo_desc_type + integer :: nl=-1 + end type foo_desc_type + +contains + + subroutine foo_cdall(map,nl) + type(foo_desc_type) :: map + integer, optional :: nl + + if (present(nl)) then + map%nl = nl + else + map%nl = 1 + end if + end subroutine foo_cdall + + + subroutine foo_cdasb(map,info) + integer :: info + type(foo_desc_type) :: map + if (map%nl < 0) map%nl=1 + end subroutine foo_cdasb + + + + subroutine d_base_allocate(this,n) + class(foo_d_base_vect_type), intent(out) :: this + + allocate(this%v(max(1,n))) + + end subroutine d_base_allocate + + subroutine d_base_free(this) + class(foo_d_base_vect_type), intent(inout) :: this + if (allocated(this%v)) then + write(0,*) 'Scalar deallocation' + deallocate(this%v) + end if + end subroutine d_base_free + + function d_base_get_vect(this) result(res) + class(foo_d_base_vect_type), intent(inout) :: this + real(foo_dpk_), allocatable :: res(:) + + if (allocated(this%v)) then + res = this%v + else + allocate(res(1)) + end if + end function d_base_get_vect + + subroutine d_vect_free(this) + class(foo_d_vect_type) :: this + if (allocated(this%v)) then + call this%v%free() + write(0,*) 'Deallocate class() component' + deallocate(this%v) + end if + end subroutine d_vect_free + + function d_vect_get_vect(this) result(res) + class(foo_d_vect_type) :: this + real(foo_dpk_), allocatable :: res(:) + + if (allocated(this%v)) then + res = this%v%get_vect() + else + allocate(res(1)) + end if + end function d_vect_get_vect + + subroutine foo_geall(v,map,info) + type(foo_d_vect_type), intent(out) :: v + type(foo_Desc_type) :: map + integer :: info + + allocate(foo_d_base_vect_type :: v%v,stat=info) + if (info == 0) call v%v%allocate(map%nl) + end subroutine foo_geall + +end module foo_base_mod + + +module foo_scalar_field_mod + use foo_base_mod + implicit none + + type scalar_field + type(foo_d_vect_type) :: f + type(foo_desc_type), pointer :: map => null() + contains + procedure :: free + end type + + integer, parameter :: nx=4,ny=nx, nz=nx + type(foo_desc_type), allocatable, save, target :: map + integer ,save :: NumMy_xy_planes + integer ,parameter :: NumGlobalElements = nx*ny*nz + integer ,parameter :: NumGlobal_xy_planes = nz, & + & Num_xy_points_per_plane = nx*ny + +contains + subroutine initialize_map(NumMyElements) + integer :: NumMyElements, info + info = 0 + if (allocated(map)) deallocate(map,stat=info) + if (info == 0) allocate(map,stat=info) + if (info == 0) call foo_cdall(map,nl=NumMyElements) + if (info == 0) call foo_cdasb(map,info) + end subroutine initialize_map + + function new_scalar_field() result(this) + type(scalar_field) :: this + real(foo_dpk_) ,allocatable :: f_v(:) + integer :: i,j,k,NumMyElements, iam, np, info,ip + integer, allocatable :: idxs(:) + + NumMy_xy_planes = NumGlobal_xy_planes + NumMyElements = NumMy_xy_planes*Num_xy_points_per_plane + if (.not. allocated(map)) call initialize_map(NumMyElements) + this%map => map + call foo_geall(this%f,this%map,info) + end function + + subroutine free(this) + class(scalar_field), intent(inout) :: this + integer ::info + call this%f%free() + end subroutine free + +end module foo_scalar_field_mod + +module foo_vector_field_mod + use foo_base_mod + use foo_scalar_field_mod + implicit none + type vector_field + type(scalar_field) :: u(1) + end type vector_field +contains + function new_vector_field() result(this) + type(vector_field) :: this + integer :: i + do i=1, size(this%u) + associate(sf=>this%u(i)) + sf = new_scalar_field() + end associate + end do + end function + + subroutine free_v_field(this) + class(vector_field), intent(inout) :: this + integer :: i + associate(vf=>this%u) + do i=1, size(vf) + call vf(i)%free() + end do + end associate + end subroutine free_v_field + +end module foo_vector_field_mod + +program main + use foo_base_mod + use foo_vector_field_mod + use foo_scalar_field_mod + implicit none + type(vector_field) :: u + type(foo_d_vect_type) :: v + real(foo_dpk_), allocatable :: av(:) + integer :: iam, np, i,info + + u = new_vector_field() + call foo_geall(v,map,info) + call free_v_field(u) + do i=1,10 + u = new_vector_field() + call free_v_field(u) + av = v%get_vect() + end do +! This gets rid of the "memory leak" + if (associated (u%u(1)%map)) deallocate (u%u(1)%map) + call free_v_field(u) + call v%free() + deallocate(av) +end program +! { dg-final { scan-tree-dump-times "__builtin_malloc" 22 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free" 29 "original" } } diff --git a/Fortran/gfortran/regression/allocate_with_source_15.f03 b/Fortran/gfortran/regression/allocate_with_source_15.f03 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_15.f03 @@ -0,0 +1,79 @@ +! { dg-do run } +! +! Tests the fix for PR67933, which was a side effect of the fix for PR67171. +! +! Contributed by Andrew +! +module test_mod + implicit none + + type :: class_t + integer :: i + end type class_t + + type, extends(class_t) :: class_e + real :: r + end type class_e + + type :: wrapper_t + class(class_t), allocatable :: class_var +! type(class_t), allocatable :: class_var +! integer, allocatable :: class_id + end type wrapper_t + + type :: list_t + type(wrapper_t) :: classes(20) + contains + procedure :: Method + procedure :: Typeme + procedure :: Dealloc + end type list_t + +contains + subroutine Method(this) + class(list_t) :: this + integer :: i + do i = 1, 20 + if (i .gt. 10) then + allocate (this%classes(i)%class_var, source = class_t (i)) + else + allocate (this%classes(i)%class_var, source = class_e (i, real (2 * i))) + end if + end do + end subroutine Method + subroutine Dealloc(this) + class(list_t) :: this + integer :: i + do i = 1, 20 + if (allocated (this%classes(i)%class_var)) & + deallocate (this%classes(i)%class_var) + end do + end subroutine Dealloc + subroutine Typeme(this) + class(list_t) :: this + integer :: i, j(20) + real :: r(20) + real :: zero = 0.0 + do i = 1, 20 + j(i) = this%classes(i)%class_var%i + select type (p => this%classes(i)%class_var) + type is (class_e) + r(i) = p%r + class default + r(i) = zero + end select + end do +! print "(10i6,/)", j + if (any (j .ne. [(i, i = 1,20)])) STOP 1 +! print "(10f6.2,/)", r + if (any (r(1:10) .ne. [(real (2 * i), i = 1,10)])) STOP 2 + if (any (r(11:20) .ne. zero)) STOP 3 + end subroutine Typeme +end module test_mod + + use test_mod + type(list_t) :: x + call x%Method + call x%Typeme + call x%dealloc +end diff --git a/Fortran/gfortran/regression/allocate_with_source_16.f90 b/Fortran/gfortran/regression/allocate_with_source_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_16.f90 @@ -0,0 +1,76 @@ +! { dg-do run } +! Test the fix for pr69011, preventing an ICE and making sure +! that the correct dynamic type is used. +! +! Contributed by Thomas Koenig +! Andre Vehreschild +! + +module m1 +implicit none +private +public :: basetype + +type:: basetype + integer :: i + contains +endtype basetype + +abstract interface +endinterface + +endmodule m1 + +module m2 +use m1, only : basetype +implicit none +integer, parameter :: I_P = 4 + +private +public :: factory, exttype + +type, extends(basetype) :: exttype + integer :: i2 + contains +endtype exttype + +type :: factory + integer(I_P) :: steps=-1 + contains + procedure, pass(self), public :: construct +endtype factory +contains + + function construct(self, previous) + class(basetype), intent(INOUT) :: previous(1:) + class(factory), intent(IN) :: self + class(basetype), pointer :: construct + allocate(construct, source=previous(self%steps)) + endfunction construct +endmodule m2 + + use m2 + use m1 + class(factory), allocatable :: c1 + class(exttype), allocatable :: prev(:) + class(basetype), pointer :: d + + allocate(c1) + allocate(prev(2)) + prev(:)%i = [ 2, 3] + prev(:)%i2 = [ 5, 6] + c1%steps= 1 + d=> c1%construct(prev) + + if (.not. associated(d) ) STOP 1 + select type (d) + class is (exttype) + if (d%i2 /= 5) STOP 2 + class default + STOP 3 + end select + if (d%i /= 2) STOP 4 + deallocate(c1) + deallocate(prev) + deallocate(d) +end diff --git a/Fortran/gfortran/regression/allocate_with_source_17.f03 b/Fortran/gfortran/regression/allocate_with_source_17.f03 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_17.f03 @@ -0,0 +1,36 @@ +! { dg-do compile } +! +! Tests the fix for PR67564 in which allocate with source for an unlimited +! polymorphic array and a character source would ICE. +! +! Contributed by Neil Carlson +! +program main + type :: any_vector + class(*), allocatable :: x(:) + end type + type(any_vector) :: a + character(kind = 1, len = 5) :: chr1(3) = ["one ","two ","three"] + character(kind = 4, len = 2) :: chr4(2) = [character(kind=4) :: 4_"ab", 4_"cd"] + real(8) :: r(2) = [1d0,2d0] + + allocate (a%x(3), source = chr1) + call check + allocate (a%x(2), source = chr4) + call check + allocate (a%x(2), source = r) + call check + +contains + subroutine check + select type (z => a%x) + type is (real(8)) + if (any (z .ne. r)) STOP 1 + type is (character(kind = 1, len = *)) + if (any(z .ne. chr1)) STOP 2 + type is (character(kind = 4, len = *)) + if (any(z .ne. chr4)) STOP 3 + end select + deallocate (a%x) + end subroutine +end program diff --git a/Fortran/gfortran/regression/allocate_with_source_18.f03 b/Fortran/gfortran/regression/allocate_with_source_18.f03 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_18.f03 @@ -0,0 +1,31 @@ +! { dg-do run } +! +! PR fortran/57365 +! [OOP] Sourced allocation fails with unlimited polymorphism +! Contributed by +! +program bug + + implicit none + character(len=:), allocatable :: test + + test = "A test case" + call allocate_test(test) + deallocate(test) + +contains + + subroutine allocate_test(var) + class(*) :: var + class(*), pointer :: copyofvar + allocate(copyofvar, source=var) + select type (copyofvar) + type is (character(len=*)) +! print*, len(copyofvar), copyofvar + if (len(copyofvar) /= 11) STOP 1 + if (copyofvar /= "A test case") STOP 2 + end select + deallocate(copyofvar) + end subroutine + +end program bug diff --git a/Fortran/gfortran/regression/allocate_with_source_19.f08 b/Fortran/gfortran/regression/allocate_with_source_19.f08 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_19.f08 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options -std=f2008 } + +! Contributed by mrestelli@gmail.com +! Check that instead of an ICE the error message is emitted. + +module m + implicit none +contains + + subroutine s() + real, allocatable :: x(:) + real :: y + + y = 5.0 + ! x either needs an array spec, or y needs to be an array. + allocate( x , source=y ) ! { dg-error "Array specification or array-valued SOURCE= expression required in ALLOCATE statement" } + + end subroutine s + +end module m + diff --git a/Fortran/gfortran/regression/allocate_with_source_2.f90 b/Fortran/gfortran/regression/allocate_with_source_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_2.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! PR 45170 +! A variation of a theme for deferred type parameters. The +! substring reference in the source= portion of the allocate +! was not probably resolved. Testcase is a modified version +! of a program due to Hans-Werner Boschmann +! +program helloworld + character(:),allocatable::string + real::rnd + call hello(5, string) + if (string /= 'hello' .or. len(string) /= 5) STOP 1 +contains + subroutine hello (n,string) + character(:),allocatable,intent(out)::string + integer,intent(in)::n + character(20)::helloworld="hello world" + allocate(string, source=helloworld(:n)) + end subroutine hello +end program helloworld diff --git a/Fortran/gfortran/regression/allocate_with_source_20.f03 b/Fortran/gfortran/regression/allocate_with_source_20.f03 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_20.f03 @@ -0,0 +1,21 @@ +! { dg-do run } + +! Check that PR72698 is fixed. +! Contributed by Gerhard Steinmetz + +module m +contains + integer function f() + f = 4 + end +end +program p + use m + character(3), parameter :: c = 'abc' + character(:), allocatable :: z + allocate (z, source=repeat(c(2:1), f())) + if (len(z) /= 0) STOP 1 + if (z /= "") STOP 2 +end + + diff --git a/Fortran/gfortran/regression/allocate_with_source_21.f03 b/Fortran/gfortran/regression/allocate_with_source_21.f03 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_21.f03 @@ -0,0 +1,52 @@ +! { dg-do compile } + +! Check fix for pr71936. +! Contributed by Gerhard Steinmetz + +program p + type t + end type + + call test2() + call test4() + call test1() + call test3() +contains + function f_p() + class(t), pointer :: f_p(:) + nullify(f_p) + end + + function f_a() + class(t), allocatable :: f_a(:) + end + + subroutine test1() + class(t), allocatable :: x(:) + allocate (x, mold=f_a()) + deallocate (x) + allocate (x, source=f_a()) + end subroutine + + subroutine test2() + class(t), pointer :: x(:) + allocate (x, mold=f_p()) + deallocate (x) + allocate (x, source=f_p()) + end + + subroutine test3() + class(t), pointer :: x(:) + allocate (x, mold=f_a()) + deallocate (x) + allocate (x, source=f_a()) + end + + subroutine test4() + class(t), allocatable :: x(:) + allocate (x, mold=f_p()) + deallocate (x) + allocate (x, source=f_p()) + end subroutine +end + diff --git a/Fortran/gfortran/regression/allocate_with_source_22.f03 b/Fortran/gfortran/regression/allocate_with_source_22.f03 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_22.f03 @@ -0,0 +1,48 @@ +! { dg-do run } +! +! Test that pr72832 is fixed now. +! Contributed by Daan van Vugt + +program allocate_source + type :: t + integer :: i + end type t + type, extends(t) :: tt + end type tt + + call test_type() + call test_class() + +contains + +subroutine test_class() + class(t), allocatable, dimension(:) :: a, b + allocate(tt::a(1:2)) + a(:)%i = [ 1,2 ] + if (size(a) /= 2) STOP 1 + if (any(a(:)%i /= [ 1,2])) STOP 2 + + allocate(b(1:4), source=a) + ! b is incorrectly initialized here. This only is diagnosed when compiled + ! with -fcheck=bounds. + if (size(b) /= 4) STOP 3 + if (any(b(1:2)%i /= [ 1,2])) STOP 4 + select type (b1 => b(1)) + class is (tt) + continue + class default + STOP 5 + end select +end subroutine + +subroutine test_type() + type(t), allocatable, dimension(:) :: a, b + allocate(a(1:2)) + if (size(a) /= 2) STOP 6 + + allocate(b(1:4), source=a) + if (size(b) /= 4) STOP 7 +end subroutine +end program allocate_source + + diff --git a/Fortran/gfortran/regression/allocate_with_source_23.f03 b/Fortran/gfortran/regression/allocate_with_source_23.f03 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_23.f03 @@ -0,0 +1,67 @@ +! { dg-do run } +! { dg-options "-fcheck=bounds" } +! { dg-shouldfail "Array bounds mismatch" } +! +! Test that pr72832 is fixed now. +! Contributed by Daan van Vugt + +program allocate_source + type :: t + integer :: i + end type t + type, extends(t) :: tt + end type tt + + call test_type() + call test_class_correct() + call test_class_fail() + +contains + +subroutine test_class_correct() + class(t), allocatable, dimension(:) :: a, b + allocate(tt::a(1:2)) + a(:)%i = [ 1,2 ] + if (size(a) /= 2) STOP 1 + if (any(a(:)%i /= [ 1,2])) STOP 2 + + allocate(b(1:4), source=a(1)) + if (size(b) /= 4) STOP 3 + if (any(b(:)%i /= [ 1,1,1,1])) STOP 4 + select type (b1 => b(1)) + class is (tt) + continue + class default + STOP 5 + end select +end subroutine + +subroutine test_class_fail() + class(t), allocatable, dimension(:) :: a, b + allocate(tt::a(1:2)) + a(:)%i = [ 1,2 ] + if (size(a) /= 2) STOP 6 + if (any(a(:)%i /= [ 1,2])) STOP 7 + + allocate(b(1:4), source=a) ! Fail expected: sizes do not conform + if (size(b) /= 4) STOP 8 + if (any(b(1:2)%i /= [ 1,2])) STOP 9 + select type (b1 => b(1)) + class is (tt) + continue + class default + STOP 10 + end select +end subroutine + +subroutine test_type() + type(t), allocatable, dimension(:) :: a, b + allocate(a(1:2)) + if (size(a) /= 2) STOP 11 + + allocate(b(1:4), source=a) + if (size(b) /= 4) STOP 12 +end subroutine +end program allocate_source + + diff --git a/Fortran/gfortran/regression/allocate_with_source_24.f90 b/Fortran/gfortran/regression/allocate_with_source_24.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_24.f90 @@ -0,0 +1,134 @@ +! { dg-do run } +! +! Test that the temporary in a sourced-ALLOCATE is not freeed. +! PR fortran/79344 +! Contributed by Juergen Reuter + +module iso_varying_string + implicit none + + type, public :: varying_string + private + character(LEN=1), dimension(:), allocatable :: chars + end type varying_string + + interface assignment(=) + module procedure op_assign_VS_CH + end interface assignment(=) + + interface operator(/=) + module procedure op_not_equal_VS_CA + end interface operator(/=) + + interface len + module procedure len_ + end interface len + + interface var_str + module procedure var_str_ + end interface var_str + + public :: assignment(=) + public :: operator(/=) + public :: len + + private :: op_assign_VS_CH + private :: op_not_equal_VS_CA + private :: char_auto + private :: len_ + private :: var_str_ + +contains + + elemental function len_ (string) result (length) + type(varying_string), intent(in) :: string + integer :: length + if(ALLOCATED(string%chars)) then + length = SIZE(string%chars) + else + length = 0 + endif + end function len_ + + elemental subroutine op_assign_VS_CH (var, exp) + type(varying_string), intent(out) :: var + character(LEN=*), intent(in) :: exp + var = var_str(exp) + end subroutine op_assign_VS_CH + + pure function op_not_equal_VS_CA (var, exp) result(res) + type(varying_string), intent(in) :: var + character(LEN=*), intent(in) :: exp + logical :: res + integer :: i + res = .true. + if (len(exp) /= size(var%chars)) return + do i = 1, size(var%chars) + if (var%chars(i) /= exp(i:i)) return + end do + res = .false. + end function op_not_equal_VS_CA + + pure function char_auto (string) result (char_string) + type(varying_string), intent(in) :: string + character(LEN=len(string)) :: char_string + integer :: i_char + forall(i_char = 1:len(string)) + char_string(i_char:i_char) = string%chars(i_char) + end forall + end function char_auto + + elemental function var_str_ (char) result (string) + character(LEN=*), intent(in) :: char + type(varying_string) :: string + integer :: length + integer :: i_char + length = LEN(char) + ALLOCATE(string%chars(length)) + forall(i_char = 1:length) + string%chars(i_char) = char(i_char:i_char) + end forall + end function var_str_ + +end module iso_varying_string + +!!!!! + +program test_pr79344 + + use iso_varying_string, string_t => varying_string + + implicit none + + type :: field_data_t + type(string_t), dimension(:), allocatable :: name + end type field_data_t + + type(field_data_t) :: model, model2 + allocate(model%name(2)) + model%name(1) = "foo" + model%name(2) = "bar" + call copy(model, model2) +contains + + subroutine copy(prt, prt_src) + implicit none + type(field_data_t), intent(inout) :: prt + type(field_data_t), intent(in) :: prt_src + integer :: i + if (allocated (prt_src%name)) then + if (prt_src%name(1) /= "foo") STOP 1 + if (prt_src%name(2) /= "bar") STOP 2 + + if (allocated (prt%name)) deallocate (prt%name) + allocate (prt%name (size (prt_src%name)), source = prt_src%name) + ! The issue was, that prt_src was empty after sourced-allocate. + if (prt_src%name(1) /= "foo") STOP 3 + if (prt_src%name(2) /= "bar") STOP 4 + if (prt%name(1) /= "foo") STOP 5 + if (prt%name(2) /= "bar") STOP 6 + end if + end subroutine copy + +end program test_pr79344 + diff --git a/Fortran/gfortran/regression/allocate_with_source_25.f90 b/Fortran/gfortran/regression/allocate_with_source_25.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_25.f90 @@ -0,0 +1,71 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Test the fix for PR86481 +! +! Contributed by Rich Townsend +! +program simple_leak + + implicit none + + type, abstract :: foo_t + end type foo_t + + type, extends(foo_t) :: foo_a_t + real(8), allocatable :: a(:) + end type foo_a_t + + type, extends(foo_t) :: bar_t + class(foo_t), allocatable :: f + end type bar_t + + integer, parameter :: N = 2 + integer, parameter :: D = 3 + + type(bar_t) :: b(N) + integer :: i + + do i = 1, N + b(i) = func_bar(D) + end do + + do i = 1, N + deallocate (b(i)%f) + end do + +contains + + function func_bar (D) result (b) + + integer, intent(in) :: D + type(bar_t) :: b + + allocate(b%f, SOURCE=func_foo(D)) + + end function func_bar + + !**** + + function func_foo (D) result (f) + + integer, intent(in) :: D + class(foo_t), allocatable :: f + + allocate(f, SOURCE=func_foo_a(D)) ! Lose one of these for each allocation + + end function func_foo + + !**** + + function func_foo_a (D) result (f) + + integer, intent(in) :: D + type(foo_a_t) :: f + + allocate(f%a(D)) ! Lose one of these for each allocation => N*D*elem_size(f%a) + + end function func_foo_a + +end program simple_leak +! { dg-final { scan-tree-dump-times "\>_final" 6 "original" } } diff --git a/Fortran/gfortran/regression/allocate_with_source_26.f90 b/Fortran/gfortran/regression/allocate_with_source_26.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_26.f90 @@ -0,0 +1,91 @@ +! { dg-do run } +! +! Ensure that the lower bound starts with the correct +! value +! +! PR fortran/87580 +! PR fortran/67125 +! +! Contributed by Antony Lewis and mrestelli +! +program p + implicit none + integer, allocatable :: a(:), b(:), c(:), d(:), e(:) + type t + integer :: i + end type t + class(t), allocatable :: p1(:), p2(:), p3(:), p4(:) + integer :: vec(6) + + vec = [1,2,3,4,5,6] + + allocate(a, source=f(3)) + allocate(b, source=g(3)) + allocate(c, source=h(3)) + allocate(d, source=[1,2,3,4,5]) + allocate(e, source=vec) + + allocate(p1(3:4)) + p1(:)%i = [43,56] + allocate(p2, source=p1) + call do_allocate(p1, size(p1)) + allocate(p4, source=poly_init()) + + if (lbound(p1, 1) /= 3 .or. ubound(p1, 1) /= 4 & + .or. lbound(p2, 1) /= 3 .or. ubound(p2, 1) /= 4 & + .or. lbound(p3, 1) /= 1 .or. ubound(p3, 1) /= 2 & + .or. lbound(p4, 1) /= 1 .or. ubound(p4, 1) /= 2 & + .or. p1(3)%i /= 43 .or. p1(4)%i /= 56 & + .or. p2(3)%i /= 43 .or. p2(4)%i /= 56 & + .or. p3(1)%i /= 43 .or. p3(2)%i /= 56 & + .or. p4(1)%i /= 11 .or. p4(2)%i /= 12) then + call abort() + endif + + !write(*,*) lbound(a,1), ubound(a,1) ! prints 1 3 + !write(*,*) lbound(b,1), ubound(b,1) ! prints 1 3 + !write(*,*) lbound(c,1), ubound(c,1) ! prints 1 3 + !write(*,*) lbound(d,1), ubound(d,1) ! prints 1 5 + !write(*,*) lbound(e,1), ubound(e,1) ! prints 1 6 + + if (lbound(a,1) /= 1 .or. ubound(a,1) /= 3 & + .or. lbound(b,1) /= 1 .or. ubound(b,1) /= 3 & + .or. lbound(c,1) /= 1 .or. ubound(c,1) /= 3 & + .or. lbound(d,1) /= 1 .or. ubound(d,1) /= 5 & + .or. lbound(e,1) /= 1 .or. ubound(e,1) /= 6) then + call abort() + endif + +contains + + subroutine do_allocate(x, n) + integer, value :: n + class(t), intent(in) :: x(n) + allocate(p3, source=x) + end subroutine + + function poly_init() + class(t), allocatable :: poly_init(:) + allocate(poly_init(7:8)) + poly_init = [t :: t(11), t(12)] + end function poly_init + + pure function f(i) + integer, intent(in) :: i + integer :: f(i) + f = 2*i + end function f + + pure function g(i) result(r) + integer, value, intent(in) :: i + integer, allocatable :: r(:) + r = [1,2,3] + end function g + + pure function h(i) result(r) + integer, value, intent(in) :: i + integer, allocatable :: r(:) + allocate(r(3:5)) + r = [1,2,3] + end function h +end program p diff --git a/Fortran/gfortran/regression/allocate_with_source_3.f90 b/Fortran/gfortran/regression/allocate_with_source_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_3.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! Contributed by Reinhold Bader +! +program assumed_shape_01 + use, intrinsic :: iso_c_binding + implicit none + type, bind(c) :: cstruct + integer(c_int) :: i + real(c_float) :: r(2) + end type cstruct + interface + subroutine psub(this, that) bind(c, name='Psub') + import :: c_float, cstruct + real(c_float) :: this(:,:) + type(cstruct) :: that(:) + end subroutine psub + end interface + + real(c_float) :: t(3,7) + type(cstruct), pointer :: u(:) + +! The following is VALID Fortran 2008 but NOT YET supported + allocate(u, source=[cstruct( 4, [1.1,2.2] ) ]) + call psub(t, u) + deallocate (u) + +end program assumed_shape_01 diff --git a/Fortran/gfortran/regression/allocate_with_source_4.f90 b/Fortran/gfortran/regression/allocate_with_source_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_4.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! +! PR 58916: [F03] Allocation of scalar with array source not rejected +! +! Contributed by Vladimir Fuka + + class(*), allocatable :: a1 + real, allocatable :: a2 + real b(1) + allocate(a1, source=b) ! { dg-error "must be scalar or have the same rank" } + allocate(a2, source=b) ! { dg-error "must be scalar or have the same rank" } +end diff --git a/Fortran/gfortran/regression/allocate_with_source_5.f90 b/Fortran/gfortran/regression/allocate_with_source_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_5.f90 @@ -0,0 +1,159 @@ +! { dg-do run } +! +! Contributed by Juergen Reuter +! Check that pr65548 is fixed. +! + +module selectors + type :: selector_t + integer, dimension(:), allocatable :: map + real, dimension(:), allocatable :: weight + contains + procedure :: init => selector_init + end type selector_t + +contains + + subroutine selector_init (selector, weight) + class(selector_t), intent(out) :: selector + real, dimension(:), intent(in) :: weight + real :: s + integer :: n, i + logical, dimension(:), allocatable :: mask + s = sum (weight) + allocate (mask (size (weight)), source = weight /= 0) + n = count (mask) + if (n > 0) then + allocate (selector%map (n), & + source = pack ([(i, i = 1, size (weight))], mask)) + allocate (selector%weight (n), & + source = pack (weight / s, mask)) + else + allocate (selector%map (1), source = 1) + allocate (selector%weight (1), source = 0.) + end if + end subroutine selector_init + +end module selectors + +module phs_base + type :: flavor_t + contains + procedure :: get_mass => flavor_get_mass + end type flavor_t + + type :: phs_config_t + integer :: n_in = 0 + type(flavor_t), dimension(:,:), allocatable :: flv + end type phs_config_t + + type :: phs_t + class(phs_config_t), pointer :: config => null () + real, dimension(:), allocatable :: m_in + end type phs_t + +contains + + elemental function flavor_get_mass (flv) result (mass) + real :: mass + class(flavor_t), intent(in) :: flv + mass = 42.0 + end function flavor_get_mass + + subroutine phs_base_init (phs, phs_config) + class(phs_t), intent(out) :: phs + class(phs_config_t), intent(in), target :: phs_config + phs%config => phs_config + allocate (phs%m_in (phs%config%n_in), & + source = phs_config%flv(:phs_config%n_in, 1)%get_mass ()) + end subroutine phs_base_init + +end module phs_base + +module foo + type :: t + integer :: n + real, dimension(:,:), allocatable :: val + contains + procedure :: make => t_make + generic :: get_int => get_int_array, get_int_element + procedure :: get_int_array => t_get_int_array + procedure :: get_int_element => t_get_int_element + end type t + +contains + + subroutine t_make (this) + class(t), intent(inout) :: this + real, dimension(:), allocatable :: int + allocate (int (0:this%n-1), source=this%get_int()) + end subroutine t_make + + pure function t_get_int_array (this) result (array) + class(t), intent(in) :: this + real, dimension(this%n) :: array + array = this%val (0:this%n-1, 4) + end function t_get_int_array + + pure function t_get_int_element (this, set) result (element) + class(t), intent(in) :: this + integer, intent(in) :: set + real :: element + element = this%val (set, 4) + end function t_get_int_element +end module foo +module foo2 + type :: t2 + integer :: n + character(32), dimension(:), allocatable :: md5 + contains + procedure :: init => t2_init + end type t2 + +contains + + subroutine t2_init (this) + class(t2), intent(inout) :: this + character(32), dimension(:), allocatable :: md5 + allocate (md5 (this%n), source=this%md5) + if (md5(1) /= "tst ") STOP 1 + if (md5(2) /= " ") STOP 2 + if (md5(3) /= "fooblabar ") STOP 3 + end subroutine t2_init +end module foo2 + +program test + use selectors + use phs_base + use foo + use foo2 + + type(selector_t) :: sel + type(phs_t) :: phs + type(phs_config_t) :: phs_config + type(t) :: o + type(t2) :: o2 + + call sel%init([2., 0., 3., 0., 4.]) + + if (any(sel%map /= [1, 3, 5])) STOP 4 + if (any(abs(sel%weight - [2., 3., 4.] / 9.) > 1E-6)) STOP 5 + + phs_config%n_in = 2 + allocate (phs_config%flv (phs_config%n_in, 1)) + call phs_base_init (phs, phs_config) + + if (any(abs(phs%m_in - [42.0, 42.0]) > 1E-6)) STOP 6 + + o%n = 2 + allocate (o%val(0:1,4)) + call o%make() + + o2%n = 3 + allocate(o2%md5(o2%n)) + o2%md5(1) = "tst" + o2%md5(2) = "" + o2%md5(3) = "fooblabar" + call o2%init() +end program test + diff --git a/Fortran/gfortran/regression/allocate_with_source_6.f90 b/Fortran/gfortran/regression/allocate_with_source_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_6.f90 @@ -0,0 +1,161 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! +! Contributed by Juergen Reuter +! Check that pr65548 is fixed and that the ICE is gone, when bounds-check +! is requested. +! + +module selectors + type :: selector_t + integer, dimension(:), allocatable :: map + real, dimension(:), allocatable :: weight + contains + procedure :: init => selector_init + end type selector_t + +contains + + subroutine selector_init (selector, weight) + class(selector_t), intent(out) :: selector + real, dimension(:), intent(in) :: weight + real :: s + integer :: n, i + logical, dimension(:), allocatable :: mask + s = sum (weight) + allocate (mask (size (weight)), source = weight /= 0) + n = count (mask) + if (n > 0) then + allocate (selector%map (n), & + source = pack ([(i, i = 1, size (weight))], mask)) + allocate (selector%weight (n), & + source = pack (weight / s, mask)) + else + allocate (selector%map (1), source = 1) + allocate (selector%weight (1), source = 0.) + end if + end subroutine selector_init + +end module selectors + +module phs_base + type :: flavor_t + contains + procedure :: get_mass => flavor_get_mass + end type flavor_t + + type :: phs_config_t + integer :: n_in = 0 + type(flavor_t), dimension(:,:), allocatable :: flv + end type phs_config_t + + type :: phs_t + class(phs_config_t), pointer :: config => null () + real, dimension(:), allocatable :: m_in + end type phs_t + +contains + + elemental function flavor_get_mass (flv) result (mass) + real :: mass + class(flavor_t), intent(in) :: flv + mass = 42.0 + end function flavor_get_mass + + subroutine phs_base_init (phs, phs_config) + class(phs_t), intent(out) :: phs + class(phs_config_t), intent(in), target :: phs_config + phs%config => phs_config + allocate (phs%m_in (phs%config%n_in), & + source = phs_config%flv(:phs_config%n_in, 1)%get_mass ()) + end subroutine phs_base_init + +end module phs_base + +module foo + type :: t + integer :: n + real, dimension(:,:), allocatable :: val + contains + procedure :: make => t_make + generic :: get_int => get_int_array, get_int_element + procedure :: get_int_array => t_get_int_array + procedure :: get_int_element => t_get_int_element + end type t + +contains + + subroutine t_make (this) + class(t), intent(inout) :: this + real, dimension(:), allocatable :: int + allocate (int (0:this%n-1), source=this%get_int()) + end subroutine t_make + + pure function t_get_int_array (this) result (array) + class(t), intent(in) :: this + real, dimension(this%n) :: array + array = this%val (0:this%n-1, 4) + end function t_get_int_array + + pure function t_get_int_element (this, set) result (element) + class(t), intent(in) :: this + integer, intent(in) :: set + real :: element + element = this%val (set, 4) + end function t_get_int_element +end module foo +module foo2 + type :: t2 + integer :: n + character(32), dimension(:), allocatable :: md5 + contains + procedure :: init => t2_init + end type t2 + +contains + + subroutine t2_init (this) + class(t2), intent(inout) :: this + character(32), dimension(:), allocatable :: md5 + allocate (md5 (this%n), source=this%md5) + if (md5(1) /= "tst ") STOP 1 + if (md5(2) /= " ") STOP 2 + if (md5(3) /= "fooblabar ") STOP 3 + end subroutine t2_init +end module foo2 + +program test + use selectors + use phs_base + use foo + use foo2 + + type(selector_t) :: sel + type(phs_t) :: phs + type(phs_config_t) :: phs_config + type(t) :: o + type(t2) :: o2 + + call sel%init([2., 0., 3., 0., 4.]) + + if (any(sel%map /= [1, 3, 5])) STOP 4 + if (any(abs(sel%weight - [2., 3., 4.] / 9.) > 1E-6)) STOP 5 + + phs_config%n_in = 2 + allocate (phs_config%flv (phs_config%n_in, 1)) + call phs_base_init (phs, phs_config) + + if (any(abs(phs%m_in - [42.0, 42.0]) > 1E-6)) STOP 6 + + o%n = 2 + allocate (o%val(0:1,4)) + call o%make() + + o2%n = 3 + allocate(o2%md5(o2%n)) + o2%md5(1) = "tst" + o2%md5(2) = "" + o2%md5(3) = "fooblabar" + call o2%init() +end program test + diff --git a/Fortran/gfortran/regression/allocate_with_source_7.f08 b/Fortran/gfortran/regression/allocate_with_source_7.f08 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_7.f08 @@ -0,0 +1,79 @@ +! { dg-do run } +! +! Check that allocate with source for arrays without array-spec +! works. +! PR fortran/44672 +! Contributed by Tobias Burnus +! Antony Lewis +! Andre Vehreschild +! + +program allocate_with_source_6 + + type P + class(*), allocatable :: X(:,:) + end type + + type t + end type t + + type(t), allocatable :: a(:), b, c(:) + integer :: num_params_used = 6 + integer, allocatable :: m(:) + + allocate(b,c(5)) + allocate(a(5), source=b) + deallocate(a) + allocate(a, source=c) + allocate(m, source=[(I, I=1, num_params_used)]) + if (any(m /= [(I, I=1, num_params_used)])) STOP 1 + deallocate(a,b,m) + call testArrays() + +contains + subroutine testArrays() + type L + class(*), allocatable :: v(:) + end type + Type(P) Y + type(L) o + real arr(3,5) + real, allocatable :: v(:) + + arr = 5 + allocate(Y%X, source=arr) + select type (R => Y%X) + type is (real) + if (any(reshape(R, [15]) /= [5,5,5,5,5, 5,5,5,5,5, 5,5,5,5,5])) & + STOP 2 + class default + STOP 3 + end select + deallocate(Y%X) + + allocate(Y%X, source=arr(2:3,3:4)) + select type (R => Y%X) + type is (real) + if (any(reshape(R, [4]) /= [5,5,5,5])) & + STOP 4 + class default + STOP 5 + end select + deallocate(Y%X) + + allocate(o%v, source=arr(2,3:4)) + select type (R => o%v) + type is (real) + if (any(R /= [5,5])) & + STOP 6 + class default + STOP 7 + end select + deallocate(o%v) + + allocate(v, source=arr(2,1:5)) + if (any(v /= [5,5,5,5,5])) STOP 8 + deallocate(v) + end subroutine testArrays +end + diff --git a/Fortran/gfortran/regression/allocate_with_source_8.f08 b/Fortran/gfortran/regression/allocate_with_source_8.f08 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_8.f08 @@ -0,0 +1,110 @@ +! { dg-do run } +! +! Contributed by Reinhold Bader +! +program assumed_shape_01 + implicit none + type :: cstruct + integer :: i + real :: r(2) + end type cstruct + + type(cstruct), pointer :: u(:) + integer, allocatable :: iv(:), iv2(:) + integer, allocatable :: im(:,:) + integer, parameter :: cim(2,3) = reshape([1,2,3, 2,3,4], [2,3]) + integer :: i + integer, parameter :: lcim(2,10) = reshape([(i, i=1,10),(i,i=1,10)], [2,10]) + + allocate(iv, source= [ 1, 2, 3, 4]) + if (any(iv /= [ 1, 2, 3, 4])) STOP 1 + deallocate(iv) + + allocate(iv, source=(/(i, i=1,10)/)) + if (any(iv /= (/(i, i=1,10)/))) STOP 2 + + ! Now 2D + allocate(im, source= cim) + if (any(im /= cim)) STOP 3 + deallocate(im) + + allocate(im, source= reshape([iv, iv], [2, size(iv, 1)])) + if (any(im /= lcim)) STOP 4 + deallocate(im) + deallocate(iv) + + allocate(u, source=[cstruct( 4, [1.1,2.2] )] ) + if (any(u(:)%i /= 4) .or. any(abs(u(1)%r(:) - [1.1,2.2]) > 1E-6)) STOP 5 + deallocate (u) + + allocate(iv, source= arrval()) + if (any(iv /= [ 1, 2, 4, 5, 6])) STOP 6 + ! Check simple array assign + allocate(iv2, source=iv) + if (any(iv2 /= [ 1, 2, 4, 5, 6])) STOP 7 + deallocate(iv, iv2) + + ! Now check for mold= + allocate(iv, mold= [ 1, 2, 3, 4]) + if (any(shape(iv) /= [4])) STOP 8 + deallocate(iv) + + allocate(iv, mold=(/(i, i=1,10)/)) + if (any(shape(iv) /= [10])) STOP 9 + + ! Now 2D + allocate(im, mold= cim) + if (any(shape(im) /= shape(cim))) STOP 10 + deallocate(im) + + allocate(im, mold= reshape([iv, iv], [2, size(iv, 1)])) + if (any(shape(im) /= shape(lcim))) STOP 11 + deallocate(im) + deallocate(iv) + + allocate(u, mold=[cstruct( 4, [1.1,2.2] )] ) + if (any(shape(u(1)%r(:)) /= 2)) STOP 12 + deallocate (u) + + allocate(iv, mold= arrval()) + if (any(shape(iv) /= [5])) STOP 13 + ! Check simple array assign + allocate(iv2, mold=iv) + if (any(shape(iv2) /= [5])) STOP 14 + deallocate(iv, iv2) + + call addData([4, 5]) + call addData(["foo", "bar"]) +contains + function arrval() + integer, dimension(5) :: arrval + arrval = [ 1, 2, 4, 5, 6] + end function + + subroutine addData(P) + class(*), intent(in) :: P(:) + class(*), allocatable :: cP(:) + allocate (cP, source= P) + select type (cP) + type is (integer) + if (any(cP /= [4,5])) STOP 15 + type is (character(*)) + if (len(cP) /= 3) STOP 16 + if (any(cP /= ["foo", "bar"])) STOP 17 + class default + STOP 18 + end select + deallocate (cP) + allocate (cP, mold= P) + select type (cP) + type is (integer) + if (any(size(cP) /= [2])) STOP 19 + type is (character(*)) + if (len(cP) /= 3) STOP 20 + if (any(size(cP) /= [2])) STOP 21 + class default + STOP 22 + end select + deallocate (cP) + end subroutine +end program assumed_shape_01 diff --git a/Fortran/gfortran/regression/allocate_with_source_9.f08 b/Fortran/gfortran/regression/allocate_with_source_9.f08 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_source_9.f08 @@ -0,0 +1,29 @@ +! { dg-do run } +! +! Contributed by Thomas Koenig , +! Andre Vehreschild + +program main + + type T + integer, allocatable :: acc(:) + end type + + integer :: n, lb, ub + integer :: vec(9) + type(T) :: o1, o2 + vec = [(i, i= 1, 9)] + n = 42 + lb = 7 + ub = lb + 2 + allocate(o1%acc, source=vec) + allocate(o2%acc, source=o1%acc(lb:ub)) + if (any (o2%acc /= [7, 8, 9])) STOP 1 + block + real, dimension(0:n) :: a + real, dimension(:), allocatable :: c + call random_number(a) + allocate(c,source=a(:)) + if (any (abs(a - c) > 1E-6)) STOP 2 + end block +end program main diff --git a/Fortran/gfortran/regression/allocate_with_typespec_1.f90 b/Fortran/gfortran/regression/allocate_with_typespec_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_typespec_1.f90 @@ -0,0 +1,121 @@ +! { dg-do compile } +! +! Allocation of arrays with a type-spec specification with implicit none. +! +subroutine implicit_none_test1 + + implicit none + + real, allocatable :: x(:) + real(4), allocatable :: x4(:) + real(8), allocatable :: x8(:) + double precision, allocatable :: d1(:) + doubleprecision, allocatable :: d2(:) + character, allocatable :: c1(:) + character(len=4), allocatable :: c2(:) + + type a + integer mytype + end type a + + type(a), allocatable :: b(:) + + allocate(real :: x(1)) + allocate(real(4) :: x4(1)) + allocate(real(8) :: x8(1)) + allocate(double precision :: d1(1)) + allocate(doubleprecision :: d2(1)) + allocate(character :: c1(1)) + allocate(character(len=4) :: c2(1)) + allocate(a :: b(1)) + +end subroutine implicit_none_test1 +! +! Allocation of a scalar with a type-spec specification with implicit none +! +subroutine implicit_none_test2 + + implicit none + + real, allocatable :: x + real(4), allocatable :: x4 + real(8), allocatable :: x8 + double precision, allocatable :: d1 + doubleprecision, allocatable :: d2 + character, allocatable :: c1 + character(len=4), allocatable :: c2 + + type a + integer mytype + end type a + + type(a), allocatable :: b + + allocate(real :: x) + allocate(real(4) :: x4) + allocate(real(8) :: x8) + allocate(double precision :: d1) + allocate(doubleprecision :: d2) + allocate(character :: c1) + allocate(character(len=4) :: c2) + allocate(a :: b) + +end subroutine implicit_none_test2 +! +! Allocation of arrays with a type-spec specification with implicit none. +! +subroutine implicit_test3 + + real, allocatable :: x(:) + real(4), allocatable :: x4(:) + real(8), allocatable :: x8(:) + double precision, allocatable :: d1(:) + doubleprecision, allocatable :: d2(:) + character, allocatable :: c1(:) + character(len=4), allocatable :: c2(:) + + type a + integer mytype + end type a + + type(a), allocatable :: b(:) + + allocate(real :: x(1)) + allocate(real(4) :: x4(1)) + allocate(real(8) :: x8(1)) + allocate(double precision :: d1(1)) + allocate(doubleprecision :: d2(1)) + allocate(character :: c1(1)) + allocate(character(len=4) :: c2(1)) + allocate(a :: b(1)) + +end subroutine implicit_test3 +! +! Allocation of a scalar with a type-spec specification without implicit none +! +subroutine implicit_test4 + + real, allocatable :: x + real(4), allocatable :: x4 + real(8), allocatable :: x8 + double precision, allocatable :: d1 + doubleprecision, allocatable :: d2 + character, allocatable :: c1 + character(len=4), allocatable :: c2 + + type a + integer mytype + end type a + + type(a), allocatable :: b + + allocate(real :: x) + allocate(real(4) :: x4) + allocate(real(8) :: x8) + allocate(double precision :: d1) + allocate(doubleprecision :: d2) + allocate(character :: c1) + allocate(character(len=4) :: c2) + allocate(a :: b) + +end subroutine implicit_test4 diff --git a/Fortran/gfortran/regression/allocate_with_typespec_2.f b/Fortran/gfortran/regression/allocate_with_typespec_2.f --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_typespec_2.f @@ -0,0 +1,121 @@ +C { dg-do compile } +C +C Allocation of arrays with a type-spec specification with implicit none. +C + subroutine implicit_none_test1 + + implicit none + + real, allocatable :: x(:) + real(4), allocatable :: x4(:) + real(8), allocatable :: x8(:) + double precision, allocatable :: d1(:) + doubleprecision, allocatable :: d2(:) + character, allocatable :: c1(:) + character(len=4), allocatable :: c2(:) + + type a + integer mytype + end type a + + type(a), allocatable :: b(:) + + allocate(real :: x(1)) + allocate(real(4) :: x4(1)) + allocate(real(8) :: x8(1)) + allocate(double precision :: d1(1)) + allocate(doubleprecision :: d2(1)) + allocate(character :: c1(1)) + allocate(character(len=4) :: c2(1)) + allocate(a :: b(1)) + + end +C +C Allocation of a scalar with a type-spec specification with implicit none +C + subroutine implicit_none_test2 + + implicit none + + real, allocatable :: x + real(4), allocatable :: x4 + real(8), allocatable :: x8 + double precision, allocatable :: d1 + doubleprecision, allocatable :: d2 + character, allocatable :: c1 + character(len=4), allocatable :: c2 + + type a + integer mytype + end type a + + type(a), allocatable :: b + + allocate(real :: x) + allocate(real(4) :: x4) + allocate(real(8) :: x8) + allocate(double precision :: d1) + allocate(doubleprecision :: d2) + allocate(character :: c1) + allocate(character(len=4) :: c2) + allocate(a :: b) + + end subroutine implicit_none_test2 +C +C Allocation of arrays with a type-spec specification with implicit none. +C + subroutine implicit_test3 + + real, allocatable :: x(:) + real(4), allocatable :: x4(:) + real(8), allocatable :: x8(:) + double precision, allocatable :: d1(:) + doubleprecision, allocatable :: d2(:) + character, allocatable :: c1(:) + character(len=4), allocatable :: c2(:) + + type a + integer mytype + end type a + + type(a), allocatable :: b(:) + + allocate(real :: x(1)) + allocate(real(4) :: x4(1)) + allocate(real(8) :: x8(1)) + allocate(double precision :: d1(1)) + allocate(doubleprecision :: d2(1)) + allocate(character :: c1(1)) + allocate(character(len=4) :: c2(1)) + allocate(a :: b(1)) + + end +C +C Allocation of a scalar with a type-spec specification without implicit none +C + subroutine implicit_test4 + + real, allocatable :: x + real(4), allocatable :: x4 + real(8), allocatable :: x8 + double precision, allocatable :: d1 + doubleprecision, allocatable :: d2 + character, allocatable :: c1 + character(len=4), allocatable :: c2 + + type a + integer mytype + end type a + + type(a), allocatable :: b + + allocate(real :: x) + allocate(real(4) :: x4) + allocate(real(8) :: x8) + allocate(double precision :: d1) + allocate(doubleprecision :: d2) + allocate(character :: c1) + allocate(character(len=4) :: c2) + allocate(a :: b) + + end diff --git a/Fortran/gfortran/regression/allocate_with_typespec_3.f90 b/Fortran/gfortran/regression/allocate_with_typespec_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_typespec_3.f90 @@ -0,0 +1,107 @@ +! { dg-do compile } +! +! Allocation of arrays with a type-spec specification with implicit none. +! +subroutine implicit_none_test1 + + implicit none + + real, allocatable :: x(:) + real(4), allocatable :: x4(:) + real(8), allocatable :: x8(:) + double precision, allocatable :: d1(:) + doubleprecision, allocatable :: d2(:) + character, allocatable :: c1(:) + + type a + integer mytype + end type a + + type(a), allocatable :: b(:) + + allocate(complex :: x(1)) ! { dg-error "is type incompatible" } + allocate(real(8) :: x4(1)) ! { dg-error "differs from the kind type parameter" } + allocate(real(4) :: x8(1)) ! { dg-error "differs from the kind type parameter" } + allocate(double :: d1(1)) ! { dg-error "Error in type-spec at" } + allocate(character(:) :: c1(1)) ! { dg-error "cannot contain a deferred type parameter" } + allocate(real :: b(1)) ! { dg-error "is type incompatible" } + +end subroutine implicit_none_test1 +! +! Allocation of a scalar with a type-spec specification with implicit none +! +subroutine implicit_none_test2 + + implicit none + + real, allocatable :: x + real(4), allocatable :: x4 + real(8), allocatable :: x8 + double precision, allocatable :: d1 + character, allocatable :: c1 + + type a + integer mytype + end type a + + type(a), allocatable :: b + + allocate(complex :: x) ! { dg-error "is type incompatible" } + allocate(real(8) :: x4) ! { dg-error "differs from the kind type parameter" } + allocate(real(4) :: x8) ! { dg-error "differs from the kind type parameter" } + allocate(double :: d1) ! { dg-error "Error in type-spec at" } + allocate(character(:) :: c1) ! { dg-error "cannot contain a deferred type parameter" } + allocate(real :: b) ! { dg-error "is type incompatible" } + +end subroutine implicit_none_test2 +! +! Allocation of arrays with a type-spec specification with implicit none. +! +subroutine implicit_test3 + + real, allocatable :: x(:) + real(4), allocatable :: x4(:) + real(8), allocatable :: x8(:) + double precision, allocatable :: d1(:) + doubleprecision, allocatable :: d2(:) + character, allocatable :: c1(:) + + type a + integer mytype + end type a + + type(a), allocatable :: b(:) + + allocate(complex :: x(1)) ! { dg-error "is type incompatible" } + allocate(real(8) :: x4(1)) ! { dg-error "differs from the kind type parameter" } + allocate(real(4) :: x8(1)) ! { dg-error "differs from the kind type parameter" } + allocate(double :: d1(1)) ! { dg-error "Error in type-spec" } + allocate(character(:) :: c1(1)) ! { dg-error "cannot contain a deferred type parameter" } + allocate(real :: b(1)) ! { dg-error "is type incompatible" } + +end subroutine implicit_test3 +! +! Allocation of a scalar with a type-spec specification without implicit none +! +subroutine implicit_test4 + + real, allocatable :: x + real(4), allocatable :: x4 + real(8), allocatable :: x8 + double precision, allocatable :: d1 + character, allocatable :: c1 + + type a + integer mytype + end type a + + type(a), allocatable :: b + + allocate(complex :: x) ! { dg-error "is type incompatible" } + allocate(real(8) :: x4) ! { dg-error "differs from the kind type parameter" } + allocate(real(4) :: x8) ! { dg-error "differs from the kind type parameter" } + allocate(double :: d1) ! { dg-error "Error in type-spec at" } + allocate(character(:) :: c1) ! { dg-error "cannot contain a deferred type parameter" } + allocate(real :: b) ! { dg-error "is type incompatible" } + +end subroutine implicit_test4 diff --git a/Fortran/gfortran/regression/allocate_with_typespec_4.f90 b/Fortran/gfortran/regression/allocate_with_typespec_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_typespec_4.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-options "-w" } +subroutine not_an_f03_intrinsic + + implicit none + + byte, allocatable :: x, y(:) + real*8, allocatable :: x8, y8(:) + double complex :: z + + type real_type + integer mytype + end type real_type + + type(real_type), allocatable :: b, c(:) + + allocate(byte :: x) ! { dg-error "Error in type-spec at" } + allocate(byte :: y(1)) ! { dg-error "Error in type-spec at" } + + allocate(real*8 :: x) ! { dg-error "Invalid type-spec at" } + allocate(real*8 :: y(1)) ! { dg-error "Invalid type-spec at" } + allocate(real*4 :: x8) ! { dg-error "Invalid type-spec at" } + allocate(real*4 :: y8(1)) ! { dg-error "Invalid type-spec at" } + allocate(double complex :: d1) ! { dg-error "neither a data pointer nor an allocatable" } + allocate(real_type :: b) + allocate(real_type :: c(1)) + +end subroutine not_an_f03_intrinsic diff --git a/Fortran/gfortran/regression/allocate_with_typespec_5.f90 b/Fortran/gfortran/regression/allocate_with_typespec_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_typespec_5.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! +! PR fortran/51652 +! +! Contributed by David Kinniburgh +! +module settings + +type keyword + character(60), allocatable :: c(:) +end type keyword + +type(keyword) :: kw(10) + +contains + +subroutine save_kw + allocate(character(80) :: kw(1)%c(10)) ! { dg-error "with type-spec requires the same character-length parameter" } +end subroutine save_kw + +subroutine foo(n) + character(len=n+2), allocatable :: x + allocate (character(len=n+3) :: x) ! { dg-error "type-spec requires the same character-length parameter" } +end subroutine foo + +end module settings diff --git a/Fortran/gfortran/regression/allocate_with_typespec_6.f90 b/Fortran/gfortran/regression/allocate_with_typespec_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_typespec_6.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! +! PR fortran/51055 +! PR fortran/45170 comment 14 +! +! Contributed by Juha Ruokolainen +! and Hans-Werner Boschmann +! +! gfortran was before checking whether the length +! was a specification expression. +! + +program a + character(len=:), allocatable :: s + integer :: i=10 + allocate(character(len=i)::s) +end program a diff --git a/Fortran/gfortran/regression/allocate_with_typespec_7.f90 b/Fortran/gfortran/regression/allocate_with_typespec_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_with_typespec_7.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! PR Fortran/83093 +! Contributed by Gerhard Steinmetz +program p + integer, parameter :: n(2) = [1,2] + real :: x = 2 + character(:), allocatable :: z, zz, zzz + character(:), allocatable :: y, yy + allocate (character(a) :: z) ! { dg-error "Scalar INTEGER expression" } + allocate (character(x) :: zz) ! { dg-error "Scalar INTEGER expression" } + allocate (character((1.0)) :: z) ! { dg-error "Scalar INTEGER expression" } + allocate (character(y) :: y) ! { dg-error "Scalar INTEGER expression" } + allocate (character(n(1:2)) :: y)! { dg-error "Scalar INTEGER expression" } +end diff --git a/Fortran/gfortran/regression/allocate_zerosize_1.f90 b/Fortran/gfortran/regression/allocate_zerosize_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_zerosize_1.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +program main + implicit none + real, allocatable :: a(:), b(:,:) + integer :: n,m + character (len=2) :: one, two + + one = ' 1' + two = ' 2' + + allocate (a(1:-1)) + if (size(a) /= 0) STOP 1 + deallocate (a) + + allocate (b(1:-1,0:10)) + if (size(b) /= 0) STOP 2 + deallocate (b) + + ! Use variables for array bounds. The internal reads + ! are there to hide fact that these are actually constant. + + read (unit=one, fmt='(I2)') n + allocate (a(n:-1)) + if (size(a) /= 0) STOP 3 + deallocate (a) + + read (unit=two, fmt='(I2)') m + allocate (b(1:3, m:0)) + if (size(b) /= 0) STOP 4 + deallocate (b) +end program main diff --git a/Fortran/gfortran/regression/allocate_zerosize_2.f90 b/Fortran/gfortran/regression/allocate_zerosize_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocate_zerosize_2.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! PR 27980 - We used to allocate negative amounts of memory +! for functions returning arrays if lbound > ubound-1. +! Based on a test case by beliavsky@aol.com posted to +! comp.lang.fortran. +program xint_func + implicit none + integer, parameter :: n=3,ii(n)=(/2,0,-1/) + integer :: i + character(len=80) :: line + do i=1,n + write (line,'(10I5)') int_func(ii(i)) + end do +contains + function int_func(n) result(ivec) + integer, intent(in) :: n + integer :: ivec(n) + integer :: i + if (n > 0) then + forall (i=1:n) ivec(i) = i + end if + end function int_func +end program xint_func diff --git a/Fortran/gfortran/regression/allocate_zerosize_3.f b/Fortran/gfortran/regression/allocate_zerosize_3.f --- /dev/null +++ b/Fortran/gfortran/regression/allocate_zerosize_3.f @@ -0,0 +1,40 @@ +C { dg-do run } +C Test the fix for PR35698, in which the negative size dimension would +C throw out the subsequent bounds. +C +C Contributed by Dick Hendrickson +C + program try_lf0030 + call LF0030(10) + end + + SUBROUTINE LF0030(nf10) + INTEGER ILA1(7) + INTEGER ILA2(7) + LOGICAL LLA(:,:,:,:,:,:,:) + INTEGER ICA(7) + ALLOCATABLE LLA + + + ALLOCATE (LLA(2:3, 4, 0:5, + $ NF10:1, -2:7, -3:8, + $ -4:9)) + + ILA1 = LBOUND(LLA) + ILA2 = UBOUND(LLA) +C CORRECT FOR THE ZERO DIMENSIONED TERM TO ALLOW AN EASIER VERIFY + ILA1(4) = ILA1(4) - 2 ! 1 - 2 = -1 + ILA2(4) = ILA2(4) + 6 ! 0 + 6 = 6 + + DO J1 = 1,7 + IVAL = 3-J1 + IF (ILA1(J1) .NE. IVAL) STOP 1 + 100 ENDDO + + DO J1 = 1,7 + IVAL = 2+J1 + IF (ILA2(J1) .NE. IVAL) STOP 2 + 101 ENDDO + + END SUBROUTINE + \ No newline at end of file diff --git a/Fortran/gfortran/regression/allocated_1.f90 b/Fortran/gfortran/regression/allocated_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocated_1.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +program foo + + implicit none + + integer, allocatable :: x + integer, allocatable :: a(:) + + logical a1, a2 + + a1 = allocated(scalar=x) + if (a1 .neqv. .false.) stop 1 + a2 = allocated(array=a) + if (a2 .neqv. .false.) stop 2 + + allocate(x) + allocate(a(2)) + + a1 = allocated(scalar=x) + if (a1 .neqv. .true.) stop 3 + a2 = allocated(array=a) + if (a2 .neqv. .true.) stop 4 + +end program foo diff --git a/Fortran/gfortran/regression/allocated_2.f90 b/Fortran/gfortran/regression/allocated_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocated_2.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +program foo + + implicit none + + integer, allocatable :: x + integer, allocatable :: a(:) + + logical a1, a2 + + a1 = allocated(scalar=a) ! { dg-error "Scalar entity required" } + a2 = allocated(array=x) ! { dg-error "Array entity required" } + a1 = allocated(scalar=x, array=a) ! { dg-error "Too many arguments" } + a1 = allocated(array=a, scalar=x) ! { dg-error "Too many arguments" } + +end program foo diff --git a/Fortran/gfortran/regression/allocated_3.f90 b/Fortran/gfortran/regression/allocated_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/allocated_3.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR fortran/91551 +! Contributed by Gerhard Steinmetz +program p + if (allocated()) stop 1 ! { dg-error "requires an array or scalar allocatable" } +end diff --git a/Fortran/gfortran/regression/altreturn_1.f90 b/Fortran/gfortran/regression/altreturn_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/altreturn_1.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-std=gnu" } + + subroutine foo (a) + real t, a, baz + call bar (*10) + t = 2 * baz () + IF (t.gt.0) t = baz () +10 END diff --git a/Fortran/gfortran/regression/altreturn_10.f90 b/Fortran/gfortran/regression/altreturn_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/altreturn_10.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options -Os } +! PR 78865 - this used to ICE. +program p + call sub (3) +end +subroutine sub (x) + integer :: x, i, n + do i = 1, x + if ( n /= 0 ) stop + call sub2 + end do + print *, x, n +end +subroutine sub2 + call sub (*99) ! { dg-error "Unexpected alternate return specifier" } + call sub (99.) ! { dg-error "Type mismatch in argument" } +99 stop +end diff --git a/Fortran/gfortran/regression/altreturn_11.f90 b/Fortran/gfortran/regression/altreturn_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/altreturn_11.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-prune-output "Obsolescent feature: Alternate-return argument" } +! PR fortran/99256 - ICE in variable_check +! Contributed by G.Steimetz + +program test + use iso_c_binding + type(c_ptr) :: i + type(c_funptr) :: p + call move_alloc (*1, *2) ! { dg-error "ALTERNATE RETURN" } + call c_f_pointer (i, *1) ! { dg-error "ALTERNATE RETURN" } + call c_f_procpointer (p, *2) ! { dg-error "ALTERNATE RETURN" } +1 continue +2 stop +end diff --git a/Fortran/gfortran/regression/altreturn_2.f90 b/Fortran/gfortran/regression/altreturn_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/altreturn_2.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-std=gnu" } + + program altreturn_2 + call foo() ! { dg-error "Missing alternate return" } + contains + subroutine foo(*) + return + end subroutine + end program diff --git a/Fortran/gfortran/regression/altreturn_3.f90 b/Fortran/gfortran/regression/altreturn_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/altreturn_3.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! { dg-options "-std=gnu" } +! +! Tests the fix for PR30236, which was due to alternate returns +! in generic interfaces causing a segfault. They now work +! correctly. +! +! Contributed by Brooks Moses +! +module arswitch + implicit none + interface gen + module procedure with + module procedure without + end interface +contains + subroutine with(i,*) + integer i + if (i>0) then + i = -1 + return 1 + else + i = -2 + return + end if + end subroutine + subroutine without() + return + end subroutine +end module + +program test + use arswitch + implicit none + integer :: i = 0 + call gen (i, *10) + if (i /= -2) STOP 1 + i = 2 + call gen (i, *20) + 10 continue + STOP 2 + 20 continue + if (i /= -1) STOP 3 +end diff --git a/Fortran/gfortran/regression/altreturn_4.f90 b/Fortran/gfortran/regression/altreturn_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/altreturn_4.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-std=gnu" } +! +! Tests the fix for PR28172, in which an ICE would result from +! the contained call with an alternate retrun. + +! Contributed by Tobias Schl�ter + +program blubb + call otherini(*998) + stop +998 stop +contains + subroutine init + call otherini(*999) + return +999 stop + end subroutine init +end program blubb diff --git a/Fortran/gfortran/regression/altreturn_5.f90 b/Fortran/gfortran/regression/altreturn_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/altreturn_5.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! { dg-options "-std=gnu" } +! +! Tests the fix for PR31483, in which dummy argument procedures +! produced an ICE if they had an alternate return. +! +! Contributed by Mathias Fr�hlich + + SUBROUTINE R (i, *, *) + INTEGER i + RETURN i + END + + SUBROUTINE PHLOAD (READER, i, res) + IMPLICIT NONE + EXTERNAL READER + integer i + character(3) res + CALL READER (i, *1, *2) + 1 res = "one" + return + 2 res = "two" + return + END + + EXTERNAL R + character(3) res + call PHLOAD (R, 1, res) + if (res .ne. "one") STOP 1 + CALL PHLOAD (R, 2, res) + if (res .ne. "two") STOP 2 + END diff --git a/Fortran/gfortran/regression/altreturn_6.f90 b/Fortran/gfortran/regression/altreturn_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/altreturn_6.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "-std=gnu" } +! +! PR 32938 +subroutine r (*) + integer(kind=8) :: i + return i +end diff --git a/Fortran/gfortran/regression/altreturn_7.f90 b/Fortran/gfortran/regression/altreturn_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/altreturn_7.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! { dg-options "-std=gnu" } +! +! PR 40848: [4.5 Regression] ICE with alternate returns +! +! Contributed by Joost VandeVondele + +MODULE TT + +INTERFACE M + MODULE PROCEDURE M1,M2 +END INTERFACE + +CONTAINS + + SUBROUTINE M1(I,*) + INTEGER :: I + RETURN 1 + END SUBROUTINE + + SUBROUTINE M2(I,J) + INTEGER :: I,J + END SUBROUTINE + +END MODULE + + + USE TT + CALL M(1,*2) + STOP 1 +2 CONTINUE +END diff --git a/Fortran/gfortran/regression/altreturn_8.f90 b/Fortran/gfortran/regression/altreturn_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/altreturn_8.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-std=gnu" } +! +! PR 56284: [OOP] ICE with alternate return in type-bound procedure +! +! Contributed by Arjen Markus + +module try_this + implicit none + + type :: table_t + contains + procedure, nopass :: getRecord + end type + +contains + + subroutine getRecord ( * ) + end subroutine + +end module diff --git a/Fortran/gfortran/regression/altreturn_9_0.f90 b/Fortran/gfortran/regression/altreturn_9_0.f90 --- /dev/null +++ b/Fortran/gfortran/regression/altreturn_9_0.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! { dg-options -std=gnu } +! { dg-additional-sources altreturn_9_1.f90 } +! PR 89496 - wrong type for alternate return was generated + +program main + call sub(10, *10, 20) + stop 1 +10 continue +end program main diff --git a/Fortran/gfortran/regression/altreturn_9_1.f90 b/Fortran/gfortran/regression/altreturn_9_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/altreturn_9_1.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! { dg-options "-std=gnu" } +! See altreturn_9_0.f90 +subroutine sub(i, *, j) + if (i == 10 .and. j == 20) return 1 + return +end subroutine sub diff --git a/Fortran/gfortran/regression/ambiguous_reference_1.f90 b/Fortran/gfortran/regression/ambiguous_reference_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/ambiguous_reference_1.f90 @@ -0,0 +1,49 @@ +! { dg-do compile } +! Tests the fix for PR33550, in which an ICE would occur, instead of +! the abiguous reference error. +! +! Found at +! http://groups.google.com/group/comp.lang.fortran/browse_thread/thread/1abc1549a6a164f1/ +! by James Van Buskirk: +! +module M1 + real x +end module M1 + +module M2 + contains + subroutine y + end subroutine y +end module M2 + +module M3 + use M2, x => y +end module M3 + +module M4 + use M1 + use M3 +end module M4 + +module M5 + use M4 ! 'x' is ambiguous here but is not referred to +end module M5 + +module M6 + use M5 ! ditto +end module M6 + +program test + use M1 + use M3 + interface + function x(z) ! { dg-error "ambiguous reference" } + end function x ! { dg-error "Expecting END INTERFACE" } + end interface + + write(*,*) 'Hello, world!' +end program test + +function x(z) + x = z +end function x diff --git a/Fortran/gfortran/regression/ambiguous_reference_2.f90 b/Fortran/gfortran/regression/ambiguous_reference_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/ambiguous_reference_2.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! +! PR 39930: Bogus error: ambiguous reference +! +! Contributed by Janus Weil + +module a1 +contains + subroutine myRoutine + end subroutine +end module + +module a2 +contains + subroutine myRoutine + end subroutine +end module + +module b +contains + + subroutine otherRoutine + use a1 + use a2 + end subroutine + + subroutine myRoutine + end subroutine myRoutine ! this is not ambiguous ! + +end module diff --git a/Fortran/gfortran/regression/ambiguous_specific_1.f90 b/Fortran/gfortran/regression/ambiguous_specific_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/ambiguous_specific_1.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! Checks the fix for PR33542, in which the ambiguity in the specific +! interfaces of foo was missed. +! +! Contributed by Tobias Burnus +! +MODULE M1 + INTERFACE FOO + MODULE PROCEDURE FOO + END INTERFACE +CONTAINS + SUBROUTINE FOO(I) + INTEGER, INTENT(IN) :: I + WRITE(*,*) 'INTEGER' + END SUBROUTINE FOO +END MODULE M1 + +MODULE M2 + INTERFACE FOO + MODULE PROCEDURE FOO + END INTERFACE +CONTAINS + SUBROUTINE FOO(R) + REAL, INTENT(IN) :: R + WRITE(*,*) 'REAL' + END SUBROUTINE FOO +END MODULE M2 + +PROGRAM P + USE M1 + USE M2 + implicit none + external bar + CALL FOO(10) + CALL FOO(10.) + call bar (foo) ! { dg-error "is ambiguous" } +END PROGRAM P diff --git a/Fortran/gfortran/regression/ambiguous_specific_2.f90 b/Fortran/gfortran/regression/ambiguous_specific_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/ambiguous_specific_2.f90 @@ -0,0 +1,41 @@ +! { dg-do compile } +! Checks the fix for PR33542 does not throw an error if there is no +! ambiguity in the specific interfaces of foo. +! +! Contributed by Tobias Burnus +! +MODULE M1 + INTERFACE FOO + MODULE PROCEDURE FOO + END INTERFACE +CONTAINS + SUBROUTINE FOO(I) + INTEGER, INTENT(IN) :: I + WRITE(*,*) 'INTEGER' + END SUBROUTINE FOO +END MODULE M1 + +MODULE M2 + INTERFACE FOO + MODULE PROCEDURE FOOFOO + END INTERFACE +CONTAINS + SUBROUTINE FOOFOO(R) + REAL, INTENT(IN) :: R + WRITE(*,*) 'REAL' + END SUBROUTINE FOOFOO +END MODULE M2 + +PROGRAM P + USE M1 + USE M2 + implicit none + external bar + CALL FOO(10) + CALL FOO(10.) + call bar (foo) +END PROGRAM P + +SUBROUTINE bar (arg) + EXTERNAL arg +END SUBROUTINE bar diff --git a/Fortran/gfortran/regression/and_or_xor.f90 b/Fortran/gfortran/regression/and_or_xor.f90 --- /dev/null +++ b/Fortran/gfortran/regression/and_or_xor.f90 @@ -0,0 +1,7 @@ +! { dg-do run } +program L + if (and(.TRUE._1, .TRUE._1) .neqv. .true.) STOP 1 + if (or(.TRUE._1, .TRUE._1) .neqv. .true.) STOP 2 + if (xor(.TRUE._1, .TRUE._1) .neqv. .false.) STOP 3 +end program L + diff --git a/Fortran/gfortran/regression/anint_1.f90 b/Fortran/gfortran/regression/anint_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/anint_1.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! Check the fix for PR33568 in which the optional KIND +! argument for ANINT, with an array for the first argument +! would cause an ICE. +! +! Contributed by Ignacio Fern�ndez Galv�n +! +PROGRAM Test + IMPLICIT NONE + INTEGER, PARAMETER :: DP=8 + REAL(DP), DIMENSION(1:3) :: A = (/1.76,2.32,7.66/), B + A = ANINT ( A , DP) + B = A + A = ANINT ( A) + if (any (A .ne. B)) STOP 1 +END PROGRAM Test diff --git a/Fortran/gfortran/regression/any_all_1.f90 b/Fortran/gfortran/regression/any_all_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/any_all_1.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! PR 34817 - the wrong library function was called, +! leading to garbage in the return value +program main + real, dimension(2,2) :: a + logical(kind=4), dimension(2) :: b + integer(kind=4), dimension(2) :: i + equivalence (b,i) + data a /1.0, 2.0, -0.1, -0.2 / + + i = 16843009 ! Initialize i to put junk into b + b = any(a>0.5,dim=1) + if (b(2) .or. .not. b(1)) STOP 1 + + i = 16843009 ! Initialize i to put junk into b + b = all(a>0.5,dim=1) + if (b(2) .or. .not. b(1)) STOP 2 +end program main diff --git a/Fortran/gfortran/regression/any_all_2.f90 b/Fortran/gfortran/regression/any_all_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/any_all_2.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! PR 34838 - this failed with "Can't convert LOGICAL(1) to LOGICAL(1) +! Test case contributed by Manfred Schwab. +program main + Logical(kind=1) :: bmp(1),bmpv(1) + + bmp(1)=.false. + bmpv(1)=.true. + + if ( ANY(bmp(1:1) .NEQV. bmpv(1:1)) ) then + print*,"hello" + end if + + if ( ALL(bmp(1:1) .NEQV. bmpv(1:1)) ) then + print*,"hello" + end if + +end program main diff --git a/Fortran/gfortran/regression/any_loc.f90 b/Fortran/gfortran/regression/any_loc.f90 --- /dev/null +++ b/Fortran/gfortran/regression/any_loc.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-ffrontend-optimize" } +! PR fortran/80142 - the location on the expression of the +! unrolled any statement was not correctly set. +! Test case by Harald Anlauf. +MODULE gfcbug140 + implicit none + integer ,parameter :: WV_NONE = 1 + integer, parameter :: WV_CDV_4 = 23 + integer, parameter :: WV_CDV_8 = 24 + integer, parameter :: wv_CDV_list(2) = [ WV_CDV_4, WV_CDV_8 ] + integer :: basis = WV_NONE +contains + subroutine wave_1d (x) + real, intent(inout) :: x(:,:) + integer :: oldbase + oldbase = basis + if (any (basis == wv_CDV_list(:))) then + end if + basis = oldbase + end subroutine wave_1d + !- + subroutine mr_gp_mat (A) + real, intent(inout) :: A (:,:) + call wave_1d (A) + end subroutine mr_gp_mat +end module gfcbug140 diff --git a/Fortran/gfortran/regression/anyallcount_1.f90 b/Fortran/gfortran/regression/anyallcount_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/anyallcount_1.f90 @@ -0,0 +1,71 @@ +! { dg-do run } +program main + character(len=*), parameter :: f='(3L1)' + character(len=*), parameter :: g='(3I1)' + real, dimension(3,3) :: a + logical(kind=1), dimension(3,3) :: m1 + logical(kind=2), dimension(3,3) :: m2 + logical(kind=4), dimension(3,3) :: m4 + logical(kind=8), dimension(3,3) :: m8 + character(len=3) :: res + data a /-1.0, -2.0, -3.0, 2.0, 1.0, -2.1, 1.0, 2.0, 3.0 / + + m1 = a > 0 + m2 = a > 0 + m4 = a > 0 + m8 = a > 0 + + write (unit=res,fmt=f) any(m1,dim=1) + if (res /= 'FTT') STOP 1 + write (unit=res,fmt=f) any(m2,dim=1) + if (res /= 'FTT') STOP 2 + write (unit=res,fmt=f) any(m4,dim=1) + if (res /= 'FTT') STOP 3 + write (unit=res,fmt=f) any(m8,dim=1) + if (res /= 'FTT') STOP 4 + write (unit=res,fmt=f) any(m1,dim=2) + if (res /= 'TTT') STOP 5 + write (unit=res,fmt=f) any(m2,dim=2) + if (res /= 'TTT') STOP 6 + write (unit=res,fmt=f) any(m4,dim=2) + if (res /= 'TTT') STOP 7 + write (unit=res,fmt=f) any(m8,dim=2) + if (res /= 'TTT') STOP 8 + + write (unit=res,fmt=f) all(m1,dim=1) + if (res /= 'FFT') STOP 9 + write (unit=res,fmt=f) all(m2,dim=1) + if (res /= 'FFT') STOP 10 + write (unit=res,fmt=f) all(m4,dim=1) + if (res /= 'FFT') STOP 11 + write (unit=res,fmt=f) all(m8,dim=1) + if (res /= 'FFT') STOP 12 + + write (unit=res,fmt=f) all(m1,dim=2) + if (res /= 'FFF') STOP 13 + write (unit=res,fmt=f) all(m2,dim=2) + if (res /= 'FFF') STOP 14 + write (unit=res,fmt=f) all(m4,dim=2) + if (res /= 'FFF') STOP 15 + write (unit=res,fmt=f) all(m8,dim=2) + if (res /= 'FFF') STOP 16 + + write (unit=res,fmt=g) count(m1,dim=1) + if (res /= '023') STOP 17 + write (unit=res,fmt=g) count(m2,dim=1) + if (res /= '023') STOP 18 + write (unit=res,fmt=g) count(m4,dim=1) + if (res /= '023') STOP 19 + write (unit=res,fmt=g) count(m8,dim=1) + if (res /= '023') STOP 20 + + write (unit=res,fmt=g) count(m1,dim=2) + if (res /= '221') STOP 21 + write (unit=res,fmt=g) count(m2,dim=2) + if (res /= '221') STOP 22 + write (unit=res,fmt=g) count(m4,dim=2) + if (res /= '221') STOP 23 + write (unit=res,fmt=g) count(m8,dim=2) + if (res /= '221') STOP 24 + +end program main diff --git a/Fortran/gfortran/regression/append_1.f90 b/Fortran/gfortran/regression/append_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/append_1.f90 @@ -0,0 +1,36 @@ +! PR libfortran/21471 +! Testing POSITION="APPEND" +! +! { dg-do run } + subroutine failed + close (10,status='delete') + STOP 1 + end subroutine failed + + integer,parameter :: n = 13 + integer :: i, j, error + + open (10, file='foo') + close (10) + + do i = 1, n + open (10, file='foo',position='append') + write (10,*) i + close (10) + end do + + open (10,file='foo',status='old') + error = 0 + i = -1 + do while (error == 0) + i = i + 1 + read (10,*,iostat=error) j + if (error == 0) then + if (i + 1 /= j) call failed + end if + if (i > n + 1) call failed + end do + if (i /= n) call failed + close (10,status='delete') + end + diff --git a/Fortran/gfortran/regression/argument_checking_1.f90 b/Fortran/gfortran/regression/argument_checking_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/argument_checking_1.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! +! PR fortran/30940 +program main + implicit none + character(len=10) :: digit_string = '123456789', str + character :: digit_arr(10) + call copy(digit_string, digit_arr) + call copy(digit_arr,str) + if(str /= '123456789') STOP 1 + digit_string = 'qwertasdf' + call copy2(digit_string, digit_arr) + call copy2(digit_arr,str) + if(str /= 'qwertasdf') STOP 2 + digit_string = '1qayxsw23e' + call copy3("1qayxsw23e", digit_arr) + call copy3(digit_arr,str) + if(str /= '1qayxsw23e') STOP 3 +contains + subroutine copy(in, out) + character, dimension(*) :: in + character, dimension(10) :: out + out = in(:10) + end subroutine copy + subroutine copy2(in, out) + character, dimension(2,*) :: in + character, dimension(2,5) :: out + out(1:2,1:5) = in(1:2,1:5) + end subroutine copy2 + subroutine copy3(in, out) + character(len=2), dimension(5) :: in + character(len=2), dimension(5) :: out + out = in + end subroutine copy3 +end program main diff --git a/Fortran/gfortran/regression/argument_checking_10.f90 b/Fortran/gfortran/regression/argument_checking_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/argument_checking_10.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR fortran/34425 +! +! Contributed by Joost VandeVondele +! +IMPLICIT NONE +INTEGER :: i(-1:1) +INTEGER :: j(-2:-1) +CALL S(i) +CALL S(j) ! { dg-error "Actual argument contains too few elements for dummy argument 'i' .2/3." } +CONTAINS + SUBROUTINE S(i) + INTEGER :: i(0:2) + END SUBROUTINE +END diff --git a/Fortran/gfortran/regression/argument_checking_11.f90 b/Fortran/gfortran/regression/argument_checking_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/argument_checking_11.f90 @@ -0,0 +1,285 @@ +! { dg-do compile } +! { dg-options "-std=f95 -fmax-errors=100" } +! +! PR fortran/34665 +! +! Test argument checking +! +! TODO: Check also expressions, e.g. "(a(1))" instead of "a(1) +! for strings; check also "string" and [ "string" ] +! +implicit none +CONTAINS +SUBROUTINE test1(a,b,c,d,e) + integer, dimension(:) :: a + integer, pointer, dimension(:) :: b + integer, dimension(*) :: c + integer, dimension(5) :: d + integer :: e + + call as_size(a) + call as_size(b) + call as_size(c) + call as_size(d) + call as_size(e) ! { dg-error "Rank mismatch" } + call as_size(1) ! { dg-error "Rank mismatch" } + call as_size( (/ 1 /) ) + call as_size( (a) ) + call as_size( (b) ) + call as_size( (c) ) ! { dg-error "The upper bound in the last dimension must appear in the reference to the assumed size array" } + call as_size( (d) ) + call as_size( (e) ) ! { dg-error "Rank mismatch" } + call as_size(a(1)) ! { dg-error "Element of assumed-shape" } + call as_size(b(1)) ! { dg-error "Element of assumed-shape" } + call as_size(c(1)) + call as_size(d(1)) + call as_size( (a(1)) ) ! { dg-error "Rank mismatch" } + call as_size( (b(1)) ) ! { dg-error "Rank mismatch" } + call as_size( (c(1)) ) ! { dg-error "Rank mismatch" } + call as_size( (d(1)) ) ! { dg-error "Rank mismatch" } + call as_size(a(1:2)) + call as_size(b(1:2)) + call as_size(c(1:2)) + call as_size(d(1:2)) + call as_size( (a(1:2)) ) + call as_size( (b(1:2)) ) + call as_size( (c(1:2)) ) + call as_size( (d(1:2)) ) + + call as_shape(a) + call as_shape(b) + call as_shape(c) ! { dg-error "cannot be an assumed-size array" } + call as_shape(d) + call as_shape(e) ! { dg-error "Rank mismatch" } + call as_shape( 1 ) ! { dg-error "Rank mismatch" } + call as_shape( (/ 1 /) ) + call as_shape( (a) ) + call as_shape( (b) ) + call as_shape( (c) ) ! { dg-error "The upper bound in the last dimension must appear in the reference to the assumed size array" } + call as_shape( (d) ) + call as_shape( (e) ) ! { dg-error "Rank mismatch" } + call as_shape( (1) ) ! { dg-error "Rank mismatch" } + call as_shape( ((/ 1 /)) ) + call as_shape(a(1)) ! { dg-error "Rank mismatch" } + call as_shape(b(1)) ! { dg-error "Rank mismatch" } + call as_shape(c(1)) ! { dg-error "Rank mismatch" } + call as_shape(d(1)) ! { dg-error "Rank mismatch" } + call as_shape( (a(1)) ) ! { dg-error "Rank mismatch" } + call as_shape( (b(1)) ) ! { dg-error "Rank mismatch" } + call as_shape( (c(1)) ) ! { dg-error "Rank mismatch" } + call as_shape( (d(1)) ) ! { dg-error "Rank mismatch" } + call as_shape(a(1:2)) + call as_shape(b(1:2)) + call as_shape(c(1:2)) + call as_shape(d(1:2)) + call as_shape( (a(1:2)) ) + call as_shape( (b(1:2)) ) + call as_shape( (c(1:2)) ) + call as_shape( (d(1:2)) ) + + call as_expl(a) + call as_expl(b) + call as_expl(c) + call as_expl(d) + call as_expl(e) ! { dg-error "Rank mismatch" } + call as_expl( 1 ) ! { dg-error "Rank mismatch" } + call as_expl( (/ 1, 2, 3 /) ) + call as_expl( (a) ) + call as_expl( (b) ) + call as_expl( (c) ) ! { dg-error "The upper bound in the last dimension must appear in the reference to the assumed size array" } + call as_expl( (d) ) + call as_expl( (e) ) ! { dg-error "Rank mismatch" } + call as_expl(a(1)) ! { dg-error "Element of assumed-shape" } + call as_expl(b(1)) ! { dg-error "Element of assumed-shape" } + call as_expl(c(1)) + call as_expl(d(1)) + call as_expl( (a(1)) ) ! { dg-error "Rank mismatch" } + call as_expl( (b(1)) ) ! { dg-error "Rank mismatch" } + call as_expl( (c(1)) ) ! { dg-error "Rank mismatch" } + call as_expl( (d(1)) ) ! { dg-error "Rank mismatch" } + call as_expl(a(1:3)) + call as_expl(b(1:3)) + call as_expl(c(1:3)) + call as_expl(d(1:3)) + call as_expl( (a(1:3)) ) + call as_expl( (b(1:3)) ) + call as_expl( (c(1:3)) ) + call as_expl( (d(1:3)) ) +END SUBROUTINE test1 + +SUBROUTINE as_size(a) + integer, dimension(*) :: a +END SUBROUTINE as_size + +SUBROUTINE as_shape(a) + integer, dimension(:) :: a +END SUBROUTINE as_shape + +SUBROUTINE as_expl(a) + integer, dimension(3) :: a +END SUBROUTINE as_expl + + +SUBROUTINE test2(a,b,c,d,e) + character(len=*), dimension(:) :: a + character(len=*), pointer, dimension(:) :: b + character(len=*), dimension(*) :: c + character(len=*), dimension(5) :: d + character(len=*) :: e + + call cas_size(a) + call cas_size(b) + call cas_size(c) + call cas_size(d) + call cas_size(e) ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_size("abc") ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_size( (/"abc"/) ) + call cas_size(a//"a") + call cas_size(b//"a") + call cas_size(c//"a") ! { dg-error "The upper bound in the last dimension must appear in the reference to the assumed size array" } + call cas_size(d//"a") + call cas_size(e//"a") ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_size(("abc")) ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_size( ((/"abc"/)) ) + call cas_size(a(1)) ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_size(b(1)) ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_size(c(1)) ! OK in F95 + call cas_size(d(1)) ! OK in F95 + call cas_size((a(1)//"a")) ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_size((b(1)//"a")) ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_size((c(1)//"a")) ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_size((d(1)//"a")) ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_size(a(1:2)) + call cas_size(b(1:2)) + call cas_size(c(1:2)) + call cas_size(d(1:2)) + call cas_size((a(1:2)//"a")) + call cas_size((b(1:2)//"a")) + call cas_size((c(1:2)//"a")) + call cas_size((d(1:2)//"a")) + call cas_size(a(:)(1:3)) + call cas_size(b(:)(1:3)) + call cas_size(d(:)(1:3)) + call cas_size((a(:)(1:3)//"a")) + call cas_size((b(:)(1:3)//"a")) + call cas_size((d(:)(1:3)//"a")) + call cas_size(a(1:2)(1:3)) + call cas_size(b(1:2)(1:3)) + call cas_size(c(1:2)(1:3)) + call cas_size(d(1:2)(1:3)) + call cas_size((a(1:2)(1:3)//"a")) + call cas_size((b(1:2)(1:3)//"a")) + call cas_size((c(1:2)(1:3)//"a")) + call cas_size((d(1:2)(1:3)//"a")) + call cas_size(e(1:3)) ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_size("abcd"(1:3)) ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_size((e(1:3))) ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_size(("abcd"(1:3)//"a")) ! { dg-error "Fortran 2003: Scalar CHARACTER" } + + call cas_shape(a) + call cas_shape(b) + call cas_shape(c) ! { dg-error "cannot be an assumed-size array" } + call cas_shape(d) + call cas_shape(e) ! { dg-error "Rank mismatch" } + call cas_shape("abc") ! { dg-error "Rank mismatch" } + call cas_shape( (/"abc"/) ) + call cas_shape(a//"c") + call cas_shape(b//"c") + call cas_shape(c//"c") ! { dg-error "The upper bound in the last dimension must appear in the reference to the assumed size array" } + call cas_shape(d//"c") + call cas_shape(e//"c") ! { dg-error "Rank mismatch" } + call cas_shape(("abc")) ! { dg-error "Rank mismatch" } + call cas_shape( ((/"abc"/)) ) + call cas_shape(a(1)) ! { dg-error "Rank mismatch" } + call cas_shape(b(1)) ! { dg-error "Rank mismatch" } + call cas_shape(c(1)) ! { dg-error "Rank mismatch" } + call cas_shape(d(1)) ! { dg-error "Rank mismatch" } + call cas_shape(a(1:2)) + call cas_shape(b(1:2)) + call cas_shape(c(1:2)) + call cas_shape(d(1:2)) + call cas_shape((a(1:2)//"a")) + call cas_shape((b(1:2)//"a")) + call cas_shape((c(1:2)//"a")) + call cas_shape((d(1:2)//"a")) + call cas_shape(a(:)(1:3)) + call cas_shape(b(:)(1:3)) + call cas_shape(d(:)(1:3)) + call cas_shape((a(:)(1:3)//"a")) + call cas_shape((b(:)(1:3)//"a")) + call cas_shape((d(:)(1:3)//"a")) + call cas_shape(a(1:2)(1:3)) + call cas_shape(b(1:2)(1:3)) + call cas_shape(c(1:2)(1:3)) + call cas_shape(d(1:2)(1:3)) + call cas_shape((a(1:2)(1:3)//"a")) + call cas_shape((b(1:2)(1:3)//"a")) + call cas_shape((c(1:2)(1:3)//"a")) + call cas_shape((d(1:2)(1:3)//"a")) + call cas_size(e(1:3)) ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_size("abcd"(1:3)) ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_size((e(1:3))) ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_size(("abcd"(1:3)//"a")) ! { dg-error "Fortran 2003: Scalar CHARACTER" } + + call cas_expl(a) + call cas_expl(b) + call cas_expl(c) + call cas_expl(d) + call cas_expl(e) ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_expl("abc") ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_expl((/"a","b","c"/)) + call cas_expl(a//"a") + call cas_expl(b//"a") + call cas_expl(c//"a") ! { dg-error "The upper bound in the last dimension must appear in the reference to the assumed size array" } + call cas_expl(d//"a") + call cas_expl(e//"a") ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_expl(("abc")) ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_expl(((/"a","b","c"/))) + call cas_expl(a(1)) ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_expl(b(1)) ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_expl(c(1)) ! OK in F95 + call cas_expl(d(1)) ! OK in F95 + call cas_expl((a(1)//"a")) ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_expl((b(1)//"a")) ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_expl((c(1)//"a")) ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_expl((d(1)//"a")) ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_expl(a(1:3)) + call cas_expl(b(1:3)) + call cas_expl(c(1:3)) + call cas_expl(d(1:3)) + call cas_expl((a(1:3)//"a")) + call cas_expl((b(1:3)//"a")) + call cas_expl((c(1:3)//"a")) + call cas_expl((d(1:3)//"a")) + call cas_expl(a(:)(1:3)) + call cas_expl(b(:)(1:3)) + call cas_expl(d(:)(1:3)) + call cas_expl((a(:)(1:3))) + call cas_expl((b(:)(1:3))) + call cas_expl((d(:)(1:3))) + call cas_expl(a(1:2)(1:3)) + call cas_expl(b(1:2)(1:3)) + call cas_expl(c(1:2)(1:3)) + call cas_expl(d(1:2)(1:3)) + call cas_expl((a(1:2)(1:3)//"a")) + call cas_expl((b(1:2)(1:3)//"a")) + call cas_expl((c(1:2)(1:3)//"a")) + call cas_expl((d(1:2)(1:3)//"a")) + call cas_expl(e(1:3)) ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_expl("abcd"(1:3)) ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_expl((e(1:3))) ! { dg-error "Fortran 2003: Scalar CHARACTER" } + call cas_expl(("abcd"(1:3)//"a")) ! { dg-error "Fortran 2003: Scalar CHARACTER" } +END SUBROUTINE test2 + +SUBROUTINE cas_size(a) + character(len=*), dimension(*) :: a +END SUBROUTINE cas_size + +SUBROUTINE cas_shape(a) + character(len=*), dimension(:) :: a +END SUBROUTINE cas_shape + +SUBROUTINE cas_expl(a) + character(len=*), dimension(3) :: a +END SUBROUTINE cas_expl +END diff --git a/Fortran/gfortran/regression/argument_checking_12.f90 b/Fortran/gfortran/regression/argument_checking_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/argument_checking_12.f90 @@ -0,0 +1,59 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/34665 +! +! Test argument checking +! +implicit none +CONTAINS +SUBROUTINE test2(a,b,c,d,e) + character(len=*), dimension(:) :: a + character(len=*), pointer, dimension(:) :: b + character(len=*), dimension(*) :: c + character(len=*), dimension(5) :: d + character(len=*) :: e + + call cas_size(e) + call cas_size("abc") + call cas_size(e//"a") + call cas_size(("abc")) + call cas_size(a(1)) + call cas_size(b(1)) + call cas_size((a(1)//"a")) + call cas_size((b(1)//"a")) + call cas_size((c(1)//"a")) + call cas_size((d(1)//"a")) + call cas_size(e(1:3)) + call cas_size("abcd"(1:3)) + call cas_size((e(1:3))) + call cas_size(("abcd"(1:3)//"a")) + call cas_size(e(1:3)) + call cas_size("abcd"(1:3)) + call cas_size((e(1:3))) + call cas_size(("abcd"(1:3)//"a")) + call cas_expl(e) + call cas_expl("abc") + call cas_expl(e//"a") + call cas_expl(("abc")) + call cas_expl(a(1)) + call cas_expl(b(1)) + call cas_expl((a(1)//"a")) + call cas_expl((b(1)//"a")) + call cas_expl((c(1)//"a")) + call cas_expl((d(1)//"a")) + call cas_expl(e(1:3)) + call cas_expl("abcd"(1:3)) + call cas_expl((e(1:3))) + call cas_expl(("abcd"(1:3)//"a")) +END SUBROUTINE test2 + +SUBROUTINE cas_size(a) + character(len=*), dimension(*) :: a +END SUBROUTINE cas_size + +SUBROUTINE cas_expl(a) + character(len=*), dimension(5) :: a +END SUBROUTINE cas_expl +END + diff --git a/Fortran/gfortran/regression/argument_checking_13.f90 b/Fortran/gfortran/regression/argument_checking_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/argument_checking_13.f90 @@ -0,0 +1,83 @@ +! { dg-do compile } +! +! PR fortran/34796 +! +! Argument checks: +! - elements of deferred-shape arrays (= non-dummies) are allowed +! as the memory is contiguous +! - while assumed-shape arrays (= dummy arguments) and pointers are +! not (strides can make them non-contiguous) +! and +! - if the memory is non-contigous, character arguments have as +! storage size only the size of the element itself, check for +! too short actual arguments. +! +subroutine test1(assumed_sh_dummy, pointer_dummy) +implicit none +interface + subroutine rlv1(y) + real :: y(3) + end subroutine rlv1 +end interface + +real :: assumed_sh_dummy(:,:,:) +real, pointer :: pointer_dummy(:,:,:) + +real, allocatable :: deferred(:,:,:) +real, pointer :: ptr(:,:,:) +call rlv1(deferred(1,1,1)) ! valid since contiguous +call rlv1(ptr(1,1,1)) ! { dg-error "Element of assumed-shape or pointer array" } +call rlv1(assumed_sh_dummy(1,1,1)) ! { dg-error "Element of assumed-shape or pointer array" } +call rlv1(pointer_dummy(1,1,1)) ! { dg-error "Element of assumed-shape or pointer array" } +end + +subroutine test2(assumed_sh_dummy, pointer_dummy) +implicit none +interface + subroutine rlv2(y) + character :: y(3) + end subroutine rlv2 +end interface + +character(3) :: assumed_sh_dummy(:,:,:) +character(3), pointer :: pointer_dummy(:,:,:) + +character(3), allocatable :: deferred(:,:,:) +character(3), pointer :: ptr(:,:,:) +call rlv2(deferred(1,1,1)) ! Valid since contiguous +call rlv2(ptr(1,1,1)) ! Valid F2003 +call rlv2(assumed_sh_dummy(1,1,1)) ! Valid F2003 +call rlv2(pointer_dummy(1,1,1)) ! Valid F2003 + +! The following is kind of ok: The memory access it valid +! We warn nonetheless as the result is not what is intented +! and also formally wrong. +! Using (1:string_length) would be ok. +call rlv2(ptr(1,1,1)(1:1)) ! { dg-error "contains too few elements" } +call rlv2(assumed_sh_dummy(1,1,1)(1:2)) ! { dg-error "contains too few elements" } +call rlv2(pointer_dummy(1,1,1)(1:3)) ! Valid F2003 +end + +subroutine test3(assumed_sh_dummy, pointer_dummy) +implicit none +interface + subroutine rlv3(y) + character :: y(3) + end subroutine rlv3 +end interface + +character(2) :: assumed_sh_dummy(:,:,:) +character(2), pointer :: pointer_dummy(:,:,:) + +character(2), allocatable :: deferred(:,:,:) +character(2), pointer :: ptr(:,:,:) +call rlv3(deferred(1,1,1)) ! Valid since contiguous +call rlv3(ptr(1,1,1)) ! { dg-error "contains too few elements" } +call rlv3(assumed_sh_dummy(1,1,1)) ! { dg-error "contains too few elements" } +call rlv3(pointer_dummy(1,1,1)) ! { dg-error "contains too few elements" } + +call rlv3(deferred(1,1,1)(1:2)) ! Valid since contiguous +call rlv3(ptr(1,1,1)(1:2)) ! { dg-error "contains too few elements" } +call rlv3(assumed_sh_dummy(1,1,1)(1:2)) ! { dg-error "contains too few elements" } +call rlv3(pointer_dummy(1,1,1)(1:2)) ! { dg-error "contains too few elements" } +end diff --git a/Fortran/gfortran/regression/argument_checking_14.f90 b/Fortran/gfortran/regression/argument_checking_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/argument_checking_14.f90 @@ -0,0 +1,68 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! PR fortran/34796 +! +! This checks for Fortran 2003 extensions. +! +! Argument checks: +! - elements of deferred-shape arrays (= non-dummies) are allowed +! as the memory is contiguous +! - while assumed-shape arrays (= dummy arguments) and pointers are +! not (strides can make them non-contiguous) +! and +! - if the memory is non-contigous, character arguments have as +! storage size only the size of the element itself, check for +! too short actual arguments. +! +subroutine test2(assumed_sh_dummy, pointer_dummy) +implicit none +interface + subroutine rlv2(y) + character :: y(3) + end subroutine rlv2 +end interface + +character(3) :: assumed_sh_dummy(:,:,:) +character(3), pointer :: pointer_dummy(:,:,:) + +character(3), allocatable :: deferred(:,:,:) +character(3), pointer :: ptr(:,:,:) +call rlv2(deferred(1,1,1)) ! Valid since contiguous +call rlv2(ptr(1,1,1)) ! { dg-error "Fortran 2003: Scalar CHARACTER actual" } +call rlv2(assumed_sh_dummy(1,1,1)) ! { dg-error "Fortran 2003: Scalar CHARACTER actual" } +call rlv2(pointer_dummy(1,1,1)) ! { dg-error "Fortran 2003: Scalar CHARACTER actual" } + +! The following is kind of ok: The memory access it valid +! We warn nonetheless as the result is not what is intented +! and also formally wrong. +! Using (1:string_length) would be ok. +call rlv2(deferred(1,1,1)(1:3)) ! OK +call rlv2(ptr(1,1,1)(1:1)) ! { dg-error "Fortran 2003: Scalar CHARACTER actual" } +call rlv2(assumed_sh_dummy(1,1,1)(1:2)) ! { dg-error "Fortran 2003: Scalar CHARACTER actual" } +call rlv2(pointer_dummy(1,1,1)(1:3)) ! { dg-error "Fortran 2003: Scalar CHARACTER actual" } +end + +subroutine test3(assumed_sh_dummy, pointer_dummy) +implicit none +interface + subroutine rlv3(y) + character :: y(2) + end subroutine rlv3 +end interface + +character(2) :: assumed_sh_dummy(:,:,:) +character(2), pointer :: pointer_dummy(:,:,:) + +character(2), allocatable :: deferred(:,:,:) +character(2), pointer :: ptr(:,:,:) +call rlv3(deferred(1,1,1)) ! Valid since contiguous +call rlv3(ptr(1,1,1)) ! { dg-error "Fortran 2003: Scalar CHARACTER actual" } +call rlv3(assumed_sh_dummy(1,1,1)) ! { dg-error "Fortran 2003: Scalar CHARACTER actual" } +call rlv3(pointer_dummy(1,1,1)) ! { dg-error "Fortran 2003: Scalar CHARACTER actual" } + +call rlv3(deferred(1,1,1)(1:2)) ! Valid since contiguous +call rlv3(ptr(1,1,1)(1:2)) ! { dg-error "Fortran 2003: Scalar CHARACTER actual" } +call rlv3(assumed_sh_dummy(1,1,1)(1:2)) ! { dg-error "Fortran 2003: Scalar CHARACTER actual" } +call rlv3(pointer_dummy(1,1,1)(1:2)) ! { dg-error "Fortran 2003: Scalar CHARACTER actual" } +end diff --git a/Fortran/gfortran/regression/argument_checking_15.f90 b/Fortran/gfortran/regression/argument_checking_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/argument_checking_15.f90 @@ -0,0 +1,57 @@ +! { dg-do compile } +! +! PR fortran/32616 +! +! Check for to few elements of the actual argument +! and reject mismatching string lengths for assumed-shape dummies +! +implicit none +external test +integer :: i(10) +integer :: j(2,2) +character(len=4) :: str(2) +character(len=4) :: str2(2,2) + +call test() + +call foo(i(8)) ! { dg-error "too few elements for dummy argument 'a' .3/4." } +call foo(j(1,1)) +call foo(j(2,1)) ! { dg-error "too few elements for dummy argument 'a' .3/4." } +call foo(j(1,2)) ! { dg-error "too few elements for dummy argument 'a' .2/4." } + +str = 'FORT' +str2 = 'fort' +call bar(str(:)(1:2)) ! { dg-error "too few elements for dummy argument 'c' .4/6." } +call bar(str(1:2)(1:1)) ! { dg-error "too few elements for dummy argument 'c' .2/6." } +call bar(str(2)) ! { dg-error "too few elements for dummy argument 'c' .4/6." } +call bar(str(1)(2:1)) ! OK +call bar(str2(2,1)(4:1)) ! OK +call bar(str2(1,2)(3:4)) ! OK +call bar(str2(1,2)(4:4)) ! { dg-error "too few elements for dummy argument 'c' .5/6." } +contains + subroutine foo(a) + integer :: a(4) + end subroutine foo + subroutine bar(c) + character(len=2) :: c(3) +! print '(3a)', ':',c(1),':' +! print '(3a)', ':',c(2),':' +! print '(3a)', ':',c(3),':' + end subroutine bar +end + + +subroutine test() +implicit none +character(len=5), pointer :: c +character(len=5) :: str(5) +call foo(c) ! { dg-warning "Character length mismatch" } +call bar(str) ! { dg-warning "Character length mismatch" } +contains + subroutine foo(a) + character(len=3), pointer :: a + end subroutine + subroutine bar(a) + character(len=3) :: a(:) + end subroutine bar +end subroutine test diff --git a/Fortran/gfortran/regression/argument_checking_16.f90 b/Fortran/gfortran/regression/argument_checking_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/argument_checking_16.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/35152 - implicit procedure with keyword=argument + +external bar + +call bar(a=5) ! { dg-error "requires explicit interface" } +call foo(a=5) ! { dg-error "requires explicit interface" } +end + diff --git a/Fortran/gfortran/regression/argument_checking_17.f90 b/Fortran/gfortran/regression/argument_checking_17.f90 --- /dev/null +++ b/Fortran/gfortran/regression/argument_checking_17.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! +! PR fortran/47569 +! +! Contributed by Jos de Kloe +! +module teststr + implicit none + integer, parameter :: GRH_SIZE = 20, NMAX = 41624 + type strtype + integer :: size + character :: mdr(NMAX) + end type strtype +contains + subroutine sub2(string,str_size) + integer,intent(in) :: str_size + character,intent(out) :: string(str_size) + string(:) = 'a' + end subroutine sub2 + subroutine sub1(a) + type(strtype),intent(inout) :: a + call sub2(a%mdr(GRH_SIZE+1),a%size-GRH_SIZE) + end subroutine sub1 +end module teststr diff --git a/Fortran/gfortran/regression/argument_checking_18.f90 b/Fortran/gfortran/regression/argument_checking_18.f90 --- /dev/null +++ b/Fortran/gfortran/regression/argument_checking_18.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! +! PR 47349: missing warning: Actual argument contains too few elements +! +! Contributed by Janus Weil + + implicit none + type t + integer :: j(3) + end type t + + type(t) :: tt + integer :: i(3) = (/ 1,2,3 /) + + tt%j = i + + call sub1 (i) ! { dg-error "Actual argument contains too few elements" } + call sub1 (tt%j) ! { dg-error "Actual argument contains too few elements" } + call sub2 (i) ! { dg-error "Rank mismatch in argument" } + call sub2 (tt%j) ! { dg-error "Rank mismatch in argument" } + +contains + + subroutine sub1(i) + integer, dimension(1:3,1:3) :: i + print *,"sub1:",i + end subroutine + + subroutine sub2(i) + integer, dimension(:,:) :: i + print *,"sub2:",i + end subroutine + +end diff --git a/Fortran/gfortran/regression/argument_checking_19.f90 b/Fortran/gfortran/regression/argument_checking_19.f90 --- /dev/null +++ b/Fortran/gfortran/regression/argument_checking_19.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! PR 91443 - this was not caught. +module x +contains + subroutine a + call foo(1) ! { dg-error "Type mismatch in argument" } + end subroutine a +end module x + +subroutine foo(a) + real :: a + print *,a +end subroutine foo + +program main + use x + call a +end program main diff --git a/Fortran/gfortran/regression/argument_checking_2.f90 b/Fortran/gfortran/regression/argument_checking_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/argument_checking_2.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! PR fortran/30940 +program main + implicit none + character(len=10) :: digit_string = '123456789', str + character :: digit_arr(10) + call copy(digit_string, digit_arr) ! { dg-error "Scalar CHARACTER actual argument with array dummy argument 'in'" } + call copy(digit_arr,str) ! { dg-error "Scalar CHARACTER actual argument with array dummy argument 'out'" } + if(str /= '123456789') STOP 1 + digit_string = 'qwertasdf' + call copy2(digit_string, digit_arr) ! { dg-error "Scalar CHARACTER actual argument with array dummy argument 'in'" } + call copy2(digit_arr,str) ! { dg-error "Scalar CHARACTER actual argument with array dummy argument 'out'" } + if(str /= 'qwertasdf') STOP 2 + digit_string = '1qayxsw23e' + call copy('1qayxsw23e', digit_arr) ! { dg-error "Scalar CHARACTER actual argument with array dummy argument 'in'" } + call copy(digit_arr,str) ! { dg-error "Scalar CHARACTER actual argument with array dummy argument 'out'" } + if(str /= '1qayxsw23e') STOP 3 +contains + subroutine copy(in, out) + character, dimension(*) :: in + character, dimension(10) :: out + out = in(:10) + end subroutine copy + subroutine copy2(in, out) + character, dimension(2,*) :: in + character, dimension(2,5) :: out + out(1:2,1:5) = in(1:2,1:5) + end subroutine copy2 +end program main diff --git a/Fortran/gfortran/regression/argument_checking_20.f90 b/Fortran/gfortran/regression/argument_checking_20.f90 --- /dev/null +++ b/Fortran/gfortran/regression/argument_checking_20.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +program main + real :: a(10), b(10,10) +! This should be caugt + call foo(1.0) ! { dg-error "Rank mismatch" } + call foo(b) ! { dg-error "Rank mismatch" } +! This is OK + call bar(a) + call bar(b) + +end program main diff --git a/Fortran/gfortran/regression/argument_checking_21.f90 b/Fortran/gfortran/regression/argument_checking_21.f90 --- /dev/null +++ b/Fortran/gfortran/regression/argument_checking_21.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-fallow-argument-mismatch" } +program main + real :: a(10), b(10,10) +! This should be caugt + call foo(1.0) ! { dg-warning "Rank mismatch" } + call foo(b) ! { dg-warning "Rank mismatch" } +! This is OK + call bar(a) + call bar(b) + +end program main diff --git a/Fortran/gfortran/regression/argument_checking_22.f90 b/Fortran/gfortran/regression/argument_checking_22.f90 --- /dev/null +++ b/Fortran/gfortran/regression/argument_checking_22.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! PR 91556 - check that multiple errors are emitted for type mismatch +! (and that the check is also done in contained procedures). + +program main + real :: a + call foo(a) ! { dg-error "Type mismatch" } +contains + subroutine bar + integer :: b + complex :: c + call foo(b) ! { dg-error "Type mismatch" } + call foo(c) ! { dg-error "Type mismatch" } + end subroutine bar +end program main diff --git a/Fortran/gfortran/regression/argument_checking_23.f90 b/Fortran/gfortran/regression/argument_checking_23.f90 --- /dev/null +++ b/Fortran/gfortran/regression/argument_checking_23.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-fallow-argument-mismatch" } +! PR 91556 - check that only a single warning iw emitted for type +! mismatch (and that the check is also done in contained procedures). + +program main + real :: a + call foo(a) ! { dg-warning "Type mismatch" } +contains + subroutine bar + integer :: b + complex :: c + call foo(b) ! { dg-warning "Type mismatch" } + call foo(c) + end subroutine bar +end program main diff --git a/Fortran/gfortran/regression/argument_checking_24.f90 b/Fortran/gfortran/regression/argument_checking_24.f90 --- /dev/null +++ b/Fortran/gfortran/regression/argument_checking_24.f90 @@ -0,0 +1,63 @@ +! { dg-do compile } +! PR 92004 - checks in the absence of an explicit interface between +! array elements and arrays +module x + implicit none + type t + real :: x + end type t + type tt + real :: x(2) + end type tt + type pointer_t + real, pointer :: x(:) + end type pointer_t + type alloc_t + real, dimension(:), allocatable :: x + end type alloc_t +contains + subroutine foo(a) + real, dimension(:) :: a + real, dimension(2), parameter :: b = [1.0, 2.0] + real, dimension(10) :: x + type (t), dimension(1) :: vv + type (pointer_t) :: pointer_v + real, dimension(:), pointer :: p + call invalid_1(a(1)) ! { dg-error "Rank mismatch" } + call invalid_1(a) ! { dg-error "Rank mismatch" } + call invalid_2(a) ! { dg-error "Element of assumed-shape or pointer" } + call invalid_2(a(1)) ! { dg-error "Element of assumed-shape or pointer" } + call invalid_3(b) ! { dg-error "Rank mismatch" } + call invalid_3(1.0) ! { dg-error "Rank mismatch" } + call invalid_4 (vv(1)%x) ! { dg-error "Rank mismatch" } + call invalid_4 (b) ! { dg-error "Rank mismatch" }w + call invalid_5 (b) ! { dg-error "Rank mismatch" } + call invalid_5 (vv(1)%x) ! { dg-error "Rank mismatch" } + call invalid_6 (x) ! { dg-error "cannot correspond to actual argument" } + call invalid_6 (pointer_v%x(1)) ! { dg-error "cannot correspond to actual argument" } + call invalid_7 (pointer_v%x(1)) ! { dg-error "Rank mismatch" } + call invalid_7 (x) ! { dg-error "Rank mismatch" } + call invalid_8 (p(1)) ! { dg-error "Rank mismatch" } + call invalid_8 (x) ! { dg-error "Rank mismatch" } + call invalid_9 (x) ! { dg-error "cannot correspond to actual argument" } + call invalid_9 (p(1)) ! { dg-error "cannot correspond to actual argument" } + end subroutine foo + + subroutine bar(a, alloc) + real, dimension(*) :: a + real, dimension(2), parameter :: b = [1.0, 2.0] + type (alloc_t), pointer :: alloc + type (tt) :: tt_var + ! None of the ones below should issue an error. + call valid_1 (a) + call valid_1 (a(1)) + call valid_2 (a(1)) + call valid_2 (a) + call valid_3 (b) + call valid_3 (b(1)) + call valid_4 (tt_var%x) + call valid_4 (tt_var%x(1)) + call valid_5 (alloc%x(1)) + call valid_5 (a) + end subroutine bar +end module x diff --git a/Fortran/gfortran/regression/argument_checking_25.f90 b/Fortran/gfortran/regression/argument_checking_25.f90 --- /dev/null +++ b/Fortran/gfortran/regression/argument_checking_25.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! PR fortran/100274 - ICE in gfc_conv_procedure_call, at fortran/trans-expr.c:6131 + +program p + call s('y') ! { dg-warning "Character length of actual argument" } +contains + subroutine s(x) + character(8), intent(out) :: x + end +end + +! { dg-error "in variable definition context" " " { target *-*-* } 5 } diff --git a/Fortran/gfortran/regression/argument_checking_26.f90 b/Fortran/gfortran/regression/argument_checking_26.f90 --- /dev/null +++ b/Fortran/gfortran/regression/argument_checking_26.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! PR fortran/104212 - ICE in transformational_result +! Contributed by G.Steinmetz + +program p + logical, parameter :: a(*,*) = reshape([.true.,.false.], shape=[1,2]) + real, parameter :: r(*,*) = reshape([1.,2.], shape=[1,2]) + print *, parity(a) + print *, parity(a, dim=1) + print *, parity(a, dim=[1]) ! { dg-error "must be a scalar" } + print *, norm2 (r) + print *, norm2 (r, dim=1) + print *, norm2 (r, dim=[1]) ! { dg-error "must be a scalar" } +end diff --git a/Fortran/gfortran/regression/argument_checking_3.f90 b/Fortran/gfortran/regression/argument_checking_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/argument_checking_3.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! +! PR fortran/30940 +program test +implicit none +interface + subroutine foo(a) + character(len=1),dimension(:) :: a + end subroutine foo + subroutine bar(a) + character(len=1),dimension(:,:) :: a + end subroutine bar + subroutine foobar(a) + character(len=1),dimension(4) :: a + end subroutine foobar + subroutine arr(a) + character(len=1),dimension(1,2,1,2) :: a + end subroutine arr +end interface + character(len=2) :: len2 + character(len=4) :: len4 + len2 = '12' + len4 = '1234' + + call foo(len2) ! { dg-error "Rank mismatch in argument" } + call foo("ca") ! { dg-error "Rank mismatch in argument" } + call bar("ca") ! { dg-error "Rank mismatch in argument" } + call foobar(len2) ! { dg-error "contains too few elements" } + call foobar(len4) + call foobar("bar") ! { dg-error "contains too few elements" } + call foobar("bar33") + call arr(len2) ! { dg-error "contains too few elements" } + call arr(len4) + call arr("bar") ! { dg-error "contains too few elements" } + call arr("bar33") +end program test diff --git a/Fortran/gfortran/regression/argument_checking_4.f90 b/Fortran/gfortran/regression/argument_checking_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/argument_checking_4.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! +! PR fortran/30940 +program test +implicit none +interface + subroutine foobar(a) + character(len=1),dimension(4) :: a + end subroutine foobar + subroutine arr(a) + character(len=1),dimension(1,2,1,2) :: a + end subroutine arr +end interface + + call foobar( [ "bar" ]) ! { dg-error "contains too few elements" } + call foobar( ["ba ","r33"]) + call arr( [ "bar" ]) ! { dg-error "contains too few elements" } + call arr( reshape(["b","a","r","3"], [2,2])) + call arr( reshape(["b","a"], [1,2])) ! { dg-error "contains too few elements" } + call arr( reshape(["b","a"], [2,1])) ! { dg-error "contains too few elements" } +end program test diff --git a/Fortran/gfortran/regression/argument_checking_5.f90 b/Fortran/gfortran/regression/argument_checking_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/argument_checking_5.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! +! PR fortran/30940 +program test +implicit none +interface + subroutine foobar(x) + integer,dimension(4) :: x + end subroutine foobar + subroutine arr(y) + integer,dimension(1,2,1,2) :: y + end subroutine arr +end interface + +integer a(3), b(5) +call foobar(a) ! { dg-error "contains too few elements" } +call foobar(b) +call foobar(b(1:3)) ! { dg-error "contains too few elements" } +call foobar(b(1:5)) +call foobar(b(1:5:2)) ! { dg-error "contains too few elements" } +call foobar(b(2)) +call foobar(b(3)) ! { dg-error "Actual argument contains too few elements" } +call foobar(reshape(a(1:3),[2,1])) ! { dg-error "contains too few elements" } +call foobar(reshape(b(2:5),[2,2])) + +call arr(a) ! { dg-error "contains too few elements" } +call arr(b) +call arr(b(1:3)) ! { dg-error "contains too few elements" } +call arr(b(1:5)) +call arr(b(1:5:2)) ! { dg-error "contains too few elements" } +call arr(b(2)) +call arr(b(3)) ! { dg-error "contains too few elements" } +call arr(reshape(a(1:3),[2,1])) ! { dg-error "contains too few elements" } +call arr(reshape(b(2:5),[2,2])) +end program test diff --git a/Fortran/gfortran/regression/argument_checking_6.f90 b/Fortran/gfortran/regression/argument_checking_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/argument_checking_6.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! PR fortran/32669 +! +! Contributed by Janus Weil +! +program tfe +implicit none + +real,dimension(-1:1) :: w +real,dimension(1:4) :: x +real,dimension(0:3) :: y +real,dimension(-1:2) :: z + +call sub(x(:)) +call sub(y(:)) +call sub(z(:)) +call sub(w(:)) ! { dg-error "too few elements" } + +contains + subroutine sub(a) + implicit none + real,dimension(1:4) :: a + end subroutine sub +end program tfe diff --git a/Fortran/gfortran/regression/argument_checking_7.f90 b/Fortran/gfortran/regression/argument_checking_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/argument_checking_7.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! PR31306 ICE with implicit character variables +! Test case from PR and prepared by Jerry DeLisle +module cyclic + implicit none + contains + function ouch(x,y) ! { dg-error "has no IMPLICIT type" } + implicit character(len(ouch)) (x) ! { dg-error "used before it is typed" } + implicit character(len(x)+1) (y) ! { dg-error "used before it is typed" } + implicit character(len(y)-1) (o) ! { dg-error "used before it is typed" } + intent(in) x,y + character(len(y)-1) ouch ! { dg-error "used before it is typed" } + integer i + do i = 1, len(ouch) + ouch(i:i) = achar(ieor(iachar(x(i:i)),iachar(y(i:i)))) + end do + end function ouch +end module cyclic diff --git a/Fortran/gfortran/regression/argument_checking_8.f90 b/Fortran/gfortran/regression/argument_checking_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/argument_checking_8.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! PR31306 ICE with implicit character variables +! Test case from PR and prepared by Jerry DeLisle +module cyclic + implicit none + contains + character(10) function ouch(x,y) + implicit character(len(ouch)) (x) + implicit character(len(x)+1) (y) + intent(in) x,y + integer i + do i = 1, len(ouch) + ouch(i:i) = achar(ieor(iachar(x(i:i)),iachar(y(i:i)))) + end do + end function ouch +end module cyclic + +program test + use cyclic + implicit none + character(10) astr + integer i + write(astr,'(a)') ouch('YOW! ','jerry ') + if (astr(1:5) /= "3*%SY") STOP 1 + do i=6,10 + if (astr(i:i) /= achar(0)) STOP 2 + end do +end program test diff --git a/Fortran/gfortran/regression/argument_checking_9.f90 b/Fortran/gfortran/regression/argument_checking_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/argument_checking_9.f90 @@ -0,0 +1,52 @@ +! { dg-do compile } +! { dg-options "-fmax-errors=40" } +! PR33162 INTRINSIC functions as ACTUAL argument +! Prepared by Jerry DeLisle +program double_specs + +real(kind=4) :: rr, x, y +real(kind=8) :: dr, dx, dy + +x = .5 +y = .7 +dx = .5d0 +dy = .5d0 + +r = dabs(x) ! { dg-error "must be double precision" } +r = dacos(x) ! { dg-error "must be double precision" } +r = dacosh(x) ! { dg-error "must be double precision" } +r = dasin(x) ! { dg-error "must be double precision" } +r = dasinh(x) ! { dg-error "must be double precision" } +r = datan(x) ! { dg-error "must be double precision" } +r = datanh(x) ! { dg-error "must be double precision" } +r = datan2(y, dx) ! { dg-error "must be double precision" } +r = datan2(dy, x) ! { dg-error "must be double precision" } +r = dbesj0(x) ! { dg-error "must be double precision" } +r = dbesj1(x) ! { dg-error "must be double precision" } +r = dbesy0(x) ! { dg-error "must be double precision" } +r = dbesy1(x) ! { dg-error "must be double precision" } +r = dcos(x) ! { dg-error "must be double precision" } +r = dcosh(x) ! { dg-error "must be double precision" } +r = ddim(x, dy) ! { dg-error "must be double precision" } +r = ddim(dx, y) ! { dg-error "must be double precision" } +r = derf(x) ! { dg-error "must be double precision" } +r = derfc(x) ! { dg-error "must be double precision" } +r = dexp(x) ! { dg-error "must be double precision" } +r = dgamma(x) ! { dg-error "must be double precision" } +r = dlgama(x) ! { dg-error "must be double precision" } +r = dlog(x) ! { dg-error "must be double precision" } +r = dlog10(x) ! { dg-error "must be double precision" } +r = dmod(x, dy) ! { dg-error "must be double precision" } +r = dmod(dx, y) ! { dg-error "must be double precision" } +r = dsign(x, dy) ! { dg-error "must be double precision" } +r = dsign(dx, y) ! { dg-error "must be double precision" } +r = dsin(x) ! { dg-error "must be double precision" } +r = dsinh(x) ! { dg-error "must be double precision" } +r = dsqrt(x) ! { dg-error "must be double precision" } +r = dtan(x) ! { dg-error "must be double precision" } +r = dtanh(x) ! { dg-error "must be double precision" } +dr = dprod(dx,y) ! { dg-error "must be default real" } +dr = dprod(x,dy) ! { dg-error "must be default real" } +dr = dprod(x,y) + +end program double_specs \ No newline at end of file diff --git a/Fortran/gfortran/regression/arith_divide.f b/Fortran/gfortran/regression/arith_divide.f --- /dev/null +++ b/Fortran/gfortran/regression/arith_divide.f @@ -0,0 +1,15 @@ +! { dg-do compile } +! This test executes all code paths in gfc_arith_divide +! when executed along with it's companion test +! arith_divide_no_check.f + implicit none + integer i,j + real a,b + complex c,d + i = 10/40 + j = 10/0! { dg-error "Division by zero at" } + a = 10.0/40.0 + b = 10.0/0.0! { dg-error "Division by zero at" } + c = (1.0,1.0)/(10.0,40.0) ! Not division by zero + d = (1.0,10.)/(0.0,0.0)! { dg-error "Division by zero at" } + end diff --git a/Fortran/gfortran/regression/arith_divide_2.f90 b/Fortran/gfortran/regression/arith_divide_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/arith_divide_2.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR 92961 - this used to ICE. Original test case by Gerhard Steinmetz. +program p + integer :: a((0)/0) ! { dg-error "Division by zero" } + integer :: b(0/(0)) ! { dg-error "Division by zero" } + integer :: c((0)/(0)) ! { dg-error "Division by zero" } + integer :: d(0/0) ! { dg-error "Division by zero" } + integer :: x = ubound(a,1) ! { dg-error "must be an array" } +end diff --git a/Fortran/gfortran/regression/arith_divide_3.f90 b/Fortran/gfortran/regression/arith_divide_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/arith_divide_3.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! PR 93500 - this used to cause an ICE + +program p + integer :: a(min(2,0)/0) ! { dg-error "Division by zero" } + integer, save :: c[min(2,0)/0,*] ! { dg-error "Division by zero|must have constant shape" } + integer :: b = lbound(a) ! { dg-error "must be an array" } + print *,lcobound(c) +end program p + +subroutine s + integer :: a(min(2,0)/0) ! { dg-error "Division by zero" } + integer, save :: c[min(2,0)/0,*] ! { dg-error "Division by zero" } + integer :: b = lbound(a) + print *,lcobound(c) +end subroutine s diff --git a/Fortran/gfortran/regression/arith_divide_no_check.f b/Fortran/gfortran/regression/arith_divide_no_check.f --- /dev/null +++ b/Fortran/gfortran/regression/arith_divide_no_check.f @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-fno-range-check" } +! This test executes all code paths in gfc_arith_divide +! when executed along with it's companion test +! arith_divide.f + + implicit none + integer i,j + real a,b + complex c,d + i = 10/40 + j = 10/0! { dg-error "Division by zero at" } + a = 10.0/40.0 + b = 10.0/0.0 + c = (1.0,1.0)/(10.0,40.0) + d = (1.0,10.)/(0.0,0.0) + end diff --git a/Fortran/gfortran/regression/arithmetic_if.f90 b/Fortran/gfortran/regression/arithmetic_if.f90 --- /dev/null +++ b/Fortran/gfortran/regression/arithmetic_if.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! { dg-options "-w" } +! Test program for PR 28439 +integer function myfunc(i) + integer i + integer, save :: value = 2 + value = value - 1 + 0 * i + myfunc = value +end function myfunc + +program pr28439 + + integer myfunc + + if (myfunc(0)) 10, 20, 30 ! Should go to 30 +10 STOP 1 +20 STOP 2 + +30 if (myfunc(0)) 40, 50, 60 ! Should go to 50 +40 STOP 3 +60 STOP 4 + +50 if (myfunc(0)) 70, 80, 90 ! Should go to 70 +80 STOP 5 +90 STOP 6 + +70 continue + +end program pr28439 + + diff --git a/Fortran/gfortran/regression/arithmetic_overflow_1.f90 b/Fortran/gfortran/regression/arithmetic_overflow_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/arithmetic_overflow_1.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! Fixes PR37787 where the arithmetic overflow was not detected and an ICE ensued. +! +! Contributed by Tobias Burnus +! +! In F2008 and F2018, overflow cannot happen, but a BOZ cannot appear +! in an array constructor. +! +program bug + implicit none + integer(1) :: a(2) = (/ Z'FF', Z'FF' /) ! { dg-error "cannot appear in" } +end program bug diff --git a/Fortran/gfortran/regression/array_1.f90 b/Fortran/gfortran/regression/array_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_1.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +! PR 15553 : the array used to be filled with garbage +! this problem disappeared between 2004-05-20 and 2004-09-15 +program arrpack + implicit none + + double precision x(10,10) + integer i, j + + x = -1 + do i=1,6 + do j=1,5 + x(i,j) = i+j*10 + end do + end do + call pack (x, 6, 5) + + if (any(reshape(x(1:10,1:3), (/ 30 /)) & + /= (/ 11, 12, 13, 14, 15, 16, & + 21, 22, 23, 24, 25, 26, & + 31, 32, 33, 34, 35, 36, & + 41, 42, 43, 44, 45, 46, & + 51, 52, 53, 54, 55, 56 /))) STOP 1 + +contains + + subroutine pack (arr, ni, nj) + integer, intent(in) :: ni, nj + double precision, intent(inout) :: arr(:,:) + double precision :: tmp(ni,nj) + tmp(:,:) = arr(1:ni, 1:nj) + call copy (arr, tmp, ni, nj) + end subroutine pack + + subroutine copy (dst, src, ni, nj) + integer, intent(in) :: ni, nj + double precision, intent(out) :: dst(ni, nj) + double precision, intent(in) :: src(ni, nj) + dst = src + end subroutine copy + +end program arrpack diff --git a/Fortran/gfortran/regression/array_2.f90 b/Fortran/gfortran/regression/array_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_2.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! PR tree-optimization/30092 +! This caused once an ICE due to internal tree changes +program test + implicit none + integer, parameter :: N = 30 + real, dimension(N) :: rho, pre, cs + real :: gamma + gamma = 2.1314 + rho = 5.0 + pre = 3.0 + call EOS(N, rho, pre, cs, gamma) + if (abs(CS(1) - sqrt(gamma*pre(1)/rho(1))) > epsilon(cs)) & + STOP 1 +contains + SUBROUTINE EOS(NODES, DENS, PRES, CS, CGAMMA) + IMPLICIT NONE + INTEGER NODES + REAL CGAMMA + REAL, DIMENSION(NODES) :: DENS, PRES, CS + REAL, PARAMETER :: RGAS = 8.314 + CS(:NODES) = SQRT(CGAMMA*PRES(:NODES)/DENS(:NODES)) + END SUBROUTINE EOS +end program test diff --git a/Fortran/gfortran/regression/array_3.f90 b/Fortran/gfortran/regression/array_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_3.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR31610 ICE with transfer, merge in gfc_conv_expr_descriptor + integer :: i(1) = 1 + integer :: foo(3) + integer :: n(1) + foo(1) = 17 + foo(2) = 55 + foo(3) = 314 + print *, i, foo + write(*,*) foo([1]), foo([1]+i), [1]+1 + n = foo([1]+i) + print *, n, shape(foo([1]+i)), shape(foo(i+[1])) +end diff --git a/Fortran/gfortran/regression/array_4.f90 b/Fortran/gfortran/regression/array_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_4.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! PR fortran/36824 +! +! Dimension of tgclist was not recognized as having constant bounds +! +program test +implicit none +integer, dimension( 3 ), parameter :: tgc = (/5, 6, 7 /) +type tgccomp + integer, dimension( tgc( 1 ) : tgc( 2 ) ) :: tgclist +end type tgccomp +end program diff --git a/Fortran/gfortran/regression/array_5.f90 b/Fortran/gfortran/regression/array_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_5.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! +! PR fortran/54166 +! There was an ICE while chosing the bounds to scalarize the FAIL line. +! +! Contributed by Koen Poppe +! + +module ds_routines +contains + subroutine dsget(vertic,rstore) + real, dimension(:), intent(in out) :: rstore + real, dimension(:,:), intent(out) :: vertic + integer :: nrvert,point + nrvert = 4 + point = 26 + vertic(1,1:nrvert) = rstore(point+1:point+nrvert) ! FAIL + end subroutine dsget +end module ds_routines + +program ds_routines_program + use ds_routines + print *, "ok" +end program ds_routines_program diff --git a/Fortran/gfortran/regression/array_alloc_1.f90 b/Fortran/gfortran/regression/array_alloc_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_alloc_1.f90 @@ -0,0 +1,21 @@ +! PR 21104. Make sure that either f() or its caller will allocate +! the array data. We've decided to make the caller allocate it. +! { dg-do run } +program main + implicit none + call test (f ()) +contains + subroutine test (x) + integer, dimension (10) :: x + integer :: i + do i = 1, 10 + if (x (i) .ne. i * 100) STOP 1 + end do + end subroutine test + + function f () + integer, dimension (10) :: f + integer :: i + forall (i = 1:10) f (i) = i * 100 + end function f +end program main diff --git a/Fortran/gfortran/regression/array_alloc_2.f90 b/Fortran/gfortran/regression/array_alloc_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_alloc_2.f90 @@ -0,0 +1,38 @@ +! Like array_alloc_1.f90, but check cases in which the array length is +! not a literal constant. +! { dg-do run } +program main + implicit none + integer, parameter :: n = 100 + call test (n, f1 ()) + call test (47, f2 (50)) + call test (n, f3 (f1 ())) +contains + subroutine test (expected, x) + integer, dimension (:) :: x + integer :: i, expected + if (size (x, 1) .ne. expected) STOP 1 + do i = 1, expected + if (x (i) .ne. i * 100) STOP 2 + end do + end subroutine test + + function f1 () + integer, dimension (n) :: f1 + integer :: i + forall (i = 1:n) f1 (i) = i * 100 + end function f1 + + function f2 (howmuch) + integer :: i, howmuch + integer, dimension (4:howmuch) :: f2 + forall (i = 4:howmuch) f2 (i) = i * 100 - 300 + end function f2 + + function f3 (x) + integer, dimension (:) :: x + integer, dimension (size (x, 1)) :: f3 + integer :: i + forall (i = 1:size(x)) f3 (i) = i * 100 + end function f3 +end program main diff --git a/Fortran/gfortran/regression/array_alloc_3.f90 b/Fortran/gfortran/regression/array_alloc_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_alloc_3.f90 @@ -0,0 +1,35 @@ +! Like array_alloc_1.f90, but check multi-dimensional arrays. +! { dg-do run } +program main + implicit none + call test ((/ 3, 4, 5 /), f ((/ 3, 4, 5 /))) +contains + subroutine test (expected, x) + integer, dimension (:,:,:) :: x + integer, dimension (3) :: expected + integer :: i, i1, i2, i3 + do i = 1, 3 + if (size (x, i) .ne. expected (i)) STOP 1 + end do + do i1 = 1, expected (1) + do i2 = 1, expected (2) + do i3 = 1, expected (3) + if (x (i1, i2, i3) .ne. i1 + i2 * 10 + i3 * 100) STOP 2 + end do + end do + end do + end subroutine test + + function f (x) + integer, dimension (3) :: x + integer, dimension (x(1), x(2), x(3)) :: f + integer :: i1, i2, i3 + do i1 = 1, x(1) + do i2 = 1, x(2) + do i3 = 1, x(3) + f (i1, i2, i3) = i1 + i2 * 10 + i3 * 100 + end do + end do + end do + end function f +end program main diff --git a/Fortran/gfortran/regression/array_assignment_1.F90 b/Fortran/gfortran/regression/array_assignment_1.F90 --- /dev/null +++ b/Fortran/gfortran/regression/array_assignment_1.F90 @@ -0,0 +1,39 @@ +! { dg-do run } +! { dg-options "-ffree-line-length-none" } +! Test that different array assignments work even when interleaving, +! reversing etc. Make sure the results from assignment with constants +! as array triples and runtime array triples (where we always create +! a temporary) match. +#define TST(b,c,d,e,f,g,r) a=init; a(b:c:d) = a(e:f:g); \ + write(unit=line ,fmt="(9I1)") a;\ + if (line /= r) STOP 1; \ + call mytst(b,c,d,e,f,g,r); + +program main + implicit none + integer :: i + integer, parameter :: n=9 + integer, dimension(n) :: a + character(len=n) :: line + integer, dimension(n), parameter :: init = (/(i,i=1,n)/) + TST(2,n,2,1,n-1,2,'113355779') + TST(3,9,3,2,6,2,'122454786'); + TST(1,8,2,3,9,2,'325476989'); + TST(1,6,1,4,9,1,'456789789'); + TST(9,5,-1,1,5,1,'123454321'); + TST(9,5,-2,1,5,2,'123456381'); + TST(5,9,2,5,1,-2,'123456381'); + TST(1,6,1,2,7,1,'234567789'); + TST(2,7,1,1,6,1,'112345689'); +end program main + +subroutine mytst(b,c,d,e,f,g,r) + integer,intent(in) :: b,c,d,e,f,g + character(len=9), intent(in) :: r + character(len=9) :: line + integer, dimension(9) :: a + a = (/(i,i=1,9)/) + a(b:c:d) = a(e:f:g) + write (unit=line,fmt='(9I1)') a + if (line /= r) STOP 2 +end subroutine mytst diff --git a/Fortran/gfortran/regression/array_assignment_5.f90 b/Fortran/gfortran/regression/array_assignment_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_assignment_5.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize" } +! PR 62214 - this used to give the wrong result. +! Original test case by Oliver Fuhrer +PROGRAM test + IMPLICIT NONE + CHARACTER(LEN=20) :: fullNames(2) + CHARACTER(LEN=255) :: pathName + CHARACTER(LEN=5) :: fileNames(2) + + pathName = "/dir1/dir2/" + fileNames = (/ "file1", "file2" /) + fullNames = SPREAD(TRIM(pathName),1,2) // fileNames + if (fullNames(1) /= '/dir1/dir2/file1' .or. & + & fullnames(2) /= '/dir1/dir2/file2') STOP 1 +END PROGRAM test diff --git a/Fortran/gfortran/regression/array_constructor_1.f90 b/Fortran/gfortran/regression/array_constructor_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_1.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! Check that [...] style array constructors work +program bracket_array_constructor + implicit none + integer :: a(4), i + + a = [ 1, 2, 3, 4 ] + do i = 1, size(a) + if (a(i) /= i) STOP 1 + end do + + a = [ (/ 1, 2, 3, 4 /) ] + do i = 1, size(a) + if (a(i) /= i) STOP 2 + end do + +end program bracket_array_constructor diff --git a/Fortran/gfortran/regression/array_constructor_10.f90 b/Fortran/gfortran/regression/array_constructor_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_10.f90 @@ -0,0 +1,27 @@ +! Like array_constructor_6.f90, but check constructors that apply +! an elemental function to an array. +! { dg-do run } +program main + implicit none + call build (200) +contains + subroutine build (order) + integer :: order, i + + call test (order, (/ (abs ((/ i, -i, -i * 2 /)), i = 1, order) /)) + call test (order, abs ((/ ((/ -i, -i, i * 2 /), i = 1, order) /))) + call test (order, (/ abs ((/ ((/ i, i, -i * 2 /), i = 1, order) /)) /)) + end subroutine build + + subroutine test (order, values) + integer, dimension (3:) :: values + integer :: order, i + + if (size (values, dim = 1) .ne. order * 3) STOP 1 + do i = 1, order + if (values (i * 3) .ne. i) STOP 2 + if (values (i * 3 + 1) .ne. i) STOP 3 + if (values (i * 3 + 2) .ne. i * 2) STOP 4 + end do + end subroutine test +end program main diff --git a/Fortran/gfortran/regression/array_constructor_11.f90 b/Fortran/gfortran/regression/array_constructor_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_11.f90 @@ -0,0 +1,48 @@ +! Like array_constructor_6.f90, but check iterators with non-default stride, +! including combinations which lead to zero-length vectors. +! { dg-do run } +! { dg-options "-Wzerotrip" } +program main + implicit none + call build (77) +contains + subroutine build (order) + integer :: order, i, j + + call test (1, 11, 3, (/ (i, i = 1, 11, 3) /)) + call test (3, 20, 2, (/ (i, i = 3, 20, 2) /)) + call test (4, 0, 11, (/ (i, i = 4, 0, 11) /)) ! { dg-warning "will be executed zero times" } + + call test (110, 10, -3, (/ (i, i = 110, 10, -3) /)) + call test (200, 20, -12, (/ (i, i = 200, 20, -12) /)) + call test (29, 30, -6, (/ (i, i = 29, 30, -6) /)) ! { dg-warning "will be executed zero times" } + + call test (1, order, 3, (/ (i, i = 1, order, 3) /)) + call test (order, 1, -3, (/ (i, i = order, 1, -3) /)) + + ! Triggers compile-time iterator calculations in trans-array.c + call test (1, 1000, 2, (/ (i, i = 1, 1000, 2), (i, i = order, 0, 1) /)) + call test (1, 0, 3, (/ (i, i = 1, 0, 3), (i, i = order, 0, 1) /)) ! { dg-warning "will be executed zero times" } + call test (1, 2000, -5, (/ (i, i = 1, 2000, -5), (i, i = order, 0, 1) /)) ! { dg-warning "will be executed zero times" } + call test (3000, 99, 4, (/ (i, i = 3000, 99, 4), (i, i = order, 0, 1) /)) ! { dg-warning "will be executed zero times" } + call test (400, 77, -39, (/ (i, i = 400, 77, -39), (i, i = order, 0, 1) /)) + + do j = -10, 10 + call test (order + j, order, 5, (/ (i, i = order + j, order, 5) /)) + call test (order + j, order, -5, (/ (i, i = order + j, order, -5) /)) + end do + + end subroutine build + + subroutine test (from, to, step, values) + integer, dimension (:) :: values + integer :: from, to, step, last, i + + last = 0 + do i = from, to, step + last = last + 1 + if (values (last) .ne. i) STOP 1 + end do + if (size (values, dim = 1) .ne. last) STOP 2 + end subroutine test +end program main diff --git a/Fortran/gfortran/regression/array_constructor_12.f90 b/Fortran/gfortran/regression/array_constructor_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_12.f90 @@ -0,0 +1,51 @@ +! Like array_constructor_6.f90, but check integer(8) iterators. +! { dg-do run } +program main + integer (kind = 8) :: i, l8, u8, step8 + integer (kind = 4) :: l4, step4 + integer (kind = 8), parameter :: big = 10000000000_8 + + l4 = huge (l4) + u8 = l4 + 10_8 + step4 = 2 + call test ((/ (i, i = l4, u8, step4) /), l4 + 0_8, u8, step4 + 0_8) + + l8 = big + u8 = big * 20 + step8 = big + call test ((/ (i, i = l8, u8, step8) /), l8, u8, step8) + + u8 = big + 100 + l8 = big + step4 = -20 + call test ((/ (i, i = u8, l8, step4) /), u8, l8, step4 + 0_8) + + u8 = big * 40 + l8 = big * 20 + step8 = -big * 2 + call test ((/ (i, i = u8, l8, step8) /), u8, l8, step8) + + u8 = big + l4 = big / 100 + step4 = -big / 500 + call test ((/ (i, i = u8, l4, step4) /), u8, l4 + 0_8, step4 + 0_8) + + u8 = big * 40 + 200 + l4 = 200 + step8 = -big + call test ((/ (i, i = u8, l4, step8) /), u8, l4 + 0_8, step8) +contains + subroutine test (a, l, u, step) + integer (kind = 8), dimension (:), intent (in) :: a + integer (kind = 8), intent (in) :: l, u, step + integer (kind = 8) :: i + integer :: j + + j = 1 + do i = l, u, step + if (a (j) .ne. i) STOP 1 + j = j + 1 + end do + if (size (a, 1) .ne. j - 1) STOP 2 + end subroutine test +end program main diff --git a/Fortran/gfortran/regression/array_constructor_13.f90 b/Fortran/gfortran/regression/array_constructor_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_13.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +! Tests patch for PR29431, which arose from PR29373. +! +! Contributed by Tobias Schlueter +! + implicit none + CHARACTER(len=6), DIMENSION(2,2) :: a + +! Reporters original triggered another error: +! gfc_todo: Not Implemented: complex character array +! constructors. + + a = reshape([to_string(1.0), trim("abcdef"), & + to_string(7.0), trim("hijklm")], & + [2, 2]) + print *, a + + CONTAINS + FUNCTION to_string(x) + character*6 to_string + REAL, INTENT(in) :: x + WRITE(to_string, FMT="(F6.3)") x + END FUNCTION +end diff --git a/Fortran/gfortran/regression/array_constructor_14.f90 b/Fortran/gfortran/regression/array_constructor_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_14.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } + +subroutine foo(x) + integer :: x(4) + x(:) = (/ 3, 1, 4, 1 /) +end subroutine + +subroutine bar(x) + integer :: x(4) + x = (/ 3, 1, 4, 1 /) +end subroutine + +! { dg-final { scan-tree-dump-times "data" 0 "original" } } diff --git a/Fortran/gfortran/regression/array_constructor_15.f90 b/Fortran/gfortran/regression/array_constructor_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_15.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } + integer :: x(2,2) + if (any(x(:,:) .ne. reshape ((/ 3, 1, 4, 1 /), (/ 2, 2 /)))) STOP 1 +end +! { dg-final { scan-tree-dump-times "atmp" 0 "original" } } diff --git a/Fortran/gfortran/regression/array_constructor_16.f90 b/Fortran/gfortran/regression/array_constructor_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_16.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! Tests the fix for PR31204, in which 'i' below would be incorrectly +! host associated by the contained subroutines. The checks for 'ii' +! and 'iii' have been added, since they can be host associated because +! of the explicit declarations in the main program. +! +! Contributed by Joost VandeVondele +! + integer ii + INTEGER, PARAMETER :: jmin(1:10) = (/ (i, i = 1, 10) /) + INTEGER, PARAMETER :: kmin(1:10) = (/ (ii, ii = 1, 10) /) + INTEGER, PARAMETER :: lmin(1:10) = (/ (iii, iii = 1, 10) /) + integer iii + CALL two + +CONTAINS + + SUBROUTINE one + i = 99 + ii = 99 + iii = 999 + END SUBROUTINE + + SUBROUTINE two + i = 0 + ii = 0 + iii = 0 + CALL one + IF (i .NE. 0) STOP 1 + IF (ii .NE. 99) STOP 2 + IF (iii .NE. 999) STOP 3 + END SUBROUTINE +END + diff --git a/Fortran/gfortran/regression/array_constructor_17.f90 b/Fortran/gfortran/regression/array_constructor_17.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_17.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! Tests the fix for PR31219, in which the character length of +! the functions in the array constructor was not being obtained +! correctly and this caused an ICE. +! +! Contributed by Joost VandeVondele +! + INTEGER :: J + CHARACTER(LEN = 8) :: str + J = 3 + write (str,'(2A4)') (/( F(I, J), I = 1, 2)/) + IF (str .NE. " ODD EVE") STOP 1 + +! Comment #1 from F-X Coudert (noted by T. Burnus) that +! actually exercises a different part of the bug. + call gee( (/g (3)/) ) + +CONTAINS + FUNCTION F (K,J) RESULT(I) + INTEGER :: K, J + CHARACTER(LEN = J) :: I + IF (MODULO (K, 2) .EQ. 0) THEN + I = "EVEN" + ELSE + I = "ODD" + ENDIF + END FUNCTION + + function g(k) result(i) + integer :: k + character(len = k) :: i + i = '1234' + end function + subroutine gee(a) + character(*),dimension(1) :: a + if(len (a) /= 3) STOP 2 + if(a(1) /= '123') STOP 3 + end subroutine gee + +END diff --git a/Fortran/gfortran/regression/array_constructor_18.f90 b/Fortran/gfortran/regression/array_constructor_18.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_18.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-Wzerotrip" } +! Tests the fix for PR32875, in which the character length for the +! array constructor would get lost in simplification and would lead +! the error 'Not Implemented: complex character array constructor'. +! +! Contributed by Joost VandeVondele +! + call foo ((/(S1(i),i=1,3,-1)/)) ! { dg-warning "will be executed zero times" } +CONTAINS + FUNCTION S1(i) + CHARACTER(LEN=1) :: S1 + INTEGER :: I + S1="123456789"(i:i) + END FUNCTION S1 + subroutine foo (chr) + character(1) :: chr(:) + print *, chr + end subroutine +END diff --git a/Fortran/gfortran/regression/array_constructor_19.f90 b/Fortran/gfortran/regression/array_constructor_19.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_19.f90 @@ -0,0 +1,17 @@ +! Simplification of unary and binary expressions containing +! array constructors. +! +! See PR33288 +! +! { dg-do run } + real, parameter :: x(1) = 42 + real, parameter :: x1(1) = (/ x /) + 1 + real, parameter :: x2(1) = 1 + (/ x /) + real, parameter :: x3(1) = -(/ x /) + real, parameter :: x4(2) = (/ x, 1. /) + (/ 2, (/3/) /) + + if (any (x1 /= (/43./))) STOP 1 + if (any (x2 /= (/43./))) STOP 2 + if (any (x3 /= (/-42./))) STOP 3 + if (any (x4 /= (/44., 4./))) STOP 4 +end diff --git a/Fortran/gfortran/regression/array_constructor_2.f90 b/Fortran/gfortran/regression/array_constructor_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_2.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! Check that array constructor delimiters match +program bracket_array_constr_2 + implicit none + integer :: a(4) + a = (/ 1, 2, 3, 4 ] ! { dg-error "array constructor" } + a = (/ [ 1, 2, 3, 4 /) ] ! { dg-error "array constructor" } +end program bracket_array_constr_2 diff --git a/Fortran/gfortran/regression/array_constructor_20.f90 b/Fortran/gfortran/regression/array_constructor_20.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_20.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! +! PR fortran/34784, in which the intrinsic expression would be +! given the implicit type. +! +! Contributed by Dick Hendrickson +! +MODULE m + implicit character(s) + INTEGER :: I(1) = (/ (SELECTED_INT_KIND(J),J=1,1) /) +END MODULE m + +MODULE s_TESTS + IMPLICIT CHARACTER (P) +CONTAINS + subroutine simple (u,j1) + optional :: j1 + if (present (j1)) stop + end subroutine +END MODULE s_TESTS diff --git a/Fortran/gfortran/regression/array_constructor_21.f90 b/Fortran/gfortran/regression/array_constructor_21.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_21.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! +! PR fortran/34785, in which the character length of BA_T was not +! passed on to the array constructor argument of SEQ. +! +! Contributed by Dick Hendrickson +! + MODULE o_TYPE_DEFS + implicit none + TYPE SEQ + SEQUENCE + CHARACTER(len = 9) :: BA(2) + END TYPE SEQ + CHARACTER(len = 9) :: BA_T(2) + CHARACTER(LEN = 9) :: CA_T(1,2) + END MODULE o_TYPE_DEFS + + MODULE TESTS + use o_type_defs + implicit none + CONTAINS + SUBROUTINE OG0015(UDS0L) + TYPE(SEQ) UDS0L + integer :: j1 + UDS0L = SEQ((/ (BA_T(J1),J1=1,2) /)) + END SUBROUTINE + END MODULE TESTS + + use o_type_defs + CONTAINS + SUBROUTINE OG0015(UDS0L) + TYPE(SEQ) UDS0L + UDS0L = SEQ(RESHAPE ( (/ ((CA_T(J1,J2), J1 = 1, 1), J2 = 1, 2)/),(/2/))) + END SUBROUTINE + END diff --git a/Fortran/gfortran/regression/array_constructor_22.f90 b/Fortran/gfortran/regression/array_constructor_22.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_22.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-options "-Wzerotrip" } +! PR34990 ICE in gfc_typenode_for_spec, at fortran/trans-types.c:842 +! Test case that of the reporters. +module test + implicit none + contains + function my_string(x) + integer i + real, intent(in) :: x(:) + character(0) h4(1:minval([(1,i=1,0)],1)) ! { dg-warning "will be executed zero times" } + character(0) sv1(size(x,1):size(h4)) + character(0) sv2(2*lbound(sv1,1):size(h4)) + character(lbound(sv2,1)-3) my_string + + do i = 1, len(my_string) + my_string(i:i) = achar(modulo(i-1,10)+iachar('0')) + end do + end function my_string +end module test + +program len_test + use test + implicit none + real x(7) + + write(*,*) my_string(x) +end program len_test diff --git a/Fortran/gfortran/regression/array_constructor_23.f b/Fortran/gfortran/regression/array_constructor_23.f --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_23.f @@ -0,0 +1,48 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_real } +! Tests the fix for PR35944/6/7, in which the variable array constructors below +! were incorrectly translated and wrong code was produced. +! +! Contributed by Dick Hendrickson +! + program try_fa6013 + call fa6013 (10, 1, -1) + call fa6077 (10, 1, -1, (/1,2,3,4,5,6,7,8,9,10/)) + call fa2083 + end program + + subroutine FA6013 (nf10, nf1, mf1) + integer, parameter :: kv = 4 + REAL(KV) DDA1(10) + REAL(KV) DDA2(10) + REAL(KV) DDA(10), dval + dda = (/1,2,3,4,5,6,7,8,9,10/) + DDA1 = ATAN2 ((/(REAL(J1,KV),J1=1,10)/), + $ REAL((/(J1,J1=nf10,nf1,mf1)/), KV)) !fails + DDA2 = ATAN2 (DDA, DDA(10:1:-1)) + if (any (DDA1 - DDA2 .gt. epsilon(dval))) STOP 1 + END + + subroutine FA6077 (nf10,nf1,mf1, ida) + INTEGER IDA1(10) + INTEGER IDA2(10), ida(10) + IDA1 = IEOR((/1,2,3,4,5,6,7,8,9,10/), + $ (/(IDA(J1),J1=10,1,-1)/) ) + IDA2 = IEOR ((/1,2,3,4,5,6,7,8,9,10/), (/10,9,8,7,6,5,4,3,2,1/) ) + if (any (ida1 .ne. ida2)) STOP 2 + END SUBROUTINE + + subroutine fa2083 + implicit none + integer j1,k + parameter (k=selected_real_kind (precision (0.0_8) + 1)) ! failed + REAL(k) QDA1(10) + REAL(k) QDA(10), qval + qda = (/ 1,2,3,4,5,6,7,8,9,10 /) + QDA1 = MOD ( 1.1_k*( QDA(1) -5.0_k), P=( QDA -2.5_k)) + DO J1 = 1,10 + QVAL = MOD(1.1_k*(QDA(1)-5.0_k),P=(QDA(J1)-2.5_k)) + if (qval - qda1(j1) .gt. epsilon(qval)) STOP 3 + ENDDO + END + diff --git a/Fortran/gfortran/regression/array_constructor_24.f b/Fortran/gfortran/regression/array_constructor_24.f --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_24.f @@ -0,0 +1,47 @@ +! { dg-do run } +! Tests the fix for PR35944/6/7, in which the variable array constructors below +! were incorrectly translated and wrong code was produced. +! +! Contributed by Dick Hendrickson +! + program try_fa6013 + call fa6013 (10, 1, -1) + call fa6077 (10, 1, -1, (/1,2,3,4,5,6,7,8,9,10/)) + call fa2083 + end program + + subroutine FA6013 (nf10, nf1, mf1) + integer, parameter :: kv = 4 + REAL(KV) DDA1(10) + REAL(KV) DDA2(10) + REAL(KV) DDA(10), dval + dda = (/1,2,3,4,5,6,7,8,9,10/) + DDA1 = ATAN2 ((/(REAL(J1,KV),J1=1,10)/), + $ REAL((/(J1,J1=nf10,nf1,mf1)/), KV)) !fails + DDA2 = ATAN2 (DDA, DDA(10:1:-1)) + if (any (abs(DDA1-DDA2) .gt. 1.0e-6)) STOP 1 + END + + subroutine FA6077 (nf10,nf1,mf1, ida) + INTEGER IDA1(10) + INTEGER IDA2(10), ida(10) + IDA1 = IEOR((/1,2,3,4,5,6,7,8,9,10/), + $ (/(IDA(J1),J1=10,1,-1)/) ) + IDA2 = IEOR ((/1,2,3,4,5,6,7,8,9,10/), (/10,9,8,7,6,5,4,3,2,1/) ) + if (any (ida1 .ne. ida2)) STOP 2 + END SUBROUTINE + + subroutine fa2083 + implicit none + integer j1,k + parameter (k=8) !failed for k=10 + REAL(k) QDA1(10) + REAL(k) QDA(10), qval + qda = (/ 1,2,3,4,5,6,7,8,9,10 /) + QDA1 = MOD ( 1.1_k*( QDA(1) -5.0_k), P=( QDA -2.5_k)) + DO J1 = 1,10 + QVAL = MOD(1.1_k*(QDA(1)-5.0_k),P=(QDA(J1)-2.5_k)) + if (qval .ne. qda1(j1)) STOP 3 + ENDDO + END + diff --git a/Fortran/gfortran/regression/array_constructor_25.f03 b/Fortran/gfortran/regression/array_constructor_25.f03 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_25.f03 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } + +! PR fortran/36492 +! Check for incorrect error message with -std=f2003. +! Reduced test based on the one from comment #4, PR 36492. + +type t + character (2) :: arr (1) = [ "a" ] +end type t + +end diff --git a/Fortran/gfortran/regression/array_constructor_26.f03 b/Fortran/gfortran/regression/array_constructor_26.f03 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_26.f03 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-std=gnu" } + +! PR fortran/36492 +! Check for incorrect error message with -std=f2003. +! Test from comment #4, PR 36492 causing ICE. + +MODULE WinData + IMPLICIT NONE + INTEGER (1), PARAMETER :: MAXFLD = 25_1, MAXHED = 5_1, MAXCHR = 80_1 + integer :: i + TYPE TWindowData + CHARACTER (MAX_FLD_HED, 1) :: DWFdHd(MAXFLD) = [(" ", i = 1, MAXFLD)] ! { dg-error "Scalar INTEGER expression" } + END TYPE TWindowData +END MODULE WinData diff --git a/Fortran/gfortran/regression/array_constructor_27.f03 b/Fortran/gfortran/regression/array_constructor_27.f03 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_27.f03 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-std=gnu" } + +! PR fortran/36492 +! Check for incorrect error message with -std=f2003. +! Reduced test triggering the ICE mentioned in comment #4, PR 36492. + +implicit none + +type t + character (a) :: arr (1) = [ "a" ] ! { dg-error "Scalar INTEGER expression" } +end type t + +end diff --git a/Fortran/gfortran/regression/array_constructor_28.f03 b/Fortran/gfortran/regression/array_constructor_28.f03 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_28.f03 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } + +! PR fortran/36492 +! Check that the error is still emitted for really incorrect constructor. + +type t + character (2) :: arr (2) = [ "a", "ab" ] ! { dg-error "Different CHARACTER" } +end type t + +end diff --git a/Fortran/gfortran/regression/array_constructor_29.f03 b/Fortran/gfortran/regression/array_constructor_29.f03 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_29.f03 @@ -0,0 +1,13 @@ +! { dg-do compile } + +! PR fortran/36492 +! Similar to the ICE-test, but now test it works for real constants. + +implicit none + +integer, parameter :: a = 42 +type t + character (a) :: arr (1) = [ "a" ] +end type t + +end diff --git a/Fortran/gfortran/regression/array_constructor_3.f90 b/Fortran/gfortran/regression/array_constructor_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_3.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +! Check that empty array constructors are rejected +program hum + print *, (//) ! { dg-error "Empty array constructor" } +end program hum diff --git a/Fortran/gfortran/regression/array_constructor_30.f03 b/Fortran/gfortran/regression/array_constructor_30.f03 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_30.f03 @@ -0,0 +1,16 @@ +! { dg-do compile } + +! PR fortran/36492 +! Similar to the ICE-test, but now test for complaint about constant +! specification expression. + +implicit none + +integer :: a = 42 +type t + character (a) :: arr (1) = [ "a" ] + ! { dg-error "in the expression" "" { target *-*-* } .-1 } + ! { dg-error "specification expression" "" { target *-*-* } .-2 } +end type t + +end diff --git a/Fortran/gfortran/regression/array_constructor_31.f90 b/Fortran/gfortran/regression/array_constructor_31.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_31.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! Test the fix for pr40018 in which the elements in the array +! constructor would be of default type and this would cause an +! ICE in the backend because of the type mistmatch with 'i'. +! +! Contributed by Francois-Xavier Coudert +! + integer(kind=8) :: i + write(*,*) [(i, i = 1, 10)] + end diff --git a/Fortran/gfortran/regression/array_constructor_32.f90 b/Fortran/gfortran/regression/array_constructor_32.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_32.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! PR41807 data statement with nested type constructors +! Test case provided by Steve Kargl + implicit none + + type :: a + real :: x(3) + end type a + + integer, parameter :: n = 3 + + type(a) :: b(n) + + real, parameter :: d1(3) = (/1., 2., 3./) + real, parameter :: d2(3) = (/4., 5., 6./) + real, parameter :: d3(3) = (/7., 8., 9./) + + integer :: i, z(n) + + data (b(i), i = 1, n) /a(d1), a(d2), a(d3)/ + data (z(i), i = 1, n) / 1, 2, 3/ + + if (any(z.ne.[1, 2, 3])) STOP 1 + if (any(b(1)%x.ne.[1, 2, 3]) .or. & + any(b(2)%x.ne.[4, 5, 6]) .or. & + any(b(3)%x.ne.[7, 8, 9])) STOP 2 +end + diff --git a/Fortran/gfortran/regression/array_constructor_33.f90 b/Fortran/gfortran/regression/array_constructor_33.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_33.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-timeout-factor 4 } +! PR20923 gfortran slow for large array constructors. +! Test case prepared from PR by Jerry DeLisle +program sel + implicit none + integer(kind=4),parameter :: n=1000 + integer(kind=4) :: i,j + real(kind=4),dimension(n*n) :: vect + vect(:) = (/ ((( (i+j+3)),i=1,n),j=1,n) /) +end diff --git a/Fortran/gfortran/regression/array_constructor_34.f90 b/Fortran/gfortran/regression/array_constructor_34.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_34.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! PR32489 Endless loop when compiling. +! Derived from fft257.f90, Public domain 2004 James Van Buskirk. +! Note: The problem solved here was not an infinite loop issue. Middle-end +! could not handle the array constructor unfolded by the front end. +! WARNING: Potential resource hog. +! Jerry DeLisle +program test + implicit none + integer, parameter :: dp = selected_real_kind(15,300) + integer, parameter :: N = 257 + complex(dp) h1(0:N-1) + complex(dp) h2(0:N-1) + complex(dp) hh(0:N-1) + complex(dp), parameter :: ri(2) = (/(1,0),(0,1)/) + integer i, j, k, L + real(dp) pi + + pi = 4*atan(1.0_dp) + do i = 0, N-1 + do j = 1, 2 + h2 = 0 + h2(i) = ri(j) + h1 = (/(sum((/(exp(-2*pi*(0,1)*mod(k*L,N)/N)*h2(L),L=0,N-1)/)),k=0,N-1)/) + end do + end do +end program test diff --git a/Fortran/gfortran/regression/array_constructor_35.f90 b/Fortran/gfortran/regression/array_constructor_35.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_35.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR42999 bogus error: Parameter 'i' at (1) has not been declared +! or is a variable, which does not reduce to a constant expression + TYPE DD + INTEGER :: I + END TYPE DD + TYPE(DD) :: X(2)=(/(DD(I),I=1,2)/) + END + diff --git a/Fortran/gfortran/regression/array_constructor_36.f90 b/Fortran/gfortran/regression/array_constructor_36.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_36.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! Test the fix for PR47348, in which the substring length +! in the array constructor at line 19 would be missed and +! the length of q used instead. +! +! Contributed by Thomas Koenig +! +program main + implicit none + character(len = *), parameter :: fmt='(2(A,"|"))' + character(len = *), parameter :: test='xyc|aec|' + integer :: i + character(len = 4) :: q + character(len = 8) :: buffer + q = 'xy' + i = 2 + write (buffer, fmt) (/ trim(q), 'ae' /)//'c' + if (buffer .ne. test) STOP 1 + write (buffer, FMT) (/ q(1:i), 'ae' /)//'c' + if (buffer .ne. test) STOP 2 +end program main diff --git a/Fortran/gfortran/regression/array_constructor_37.f90 b/Fortran/gfortran/regression/array_constructor_37.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_37.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! Check the fix for PR47850, in which the argument of ANY, below, was not +! simplified, thereby causing an ICE. +! +! Contributed by Tobias Burnus but based on James van Buskirk's program in +! http://groups.google.com/group/comp.lang.fortran/browse_thread/thread/625faf82578e9af8 +! +! +program Cindex + implicit none + integer,parameter :: SENSOR_CHANNEL(8) = & + [10,12,17,20,22,30,33,34] + integer,parameter :: NLTE_CHANNEL(3) = [20,22,34] + integer,parameter :: N_NLTE_CHANNELS = size(NLTE_CHANNEL) + integer,parameter :: N_CHANNELS = size(SENSOR_CHANNEL) + integer i + integer,parameter :: C_INDEX(8) = unpack( & + vector = [(i,i=1,size(SENSOR_CHANNEL))], & + mask = [(any(SENSOR_CHANNEL(i) == NLTE_CHANNEL), & + i=lbound(SENSOR_CHANNEL,1),ubound(SENSOR_CHANNEL,1))], & + field = 0) + character(20) fmt + + write(fmt,'(a,i0,a)') '(a,t19,',size(SENSOR_CHANNEL),'(i3:","))' + write(*,fmt) 'SENSOR_CHANNEL = ',SENSOR_CHANNEL + write(fmt,'(a,i0,a)') '(a,t19,',size(NLTE_CHANNEL),'(i3:","))' + write(*,fmt) 'NLTE_CHANNEL = ',NLTE_CHANNEL + write(*,'(a,t19,i3)') 'N_NLTE_CHANNELS = ',N_NLTE_CHANNELS + write(*,'(a,t19,i3)') 'N_CHANNELS = ',N_CHANNELS + write(fmt,'(a,i0,a)') '(a,t19,',size(C_INDEX),'(i3:","))' + write(*,fmt) 'C_INDEX = ',C_INDEX +end program Cindex diff --git a/Fortran/gfortran/regression/array_constructor_38.f90 b/Fortran/gfortran/regression/array_constructor_38.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_38.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! PR fortran/44354 +! array constructors were giving unexpected results when the ac-implied-do +! variable was used in one of the ac-implied-do bounds. +! +! Original testcase by Vittorio Zecca +! + I=5 + print *,(/(i,i=I,8)/) ! { dg-error "initial expression references control variable" } + print *,(/(i,i=1,I)/) ! { dg-error "final expression references control variable" } + print *,(/(i,i=1,50,I)/) ! { dg-error "step expression references control variable" } + end + + diff --git a/Fortran/gfortran/regression/array_constructor_39.f90 b/Fortran/gfortran/regression/array_constructor_39.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_39.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! +! PR fortran/44354 +! array constructors were giving unexpected results when the ac-implied-do +! variable was used in one of the ac-implied-do bounds. +! +! Original testcase by Vittorio Zecca +! + I=5 + if (any((/(i,i=1,I)/) /= (/1,2,3,4,5/))) STOP 1! { dg-warning "final expression references control variable" } + if (I /= 5) STOP 2 + end + diff --git a/Fortran/gfortran/regression/array_constructor_4.f90 b/Fortran/gfortran/regression/array_constructor_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_4.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! PR 21912 +! We didn't adapt the exit condition to negative steps in array constructors, +! leaving the resulting arrays uninitialized. +integer :: i(5), n, m, l, k + +n = 5 +i = (/ (m, m = n, 1, -1) /) +if (any (i /= (/ 5, 4, 3, 2, 1 /))) STOP 1 + +k = 1 + +i(5:1:-1) = (/ (m, m = n, k, -1) /) +if (any (i /= (/ 1, 2, 3, 4, 5 /))) STOP 2 + +l = -1 + +i = (/ (m, m = n, 1, l) /) +if (any (i /= (/ 5, 4, 3, 2, 1 /))) STOP 3 + +i(5:1:-1) = (/ (m, m = n, k, l) /) +if (any (i /= (/ 1, 2, 3, 4, 5 /))) STOP 4 +end diff --git a/Fortran/gfortran/regression/array_constructor_40.f90 b/Fortran/gfortran/regression/array_constructor_40.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_40.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize -fdump-tree-original" } +! PR 55806 - replace ANY intrinsic for array +! constructor with .or. + +module mymod + implicit none +contains + subroutine bar(a,b,c, lo) + real, dimension(3,3), intent(in) :: a,b + logical, dimension(3,3), intent(in) :: lo + integer, intent(out) :: c + real, parameter :: acc = 1e-4 + integer :: i,j + + c = 0 + do i=1,3 + if (any([abs(a(i,1) - b(i,1)) > acc, & + (j==i+1,j=3,8)])) cycle + if (any([abs(a(i,2) - b(i,2)) > acc, & + abs(a(i,3) - b(i,3)) > acc, lo(i,:)])) cycle + c = c + i + end do + end subroutine bar + + subroutine baz(a, b, c) + real, dimension(3,3), intent(in) :: a,b + real, intent(out) :: c + c = sum([a(1,1),a(2,2),a(3,3),b(:,1)]) + end subroutine baz +end module mymod + +program main + use mymod + implicit none + real, dimension(3,3) :: a,b + real :: res + integer :: c + logical lo(3,3) + data a/1.1, 1.2, 1.3, 1.4, 1.5, 1.6, 1.7, 1.8, 1.9/ + + b = a + b(2,2) = a(2,2) + 0.2 + lo = .false. + lo(3,3) = .true. + call bar(a,b,c,lo) + if (c /= 1) STOP 1 + call baz(a,b,res); + if (abs(res - 8.1) > 1e-5) STOP 2 +end program main +! { dg-final { scan-tree-dump-times "while" 5 "original" } } diff --git a/Fortran/gfortran/regression/array_constructor_41.f90 b/Fortran/gfortran/regression/array_constructor_41.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_41.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! Test fix for PR55789 +! +! Contributed by Joost VandVandole +! +MODULE M1 +CONTAINS + SUBROUTINE cp_1d_i4_sort(arr) + INTEGER(kind=4), DIMENSION(:), & + INTENT(inout) :: arr + arr = (/ (i, i = 1, SIZE(arr)) /) + END SUBROUTINE +END MODULE M1 + +PROGRAM TEST + USE M1 + INTEGER :: arr(1) + INTERFACE + SUBROUTINE mtrace() BIND(C,name="mtrace") + END SUBROUTINE + END INTERFACE + INTERFACE + SUBROUTINE muntrace() BIND(C,name="muntrace") + END SUBROUTINE + END INTERFACE + CALL mtrace() + CALL cp_1d_i4_sort(arr) + CALL muntrace() +END + +! { dg-final { scan-tree-dump-times "realloc" 0 "original" } } diff --git a/Fortran/gfortran/regression/array_constructor_42.f90 b/Fortran/gfortran/regression/array_constructor_42.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_42.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +! PR fortran/54730 +! A symbol 'a' was created while attempting to parse a typespec in the array +! constructor. That (invalid) symbol was kept until translation stage +! where it was leading to an ICE. +! +! Original testcase from Paul Kapinos +! + + subroutine s + implicit none + intrinsic :: real + real :: vec(1:2) + vec = (/ real(a = 1), 1. /) + end subroutine s + + program main + implicit none + intrinsic :: real + print *,(/ real(a = 1) /) + end diff --git a/Fortran/gfortran/regression/array_constructor_43.f90 b/Fortran/gfortran/regression/array_constructor_43.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_43.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-ffrontend-optimize -fdump-tree-original" } +program main + implicit none + real :: a,b,c,d + call random_number(a) + call random_number(b) + call random_number(c) + call random_number(d) + if (any ([a,b,c,d] < 0.2)) print *,"foo" +end program main +! { dg-final { scan-tree-dump-times "\\\|\\\|" 3 "original" } } diff --git a/Fortran/gfortran/regression/array_constructor_44.f90 b/Fortran/gfortran/regression/array_constructor_44.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_44.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize" } +! PR 56872 - wrong front-end optimization with a single constructor. +! Original bug report by Rich Townsend. + integer :: k + real :: s + integer :: m + s = 2.0 + m = 4 + res = SUM([(s**(REAL(k-1)/REAL(m-1)),k=1,m)]) + if (abs(res - 5.84732246) > 1e-6) STOP 1 + end diff --git a/Fortran/gfortran/regression/array_constructor_45.f90 b/Fortran/gfortran/regression/array_constructor_45.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_45.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! PR PR 56872 - wrong front-end optimization with a +! single array constructor and another value. +program main + real :: s + integer :: m + integer :: k + real :: res + + m = 2 + s = 1000. + + res = SUM([3.0,(s**(REAL(k-1)/REAL(m-1)),k=1,m),17.]) + if (abs(res - 1021.)>1e-4) STOP 1 +end diff --git a/Fortran/gfortran/regression/array_constructor_46.f90 b/Fortran/gfortran/regression/array_constructor_46.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_46.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize -fdump-tree-original" } +! Test that nested array constructors are optimized. +program main + implicit none + integer, parameter :: dp=selected_real_kind(15) + real(kind=dp), dimension(2,2) :: a + real(kind=dp) thirteen + + data a /2._dp,3._dp,5._dp,7._dp/ + thirteen = 13._dp + if (abs (product([[11._dp, thirteen], a]) - 30030._dp) > 1e-8) STOP 1 +end program main +! { dg-final { scan-tree-dump-times "while" 2 "original" } } diff --git a/Fortran/gfortran/regression/array_constructor_47.f90 b/Fortran/gfortran/regression/array_constructor_47.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_47.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize -fdump-tree-original" } +! Test that reduction optimization doesn't break with a function expression +! in an array constructor. +program main + implicit none + integer, parameter :: dp=selected_real_kind(15) + real(kind=dp), dimension(2,2) :: a + real(kind=dp) thirteen + + data a /2._dp,3._dp,5._dp,7._dp/ + thirteen = 13._dp + if (abs (product([[sum([eleven_ones()]), thirteen], a]) - 30030._dp) > 1e-8) STOP 1 + contains + function eleven_ones() + real(kind=dp) :: eleven_ones(11) + integer :: i + + eleven_ones = [ (1._dp, i=1,11) ] + end function eleven_ones +end program main +! { dg-final { scan-tree-dump-times "while" 4 "original" } } + diff --git a/Fortran/gfortran/regression/array_constructor_48.f90 b/Fortran/gfortran/regression/array_constructor_48.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_48.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! +! PR fortran/57549 +! +! Contributed by Vladimir Fuka +! + type t + end type + type(t),allocatable :: a(:) + a = [t::t()] + print *, [ integer :: ] +end + +subroutine invalid() + print *, [ type(integer) :: ] ! { dg-error "Syntax error in array constructor" } + print *, [ type(tt) :: ] ! { dg-error "Syntax error in array constructor" } +end subroutine invalid diff --git a/Fortran/gfortran/regression/array_constructor_49.f90 b/Fortran/gfortran/regression/array_constructor_49.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_49.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize -fdump-tree-original" } +! PR 62106 - this used to give wrong results because +! of a bogus extra temporary variable. +! Original test case by Martien Hulsen +program t + integer :: ndim=2, ndfp=4, i + character (len=8) :: line + write (unit=line,fmt='(4I2)') (/ ( i, i = 1, ndfp ) /) + ndim + if (line /= ' 3 4 5 6') STOP 1 +end program t +! { dg-final { scan-tree-dump-times "__var" 3 "original" } } diff --git a/Fortran/gfortran/regression/array_constructor_5.f90 b/Fortran/gfortran/regression/array_constructor_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_5.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! PR22327 +program array_constructor + implicit none + integer :: a(6), i + i = 6 + a = (/ 1, 2, 3, 4, 5, i /) + do i = 1, 6 + if (a(i) /= i) STOP 1 + end do +end program array_constructor diff --git a/Fortran/gfortran/regression/array_constructor_50.f90 b/Fortran/gfortran/regression/array_constructor_50.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_50.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! PR 71795 - wrong result when putting an array constructor +! instide an iterator. + program test + + implicit none + integer :: i,n + logical, dimension(1) :: ra + logical :: rs + integer, allocatable :: a(:) + + allocate ( a(1) ) + + n = 1 + a = 2 + + ra = (/ (any(a(i).eq.(/1,2,3/)) ,i=1,n) /) + if (.not. all(ra)) STOP 1 + rs = any ( (/ (any(a(i).eq.(/1,2,3/)) ,i=1,n) /) ) + if (.not. rs) STOP 2 + end program test diff --git a/Fortran/gfortran/regression/array_constructor_51.f90 b/Fortran/gfortran/regression/array_constructor_51.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_51.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-additional-options "-ffrontend-optimize -fdump-tree-original" } +! PR 82567 - long compile times caused by large constant constructors +! multiplied by variables + + SUBROUTINE sub() + IMPLICIT NONE + + INTEGER, PARAMETER :: n = 1000 + REAL, ALLOCATABLE :: x(:) + REAL :: xc, h + INTEGER :: i + + ALLOCATE( x(n) ) + xc = 100. + h = xc/n + x = h*[(i,i=1,n)] + +end +! { dg-final { scan-tree-dump-times "__var" 0 "original" } } diff --git a/Fortran/gfortran/regression/array_constructor_52.f90 b/Fortran/gfortran/regression/array_constructor_52.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_52.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! PR 84931 - long array constructors with type conversion were not +! handled correctly. +program test + implicit none + integer, parameter :: n = 2**16 + real, dimension(n) :: y + integer :: i + y = (/ (1, i=1, n) /) + if (y(2) /= 1) stop 1 +end program test diff --git a/Fortran/gfortran/regression/array_constructor_53.f90 b/Fortran/gfortran/regression/array_constructor_53.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_53.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! PR 84931 - long array constructors with type conversion were not +! handled correctly. array_constructor_52.f90 tests the original +! problem. +program test + implicit none + integer, parameter :: n = 2**16 + 1 + real, dimension(n) :: y + real, dimension(2*n) :: z + integer :: i + + y = [33, (1, i=1, n-1) ] ! Check that something more complicated works + if (int(y(3)) /= 1) stop 1 + + z = [[(1, i=1, n) ],[(2, i=1, n) ]] ! Failed with first version of the fix + + if (int(z(2)) /= 1) stop 2 + if (int(z(n+1)) /= 2) stop 3 +end program test diff --git a/Fortran/gfortran/regression/array_constructor_54.f90 b/Fortran/gfortran/regression/array_constructor_54.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_54.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -Warray-temporaries" } +! { dg-final { scan-tree-dump-not "stride" "original" } } +! Verify that no temporary array is generated for a constant array constructor +! See e.g. PR fortran/102717, PR fortran/102787 + +program p + integer, parameter :: a(*) = [1,2,3,4] + integer, parameter :: b(2,3) = reshape([1,2,3,4,5,6], shape (b)) + print *, [a] + print *, [a( : ) ] + print *, [a( ::1)] + print *, [a( ::2)] + print *, [a(1:2:1)] + print *, [a(4:1:-2)] + print *, [a([3,2])] + print *, [a,1] + print *, [1,a] + print *, [a,a] + print *, [b(:,3:1:-2)] + print *, [1,b(1,[2,1,3])] + print *, [a,b] +end diff --git a/Fortran/gfortran/regression/array_constructor_55.f90 b/Fortran/gfortran/regression/array_constructor_55.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_55.f90 @@ -0,0 +1,55 @@ +! { dg-do run } +! PR fortran/66193 - ICE for initialisation of some non-zero-sized arrays +! Testcase by G.Steinmetz + +program p + implicit none + call s1 + call s2 + call s3 + call s4 +contains + subroutine s1 + integer(8), parameter :: z1(2) = 10 + [ integer(8) :: [ integer(4) ::],1,2] + integer(8) :: z2(2) = 10 + [ integer(8) :: [ integer(4) ::],1,2] + integer(8) :: z3(2) + z3 = 10 + [ integer(8) :: [ integer(4) :: ], 1, 2 ] + if ( z1(1) /= 11 .or. z1(2) /= 12 ) stop 1 + if ( z2(1) /= 11 .or. z2(2) /= 12 ) stop 2 + if ( z3(1) /= 11 .or. z3(2) /= 12 ) stop 3 + end subroutine s1 + + subroutine s2 + logical(8), parameter :: z1(3) = .true. .or. & + [ logical(8) :: [ logical(4) :: ], .false., .false., .true. ] + logical(8) :: z2(3) = .true. .or. & + [ logical(8) :: [ logical(4) :: ], .false., .false., .true. ] + logical(8) :: z3(3) + z3 = .true. .or. & + [ logical(8) :: [ logical(4) :: ], .false., .false., .true. ] + if ( .not. all(z1) ) stop 11 + if ( .not. all(z2) ) stop 12 + if ( .not. all(z3) ) stop 13 + end subroutine s2 + + subroutine s3 + real(8), parameter :: eps = 4.0_8 * epsilon(1.0_8) + real(8), parameter :: z1(2) = 10. + [ real(8) :: [ real(4) :: ], 1., 2. ] + real(8) :: z2(2) = 10. + [ real(8) :: [ real(4) :: ], 1., 2. ] + real(8) :: z3(2) + z3 = 10.0 + [ real(8) :: [ real(4) :: ], 1.0, 2.0 ] + + if ( abs(1-z1(1)/11) > eps ) stop 21 + if ( abs(1-z1(2)/12) > eps ) stop 22 + if ( abs(1-z2(1)/11) > eps ) stop 23 + if ( abs(1-z2(2)/12) > eps ) stop 24 + if ( abs(1-z3(1)/11) > eps ) stop 25 + if ( abs(1-z3(2)/12) > eps ) stop 26 + end subroutine s3 + + subroutine s4 + real, parameter :: x(3) = 2.0 * [real :: 1, (2), 3] + real, parameter :: y(2) = [real :: 1, (2)] + 10.0 + real, parameter :: z(2) = [real ::(1),(2)] + 10.0 + end subroutine s4 +end program p diff --git a/Fortran/gfortran/regression/array_constructor_56.f90 b/Fortran/gfortran/regression/array_constructor_56.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_56.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +! Test the fix for the following: +! PR fortran/93483 +! PR fortran/107216 +! PR fortran/107219 +! +! Contributed by G.Steinmetz + +program p + real, parameter :: r0(*) = +[real :: +(1) ] + real, parameter :: r1(*) = +[real :: +[1] ] + real, parameter :: r2(*) = -[real :: [(1)]] + real, parameter :: r3(*) = +[real :: [-(1)]] + real, parameter :: r4(*) = -[real :: [[(1)]]] + real, parameter :: r5(*) = -[real :: -[1, 2]] + real, parameter :: r6(*) = +[real :: +[1, 2]] + real, parameter :: r7(*) = [real :: 1, 2] * [real :: 1, (2)] + real, parameter :: r8(*) = [real :: 1, (2)] * [real :: 1, 2] + real, parameter :: r9(*) = +[real :: 1, 2] * [real :: 1, (2)] + real, parameter :: rr(*) = -[real :: 1, (2)] * [real :: 1, 2] +end diff --git a/Fortran/gfortran/regression/array_constructor_57.f90 b/Fortran/gfortran/regression/array_constructor_57.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_57.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! PR fortran/93483 +! +! Verify that resolution (host associated parameter vs. contained function) works. +! +! Contributed by Mikael Morin + +module m + implicit none + integer, parameter :: a(*) = [ 7, 11 ] +contains + subroutine bug + real :: b(1), c(1) + b = [ real :: (a(1)) ] + c = [ real :: a(1) ] + print *, b, c + if (any (b /= [ 14. ])) stop 1 + if (any (c /= [ 14. ])) stop 2 + contains + function a(c) + integer :: a, c + a = c + 13 + end function a + end subroutine bug +end module m + +program p + use m + call bug +end program p diff --git a/Fortran/gfortran/regression/array_constructor_6.f90 b/Fortran/gfortran/regression/array_constructor_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_6.f90 @@ -0,0 +1,25 @@ +! PR 12840. Make sure that array constructors can be used to determine +! the bounds of a scalarization loop. +! { dg-do run } +program main + implicit none + call build (11) +contains + subroutine build (order) + integer :: order, i + + call test (order, (/ (i * 2, i = 1, order) /)) + call test (17, (/ (i * 2, i = 1, 17) /)) + call test (5, (/ 2, 4, 6, 8, 10 /)) + end subroutine build + + subroutine test (order, values) + integer, dimension (:) :: values + integer :: order, i + + if (size (values, dim = 1) .ne. order) STOP 1 + do i = 1, order + if (values (i) .ne. i * 2) STOP 2 + end do + end subroutine test +end program main diff --git a/Fortran/gfortran/regression/array_constructor_7.f90 b/Fortran/gfortran/regression/array_constructor_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_7.f90 @@ -0,0 +1,26 @@ +! Like array_constructor_6.f90, but test for nested iterators. +! { dg-do run } +program main + implicit none + call build (17) +contains + subroutine build (order) + integer :: order, i, j + + call test (order, (/ (((j + 100) * i, j = 1, i), i = 1, order) /)) + call test (9, (/ (((j + 100) * i, j = 1, i), i = 1, 9) /)) + call test (3, (/ 101, 202, 204, 303, 306, 309 /)) + end subroutine build + + subroutine test (order, values) + integer, dimension (:) :: values + integer :: order, i, j + + if (size (values, dim = 1) .ne. order * (order + 1) / 2) STOP 1 + do i = 1, order + do j = 1, i + if (values (i * (i - 1) / 2 + j) .ne. (j + 100) * i) STOP 2 + end do + end do + end subroutine test +end program main diff --git a/Fortran/gfortran/regression/array_constructor_8.f90 b/Fortran/gfortran/regression/array_constructor_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_8.f90 @@ -0,0 +1,46 @@ +! Like array_constructor_6.f90, but check constructors that mix iterators +! and individual scalar elements. +! { dg-do run } +program main + implicit none + call build (42) +contains + subroutine build (order) + integer :: order, i + + call test (order, 8, 5, (/ ((/ 1, 2, 3, 4, 5, 6, 7, 8 /), i = 1, order), & + 100, 200, 300, 400, 500 /)) + + call test (order, 2, 3, (/ ((/ 1, 2 /), i = 1, order), & + 100, 200, 300 /)) + + call test (order, 3, 5, (/ ((/ 1, 2, 3 /), i = 1, order), & + 100, 200, 300, 400, 500 /)) + + call test (order, 6, 1, (/ ((/ 1, 2, 3, 4, 5, 6 /), i = 1, order), & + 100 /)) + + call test (order, 5, 0, (/ ((/ 1, 2, 3, 4, 5 /), i = 1, order) /)) + + call test (order, 0, 4, (/ 100, 200, 300, 400 /)) + + call test (11, 5, 2, (/ ((/ 1, 2, 3, 4, 5 /), i = 1, 11), & + 100, 200 /)) + + call test (6, 2, order, (/ ((/ 1, 2 /), i = 1, 6), & + (i * 100, i = 1, order) /)) + end subroutine build + + subroutine test (order, repeat, trail, values) + integer, dimension (:) :: values + integer :: order, repeat, trail, i + + if (size (values, dim = 1) .ne. order * repeat + trail) STOP 1 + do i = 1, order * repeat + if (values (i) .ne. mod (i - 1, repeat) + 1) STOP 2 + end do + do i = 1, trail + if (values (i + order * repeat) .ne. i * 100) STOP 3 + end do + end subroutine test +end program main diff --git a/Fortran/gfortran/regression/array_constructor_9.f90 b/Fortran/gfortran/regression/array_constructor_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_9.f90 @@ -0,0 +1,43 @@ +! Like array_constructor_6.f90, but check constructors in which the length +! of each subarray can only be determined at run time. +! { dg-do run } +program main + implicit none + call build (9) +contains + function gen (order) + real, dimension (:, :), pointer :: gen + integer :: order, i, j + + allocate (gen (order, order + 1)) + forall (i = 1 : order, j = 1 : order + 1) gen (i, j) = i * i + j + end function gen + + ! Deliberately leaky! + subroutine build (order) + integer :: order, i + + call test (order, 0, (/ (gen (i), i = 1, order) /)) + call test (3, 2, (/ ((/ 1.5, 1.5, gen (i) /), i = 1, 3) /)) + end subroutine build + + subroutine test (order, prefix, values) + real, dimension (:) :: values + integer :: order, prefix, last, i, j, k + + last = 0 + do i = 1, order + do j = 1, prefix + last = last + 1 + if (values (last) .ne. 1.5) STOP 1 + end do + do j = 1, i + 1 + do k = 1, i + last = last + 1 + if (values (last) .ne. j + k * k) STOP 2 + end do + end do + end do + if (size (values, dim = 1) .ne. last) STOP 3 + end subroutine test +end program main diff --git a/Fortran/gfortran/regression/array_constructor_type_1.f03 b/Fortran/gfortran/regression/array_constructor_type_1.f03 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_type_1.f03 @@ -0,0 +1,17 @@ +! { 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 + STOP 1 + END IF +END PROGRAM test diff --git a/Fortran/gfortran/regression/array_constructor_type_10.f03 b/Fortran/gfortran/regression/array_constructor_type_10.f03 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_type_10.f03 @@ -0,0 +1,23 @@ +! { 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 + STOP 1 + END IF + END SUBROUTINE foo +END PROGRAM test diff --git a/Fortran/gfortran/regression/array_constructor_type_11.f03 b/Fortran/gfortran/regression/array_constructor_type_11.f03 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_type_11.f03 @@ -0,0 +1,11 @@ +! { dg-do run } +! +! PR fortran/27997 +! +! Empty array constructor with typespec. +! + integer :: i(3) + i(3:2) = (/ integer :: /) + if (len((/ character(5) :: /)) /= 5) STOP 1 + if (kind((/ integer(8) :: /)) /= 8) STOP 2 +end diff --git a/Fortran/gfortran/regression/array_constructor_type_12.f03 b/Fortran/gfortran/regression/array_constructor_type_12.f03 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_type_12.f03 @@ -0,0 +1,12 @@ +! { 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 )) STOP 1 +end diff --git a/Fortran/gfortran/regression/array_constructor_type_13.f90 b/Fortran/gfortran/regression/array_constructor_type_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_type_13.f90 @@ -0,0 +1,14 @@ +! { 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 )) STOP 1 +end diff --git a/Fortran/gfortran/regression/array_constructor_type_14.f03 b/Fortran/gfortran/regression/array_constructor_type_14.f03 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_type_14.f03 @@ -0,0 +1,24 @@ +! { 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 = (/ 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 + STOP 1 + END IF +END PROGRAM test diff --git a/Fortran/gfortran/regression/array_constructor_type_15.f03 b/Fortran/gfortran/regression/array_constructor_type_15.f03 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_type_15.f03 @@ -0,0 +1,22 @@ +! { 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 (*,*) (/ foo :: x, foo(0, 1.), bar(.TRUE.) /) ! { dg-error "convert TYPE" } +END PROGRAM test diff --git a/Fortran/gfortran/regression/array_constructor_type_16.f03 b/Fortran/gfortran/regression/array_constructor_type_16.f03 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_type_16.f03 @@ -0,0 +1,25 @@ +! { 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) STOP 1 + arr = (/ INTEGER(KIND=8) :: [ INTEGER(KIND=4) :: 4, 42, 12 ] /) + IF (arr(1) /= 4 .OR. arr(2) /= 42 .OR. arr(3) /= 12) STOP 2 + arr = (/ INTEGER(KIND=8) :: [ INTEGER(KIND=4) :: 4, 42 ], 12 /) + IF (arr(1) /= 4 .OR. arr(2) /= 42 .OR. arr(3) /= 12) STOP 3 + arr = (/ INTEGER(KIND=8) :: [ INTEGER(KIND=4) :: ], 4, 42, 12 /) + IF (arr(1) /= 4 .OR. arr(2) /= 42 .OR. arr(3) /= 12) STOP 4 + + carr = [ CHARACTER(len=6) :: "foo", [ CHARACTER(len=4) :: "foobar", "xyz" ] ] + IF (carr(1) /= "foo" .OR. carr(2) /= "foob" .OR. carr(3) /= "xyz") THEN + STOP 5 + END IF +END PROGRAM test diff --git a/Fortran/gfortran/regression/array_constructor_type_17.f03 b/Fortran/gfortran/regression/array_constructor_type_17.f03 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_type_17.f03 @@ -0,0 +1,12 @@ +! { 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" } +END PROGRAM test diff --git a/Fortran/gfortran/regression/array_constructor_type_18.f03 b/Fortran/gfortran/regression/array_constructor_type_18.f03 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_type_18.f03 @@ -0,0 +1,12 @@ +! { 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 diff --git a/Fortran/gfortran/regression/array_constructor_type_19.f03 b/Fortran/gfortran/regression/array_constructor_type_19.f03 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_type_19.f03 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } + +! PR fortran/36517 +! Check for incorrect error message with -std=f2003. +! This is the test of comment #1, PR 36517. + +print *, [ character(len=2) :: 'a', 'bb' ] +end diff --git a/Fortran/gfortran/regression/array_constructor_type_2.f03 b/Fortran/gfortran/regression/array_constructor_type_2.f03 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_type_2.f03 @@ -0,0 +1,20 @@ +! { 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) STOP 1 + if ( size([ integer :: ]) /= 0) STOP 2 + 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))& + STOP 3 +end program test diff --git a/Fortran/gfortran/regression/array_constructor_type_20.f03 b/Fortran/gfortran/regression/array_constructor_type_20.f03 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_type_20.f03 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } + +! PR fortran/36517 +! Check for incorrect error message with -std=f2003. +! This is the original test from PR 36517. + +CHARACTER (len=*) MY_STRING(1:3) +PARAMETER ( MY_STRING = (/ CHARACTER (len=3) :: "AC", "B", "C" /) ) +CHARACTER (len=*), PARAMETER :: str(2) = [ CHARACTER (len=3) :: 'A', 'cc' ] +END diff --git a/Fortran/gfortran/regression/array_constructor_type_21.f03 b/Fortran/gfortran/regression/array_constructor_type_21.f03 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_type_21.f03 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } + +! PR fortran/36492 +! Check that it works with a typespec even for not-the-same-length elements. + +type t + character (1) :: arr (2) = [ character(len=2) :: "a", "ab" ] +end type t + +end diff --git a/Fortran/gfortran/regression/array_constructor_type_22.f03 b/Fortran/gfortran/regression/array_constructor_type_22.f03 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_type_22.f03 @@ -0,0 +1,29 @@ +! { dg-do compile } +! PR Fortran/83548 +program foo + + implicit none + + logical, parameter :: t = .true., f = .false. + logical, parameter :: a1(2) = [t, f] + logical(kind=1), parameter :: a2(2) = [logical(kind=1) :: t, f] + logical(kind=4), parameter :: a3(2) = [logical(kind=4) :: t, f] + logical(kind=1), parameter :: a4(2) = [logical(t, 1), logical(f, 1)] + logical(kind=4), parameter :: a5(2) = [logical(t, 4), logical(f, 4)] + logical(kind=1) b(2) + logical(kind=4) c(2) + + real, parameter :: x = 1, y = 2 + real, parameter :: r1(2) = [x, y] + real(kind=4), parameter :: r2(2) = [real(kind=4) :: x, y] + real(kind=8), parameter :: r3(2) = [real(kind=8) :: x, y] + real(kind=4), parameter :: r4(2) = [real(x, 4), real(y, 4)] + real(kind=8), parameter :: r5(2) = [real(x, 8), real(y, 8)] + real(kind=4) p(2) + real(kind=8) q(2) + + p = [real(kind=4) :: x, y] + q = [real(kind=8) :: x, y] + if (any(p .ne. r2)) STOP 1 + if (any(q .ne. r3)) STOP 2 +end program foo diff --git a/Fortran/gfortran/regression/array_constructor_type_23.f90 b/Fortran/gfortran/regression/array_constructor_type_23.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_type_23.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR 83999 - this used to ICE +! Origial test case by Gerhard Steinmetz + +program p + character(2) :: c = 'a' // [character :: [1]] ! { dg-error "Illegal type in character concatenation" } +end diff --git a/Fortran/gfortran/regression/array_constructor_type_3.f03 b/Fortran/gfortran/regression/array_constructor_type_3.f03 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_type_3.f03 @@ -0,0 +1,16 @@ +! { 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 + STOP 1 + END IF +END PROGRAM test diff --git a/Fortran/gfortran/regression/array_constructor_type_4.f03 b/Fortran/gfortran/regression/array_constructor_type_4.f03 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_type_4.f03 @@ -0,0 +1,15 @@ +! { 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 + STOP 1 + END IF +END PROGRAM test diff --git a/Fortran/gfortran/regression/array_constructor_type_5.f03 b/Fortran/gfortran/regression/array_constructor_type_5.f03 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_type_5.f03 @@ -0,0 +1,18 @@ +! { 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))& + STOP 1 +end program test diff --git a/Fortran/gfortran/regression/array_constructor_type_6.f03 b/Fortran/gfortran/regression/array_constructor_type_6.f03 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_type_6.f03 @@ -0,0 +1,30 @@ +! { 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 + STOP 1 + 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 + STOP 2 + 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 + STOP 3 + end if + +end program test diff --git a/Fortran/gfortran/regression/array_constructor_type_7.f03 b/Fortran/gfortran/regression/array_constructor_type_7.f03 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_type_7.f03 @@ -0,0 +1,23 @@ +! { 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 + STOP 1 + END IF + END SUBROUTINE foo +END PROGRAM test diff --git a/Fortran/gfortran/regression/array_constructor_type_8.f03 b/Fortran/gfortran/regression/array_constructor_type_8.f03 --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_type_8.f03 @@ -0,0 +1,13 @@ +! { 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 diff --git a/Fortran/gfortran/regression/array_constructor_type_9.f b/Fortran/gfortran/regression/array_constructor_type_9.f --- /dev/null +++ b/Fortran/gfortran/regression/array_constructor_type_9.f @@ -0,0 +1,10 @@ +! { 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 diff --git a/Fortran/gfortran/regression/array_function_1.f90 b/Fortran/gfortran/regression/array_function_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_function_1.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! PR fortran/30720 +program array_function_1 + integer :: a(5), b, l, u + l = 4 + u = 2 + + a = (/ 1, 2, 3, 4, 5 /) + + b = f(a(l:u) - 2) + if (b /= 0) STOP 1 + + b = f(a(4:2) - 2) + if (b /= 0) STOP 2 + + b = f(a(u:l) - 2) + if (b /= 3) STOP 3 + + b = f(a(2:4) - 2) + if (b /= 3) STOP 4 + + contains + integer function f(x) + integer, dimension(:), intent(in) :: x + f = sum(x) + end function +end program diff --git a/Fortran/gfortran/regression/array_function_2.f90 b/Fortran/gfortran/regression/array_function_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_function_2.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } + +! PR fortran/37199 +! We used to produce wrong (segfaulting) code for this one because the +! temporary array for the function result had wrong bounds. + +! Contributed by Gavin Salam + +program bounds_issue + implicit none + integer, parameter :: dp = kind(1.0d0) + real(dp), pointer :: pdf0(:,:), dpdf(:,:) + + allocate(pdf0(0:282,-6:7)) + allocate(dpdf(0:282,-6:7)) ! with dpdf(0:283,-6:7) [illegal] error disappears + !write(0,*) lbound(dpdf), ubound(dpdf) + dpdf = tmp_PConv(pdf0) + +contains + function tmp_PConv(q_in) result(Pxq) + real(dp), intent(in) :: q_in(0:,-6:) + real(dp) :: Pxq(0:ubound(q_in,dim=1),-6:7) + Pxq = 0d0 + !write(0,*) lbound(q_in), ubound(q_in) + !write(0,*) lbound(Pxq), ubound(Pxq) + return + end function tmp_PConv + +end program bounds_issue diff --git a/Fortran/gfortran/regression/array_function_3.f90 b/Fortran/gfortran/regression/array_function_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_function_3.f90 @@ -0,0 +1,46 @@ +! { dg-do compile } + +! PR fortran/36167 +! This used to cause an ICE because of a missing array spec after interface +! mapping. + +! Contributed by Frank Muldoon + +module communication_tools + +contains +!******************************************************************************* +function overlap_1(u,lbound_u,ubound_u) +!******************************************************************************* +integer, intent(in), dimension(:) :: lbound_u,ubound_u +real, intent(in), dimension(lbound_u(1):ubound_u(1),lbound_u(2):ubound_u(2),& + lbound_u(3):ubound_u(3)) :: u + +real, dimension(& +lbound(u,1):ubound(u,1),& +lbound(u,2):ubound(u,2),& +lbound(u,3):ubound(u,3)) :: overlap_1 + +return +end function overlap_1 + +end module communication_tools + +!******************************************************************************* +subroutine write_out_particles +!******************************************************************************* + +use communication_tools +real, dimension(1:5, 2:4, 3:10) :: vorticityMag +real, allocatable, dimension(:,:,:) :: temp3d + +allocate(temp3d( & +lbound(overlap_1(vorticityMag,lbound(vorticityMag),ubound(vorticityMag)),1):& +ubound(overlap_1(vorticityMag,lbound(vorticityMag),ubound(vorticityMag)),1),& +lbound(overlap_1(vorticityMag,lbound(vorticityMag),ubound(vorticityMag)),2):& +ubound(overlap_1(vorticityMag,lbound(vorticityMag),ubound(vorticityMag)),2),& +lbound(overlap_1(vorticityMag,lbound(vorticityMag),ubound(vorticityMag)),3):& +ubound(overlap_1(vorticityMag,lbound(vorticityMag),ubound(vorticityMag)),3))) + +return +end subroutine write_out_particles diff --git a/Fortran/gfortran/regression/array_function_4.f90 b/Fortran/gfortran/regression/array_function_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_function_4.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } + +! PR fortran/37411 +! This used to cause an ICE because of a missing array spec after interface +! mapping. + +! Contributed by Kristjan Jonasson + +MODULE B1 +CONTAINS + subroutine sub() + integer :: x(1) + character(3) :: st + st = fun(x) + end subroutine sub + + function fun(x) result(st) + integer, intent(in) :: x(1) + character(lenf(x)) :: st + st = 'abc' + end function fun + + pure integer function lenf(x) + integer, intent(in) :: x(1) + lenf = x(1) + end function lenf +END MODULE B1 diff --git a/Fortran/gfortran/regression/array_function_5.f90 b/Fortran/gfortran/regression/array_function_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_function_5.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! PR41278 internal compiler error related to matmul and transpose +! Test case prepared by Jerry DeLisle +! Original test case by Chris +program bug + implicit none + real, dimension(3,3) :: matA,matB,matC + + matA(1,:)=(/1., 2., 3./) + matA(2,:)=(/4., 5., 6./) + matA(3,:)=(/7., 8., 9./) + + matB=matmul(transpose(0.5*matA),matA) + matC = transpose(0.5*matA) + matC = matmul(matC, matA) + if (any(matB.ne.matC)) STOP 1 +end program bug diff --git a/Fortran/gfortran/regression/array_function_6.f90 b/Fortran/gfortran/regression/array_function_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_function_6.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! PR46842 wrong results with MATMUL(..., TRANSPOSE (func ())) +implicit none +call sub() +contains + subroutine sub() + real, dimension(2,2) :: b + b = 1.0 + b = matmul(b,transpose(func())) + if (any(b.ne.reshape((/ 4.0, 4.0, 6.0, 6.0 /),[2,2]) )) print *, b + end subroutine + + function func() result(res) + real, dimension(2,2) :: res + res = reshape([1,2,3,4], [2,2]) + end function +end diff --git a/Fortran/gfortran/regression/array_initializer_1.f90 b/Fortran/gfortran/regression/array_initializer_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_initializer_1.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! Check the fix for PR16206, in which array sections would not work +! in array initializers. Use of implied do loop variables for indices +! and substrings, with and without implied do loops, were fixed at the +! same time. +! +! Contributed by Paul Thomas +! based on testcase from Harald Anlauf +! + real, parameter :: x(4,4) = reshape((/(i, i = 1, 16)/), (/4,4/)) + real, parameter :: y(4) = (/ x(1:2, 2), x(3:4, 4)/) + real, parameter :: z(2) = x(2:3, 3) + 1 + real, parameter :: r(6) = (/(x(i:i +1, i), i = 1,3)/) + real, parameter :: s(12) = (/((x(i, i:j-1:-1), i = 3,4), j = 2,3)/) + real, parameter :: t(8) = (/(z, real (i)**3, y(i), i = 2, 3)/) + + integer, parameter :: ii = 4 + + character(4), parameter :: chr(4) = (/"abcd", "efgh", "ijkl", "mnop"/) + character(4), parameter :: chrs = chr(ii)(2:3)//chr(2)(ii-3:ii-2) + character(4), parameter :: chrt(2) = (/chr(2:2)(2:3), chr(ii-1)(3:ii)/) + character(2), parameter :: chrx(2) = (/(chr(i)(i:i+1), i=2,3)/) + + if (any (y .ne. (/5., 6., 15., 16./))) STOP 1 + if (any (z .ne. (/11., 12./))) STOP 2 + if (any (r .ne. (/1., 2., 6., 7., 11., 12./))) STOP 3 + if (any (s .ne. (/11., 7., 3., 16., 12., 8., 4., & + 11., 7., 16., 12., 8. /))) STOP 4 + + if (any (t .ne. (/11., 12., 8., 6., 11., 12., 27., 15. /))) STOP 5 + + if (chrs .ne. "noef") STOP 6 + if (any (chrt .ne. (/"fg", "kl"/))) STOP 7 + if (any (chrx .ne. (/"fg", "kl"/))) STOP 8 +end diff --git a/Fortran/gfortran/regression/array_initializer_2.f90 b/Fortran/gfortran/regression/array_initializer_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_initializer_2.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! Tests the fix for PR28496 in which initializer array constructors with +! a missing initial array index would cause an ICE. +! +! Test for the fix of the initializer array constructor part of PR29975 +! was added later. Here, the indexing would get in a mess if the array +! specification had a lower bound other than unity. +! +! Contributed by Paul Thomas +! Based on original test case from Samir Nordin +! + integer, dimension(3), parameter :: a=(/1,2,3/) + integer, dimension(3), parameter :: b=(/a(:)/) + integer, dimension(3,3), parameter :: c=reshape ((/(i, i = 1,9)/),(/3,3/)) + integer, dimension(2,3), parameter :: d=reshape ((/c(3:2:-1,:)/),(/2,3/)) + integer, dimension(3,3), parameter :: e=reshape ((/a(:),a(:)+3,a(:)+6/),(/3,3/)) + integer, dimension(2,3), parameter :: f=reshape ((/c(2:1:-1,:)/),(/2,3/)) + CHARACTER (LEN=1), DIMENSION(3:7), PARAMETER :: g = & + (/ '+', '-', '*', '/', '^' /) + CHARACTER (LEN=3) :: h = "A+C" +! +! PR28496 +! + if (any (b .ne. (/1,2,3/))) STOP 1 + if (any (reshape(d,(/6/)) .ne. (/3, 2, 6, 5, 9, 8/))) STOP 2 + if (any (reshape(f,(/6/)) .ne. (/2, 1, 5, 4, 8, 7/))) STOP 3 +! +! PR29975 +! + IF (all(h(2:2) /= g(3:4))) STOP 4 +end diff --git a/Fortran/gfortran/regression/array_initializer_3.f90 b/Fortran/gfortran/regression/array_initializer_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_initializer_3.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! Tests the fix for PR28923 in which initializer array constructors with +! a missing initial array index and negative stride would be incorrectly +! interpreted. +! +! Contributed by Dominique d'Humieres +! +real, dimension(3,3), parameter :: a=reshape ((/(i, i = 1,9)/),(/3,3/)) +real, dimension(2,3) :: b=a(:2:-1,:) ! { dg-error "Different shape for array assignment" } +real, dimension(2,3) :: c=a(3:2:-1,:) +print *, b +print *, c +end + diff --git a/Fortran/gfortran/regression/array_memcpy_1.f90 b/Fortran/gfortran/regression/array_memcpy_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_memcpy_1.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } +subroutine testi(a,b) + integer :: a(20) + integer :: b(20) + a = b; +end subroutine + +subroutine testr(a,b) + real :: a(20) + real :: b(20) + a = b; +end subroutine + +subroutine testz(a,b) + complex :: a(20) + complex :: b(20) + a = b; +end subroutine + +subroutine testl(a,b) + logical :: a(20) + logical :: b(20) + a = b; +end subroutine + +! { dg-final { scan-tree-dump-times "memcpy" 4 "original" } } diff --git a/Fortran/gfortran/regression/array_memcpy_2.f90 b/Fortran/gfortran/regression/array_memcpy_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_memcpy_2.f90 @@ -0,0 +1,19 @@ +! This checks that the "z = y" assignment is not considered copyable, as the +! array is of a derived type containing allocatable components. Hence, we +! we should expand the scalarized loop, which contains *two* memcpy calls. +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } + + type :: a + integer, allocatable :: i(:) + end type a + + type :: b + type (a), allocatable :: at(:) + end type b + + type(b) :: y(2), z(2) + + z = y +end +! { dg-final { scan-tree-dump-times "memcpy" 2 "original" } } diff --git a/Fortran/gfortran/regression/array_memcpy_3.f90 b/Fortran/gfortran/regression/array_memcpy_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_memcpy_3.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } + +subroutine foo(x) + integer :: x(4) + x(:) = (/ 3, 1, 4, 1 /) +end subroutine + +subroutine bar(x) + integer :: x(4) + x = (/ 3, 1, 4, 1 /) +end subroutine + +! { dg-final { scan-tree-dump-times "memcpy|ref-all\[^\\n\]*ref-all" 2 "original" } } diff --git a/Fortran/gfortran/regression/array_memcpy_4.f90 b/Fortran/gfortran/regression/array_memcpy_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_memcpy_4.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } + type t + logical valid + integer :: x, y + end type + type (t) :: s(5) + type (t) :: d(5) + + d = s +end +! { dg-final { scan-tree-dump-times "memcpy" 1 "original" } } diff --git a/Fortran/gfortran/regression/array_memcpy_5.f90 b/Fortran/gfortran/regression/array_memcpy_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_memcpy_5.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! Tests the fix for PR33370, in which array copying, with subreferences +! was broken due to a regression. +! +! Reported by Thomas Koenig +! +program main + type foo + integer :: i + character(len=3) :: c + end type foo + type(foo), dimension(2) :: a = (/foo (1, "uvw"), foo (2, "xyz")/) + type(foo), dimension(2) :: b = (/foo (101, "abc"), foo (102, "def")/) + a%i = 0 + print *, a + a%i = (/ 12, 2/) + if (any (a%c .ne. (/"uvw", "xyz"/))) STOP 1 + if (any (a%i .ne. (/12, 2/))) STOP 2 + a%i = b%i + if (any (a%c .ne. (/"uvw", "xyz"/))) STOP 3 + if (any (a%i .ne. (/101, 102/))) STOP 4 +end program main diff --git a/Fortran/gfortran/regression/array_memset_1.f90 b/Fortran/gfortran/regression/array_memset_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_memset_1.f90 @@ -0,0 +1,63 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } +subroutine i1(a) + integer :: a(20) + a = 0; +end subroutine + +subroutine i2(a) + integer :: a(20) + a(:) = 0; +end subroutine + +subroutine i3(a) + integer :: a(20) + a(1:20) = 0; +end subroutine + +subroutine r1(a) + real :: a(20) + a = 0.0; +end subroutine + +subroutine r2(a) + real :: a(20) + a(:) = 0.0; +end subroutine + +subroutine r3(a) + real :: a(20) + a(1:20) = 0.0; +end subroutine + +subroutine z1(a) + complex :: a(20) + a = 0; +end subroutine + +subroutine z2(a) + complex :: a(20) + a(:) = 0; +end subroutine + +subroutine z3(a) + complex :: a(20) + a(1:20) = 0; +end subroutine + +subroutine l1(a) + logical :: a(20) + a = .false.; +end subroutine + +subroutine l2(a) + logical :: a(20) + a(:) = .false.; +end subroutine + +subroutine l3(a) + logical :: a(20) + a(1:20) = .false.; +end subroutine + +! { dg-final { scan-tree-dump-times "memset" 12 "original" } } diff --git a/Fortran/gfortran/regression/array_memset_2.f90 b/Fortran/gfortran/regression/array_memset_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_memset_2.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! { dg-options "-O2 -fdump-tree-original" } + +module foo +contains + subroutine bar(a) + real, dimension(:,:) :: a + a(1,:) = 0. + end subroutine bar +end module foo + +program test + use foo + implicit none + real, dimension (2,2) :: a, d, e + real, dimension (1,2) :: b + real, dimension (2) :: c + data a, d, e /12*1.0/ + data b /2*1.0/ + data c /2*1.0/ + + a(1,:) = 0. ! This can't be optimized to a memset. + b(1,:) = 0. ! This is optimized to = {}. + c = 0. ! This is optimized to = {}. + d(:,1) = 0. ! This can't be otimized to a memset. + call bar(e) + + if (any(a /= reshape((/ 0.0, 1.0, 0.0, 1.0/), shape(a)))) STOP 1 + if (any(b /= 0.)) STOP 2 + if (any(c /= 0.)) STOP 3 + if (any(d /= reshape((/ 0.0, 0.0, 1.0, 1.0/), shape(d)))) STOP 4 + if (any(e /= reshape((/ 0.0, 1.0, 0.0, 1.0/), shape(e)))) STOP 5 + +end program + +! { dg-final { scan-tree-dump-times "= {}" 2 "original" } } diff --git a/Fortran/gfortran/regression/array_reference_1.f90 b/Fortran/gfortran/regression/array_reference_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_reference_1.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! Tests the fix for PR31994, aka 31867, in which the offset +! of 'a' in both subroutines was being evaluated incorrectly. +! The testcase for PR31867 is char_length_5.f90 +! +! Contributed by Elizabeth Yip +! and Francois-Xavier Coudert +! +program main + call PR31994 + call PR31994_comment6 +contains + subroutine PR31994 + implicit none + complex (kind=4), dimension(2,2) :: a, b, c + a(1,1) = (1.,1.) + a(2,1) = (2.,2.) + a(1,2) = (3.,3.) + a(2,2) = (4.,4.) + b=conjg (transpose (a)) + c=transpose (a) + c=conjg (c) + if (any (b .ne. c)) STOP 1 + end subroutine PR31994 + subroutine PR31994_comment6 + implicit none + real ,dimension(2,2)::a + integer ,dimension(2,2) :: b, c + a = reshape ((/1.,2.,3.,4./), (/2,2/)) + b=int (transpose(a)) + c = int (a) + c = transpose (c) + if (any (b .ne. c)) STOP 2 + end subroutine PR31994_comment6 +END program main diff --git a/Fortran/gfortran/regression/array_reference_2.f90 b/Fortran/gfortran/regression/array_reference_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_reference_2.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! +! Test the fix for PR89200, in which the indexing did not work in +! the write statement below. +! +! Contributed by Damian Rouson +! + type foo + character(len=:), allocatable :: string + end type + type foo_list + type(foo), allocatable :: entry(:) + end type + type(foo_list) list + character(4) :: buffer + list = foo_list([foo('12'), foo('34')]) + write(buffer, '(2a2)') list%entry(1)%string, list%entry(2)%string + if (buffer .ne. '1234') stop 1 + deallocate (list%entry) +end diff --git a/Fortran/gfortran/regression/array_reference_3.f90 b/Fortran/gfortran/regression/array_reference_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_reference_3.f90 @@ -0,0 +1,195 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } +! +! PR fortran/102043 +! Array indexing was causing the middle-end to conclude the index +! to be non-negative, which can be wrong for arrays with a "reversed-order" +! descriptor. This was fixed by using pointer arithmetic when +! the index can be negative. +! +! This test checks the code generated for array references of various kinds +! of arrays, using either array indexing or pointer arithmetic. + +program p + implicit none + call check_assumed_shape_elem + call check_assumed_shape_scalarized + call check_descriptor_dim + call check_cfi_dim + call check_substring + call check_ptr_elem + call check_ptr_scalarized + call check_explicit_shape_elem + call check_explicit_shape_scalarized + call check_tmp_array + call check_allocatable_array_elem + call check_allocatable_array_scalarized +contains + subroutine cases(assumed_shape_x) + integer :: assumed_shape_x(:) + assumed_shape_x(2) = 10 + end subroutine cases + subroutine check_assumed_shape_elem + integer :: x(3) + x = 0 + call cases(x) + if (any(x /= (/ 0, 10, 0 /))) stop 10 + ! Assumed shape array are referenced with pointer arithmetic. + ! { dg-final { scan-tree-dump-times "\\*\\(\\(integer\\(kind=4\\) \\*\\) assumed_shape_x.\\d+ \\+ \\(sizetype\\) \\(\\(stride.\\d+ \\* 2 \\+ offset.\\d+\\) \\* 4\\)\\) = 10;" 1 "original" } } + end subroutine check_assumed_shape_elem + subroutine casss(assumed_shape_y) + integer :: assumed_shape_y(:) + assumed_shape_y = 11 + end subroutine casss + subroutine check_assumed_shape_scalarized + integer :: y(3) + call casss(y) + if (any(y /= 11)) stop 11 + ! Assumed shape array are referenced with pointer arithmetic. + ! { dg-final { scan-tree-dump-times "\\*\\(\\(integer\\(kind=4\\) \\*\\) assumed_shape_y.\\d+ \\+ \\(sizetype\\) \\(\\(S.\\d+ \\* D.\\d+ \\+ D.\\d+\\) \\* 4\\)\\) = 11;" 1 "original" } } + end subroutine check_assumed_shape_scalarized + subroutine check_descriptor_dim + integer, allocatable :: descriptor(:) + allocate(descriptor(4)) + descriptor(:) = 12 + if (any(descriptor /= 12)) stop 12 + ! The descriptor’s dim array is referenced with array indexing. + ! { dg-final { scan-tree-dump-times "descriptor\\.dim\\\[0\\\]\\.ubound = 4;" 1 "original" } } + end subroutine check_descriptor_dim + subroutine ccfis(cfi_descriptor) bind(c) + integer :: cfi_descriptor(:) + cfi_descriptor = 13 + end subroutine ccfis + subroutine check_cfi_dim + integer :: x(5) + call ccfis(x) + if (any(x /= 13)) stop 13 + ! The cfi descriptor’s dim array is referenced with array indexing. + ! { dg-final { scan-tree-dump-times "cfi_descriptor->dim\\\[idx.\\d+\\\]\\.ubound = _cfi_descriptor->dim\\\[idx.\\d+\\\]\\.extent \\+ \\(cfi_descriptor->dim\\\[idx.\\d+\\\]\\.lbound \\+ -1\\);" 1 "original" } } + end subroutine check_cfi_dim + subroutine css(c) bind(c) + character :: c + c = 'k' + end subroutine css + subroutine check_substring + character(5) :: x + x = 'abcde' + call css(x(3:3)) + if (x /= 'abkde') stop 14 + ! Substrings use array indexing + ! { dg-final { scan-tree-dump-times "css \\(\\(character\\(kind=1\\)\\\[\\d+:\\d+\\\] \\*\\) &x\\\[3\\\].lb: \\d+ sz: \\d+.\\);" 1 "original" } } + end subroutine check_substring + subroutine check_ptr_elem + integer, target :: x(7) + integer, pointer :: ptr_x(:) + x = 0 + ptr_x => x + ptr_x(4) = 16 + if (any(ptr_x /= (/ 0, 0, 0, 16, 0, 0, 0 /))) stop 16 + ! pointers are referenced with pointer arithmetic. + ! { dg-final { scan-tree-dump-times "\\*\\(integer\\(kind=4\\) \\*\\) \\(ptr_x\\.data \\+ \\(sizetype\\) \\(\\(ptr_x\\.offset \\+ ptr_x\\.dim\\\[0\\\]\\.stride \\* 4\\) \\* ptr_x\\.span\\)\\) = 16;" 1 "original" } } + end subroutine check_ptr_elem + subroutine check_ptr_scalarized + integer, target :: y(8) + integer, pointer :: ptr_y(:) + y = 0 + ptr_y => y + ptr_y = 17 + if (any(ptr_y /= 17)) stop 17 + ! pointers are referenced with pointer arithmetic. + ! { dg-final { scan-tree-dump-times "\\*\\(\\(integer\\(kind=4\\) \\*\\) D.\\d+ \\+ \\(sizetype\\) \\(\\(S.\\d+ \\* D.\\d+ \\+ D.\\d+\\) \\* ptr_y\\.span\\)\\) = 17;" 1 "original" } } + end subroutine check_ptr_scalarized + subroutine check_explicit_shape_elem + integer :: explicit_shape_x(9) + explicit_shape_x = 0 + explicit_shape_x(5) = 18 + if (any(explicit_shape_x /= (/ 0, 0, 0, 0, 18, 0, 0, 0, 0 /))) stop 18 + ! Explicit shape arrays are referenced with array indexing. + ! { dg-final { scan-tree-dump-times "explicit_shape_x\\\[4\\\] = 18;" 1 "original" } } + end subroutine check_explicit_shape_elem + subroutine check_explicit_shape_scalarized + integer :: explicit_shape_y(3) + explicit_shape_y = 19 + if (any(explicit_shape_y /= 19)) stop 19 + ! Explicit shape arrays are referenced with array indexing. + ! { dg-final { scan-tree-dump-times "explicit_shape_y\\\[S.\\d+ \\+ -1\\\] = 19;" 1 "original" } } + end subroutine check_explicit_shape_scalarized + subroutine check_tmp_array + integer :: non_tmp(6) + non_tmp = 15 + non_tmp(2:5) = non_tmp(1:4) + non_tmp(3:6) + if (any(non_tmp /= (/ 15, 30, 30, 30, 30, 15 /))) stop 15 + ! temporary arrays use array indexing + ! { dg-final { scan-tree-dump-times "\\(*\\(integer\\(kind=4\\)\\\[4\\\] \\* restrict\\) atmp.\\d+\\.data\\)\\\[S.\\d+\\\] = non_tmp\\\[S.\\d+\\\] \\+ non_tmp\\\[S.\\d+ \\+ 2\\\];" 1 "original" } } + ! { dg-final { scan-tree-dump-times "non_tmp\\\[S.\\d+ \\+ 1\\\] = \\(\\*\\(integer\\(kind=4\\)\\\[4\\\] \\* restrict\\) atmp.\\d+\\.data\\)\\\[S.\\d+\\\];" 1 "original" } } + end subroutine check_tmp_array + subroutine check_allocatable_array_elem + integer, allocatable :: allocatable_x(:) + allocate(allocatable_x(4),source=0) + allocatable_x(2) = 20 + if (any(allocatable_x /= (/ 0, 20, 0, 0 /))) stop 20 + ! Allocatable arrays are referenced with array indexing. + ! { dg-final { scan-tree-dump-times "\\(\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) allocatable_x\\.data\\)\\\[allocatable_x\\.offset \\+ 2\\\] = 20;" 1 "original" } } + end subroutine check_allocatable_array_elem + subroutine check_allocatable_array_scalarized + integer, allocatable :: allocatable_y(:) + allocate(allocatable_y(5),source=0) + allocatable_y = 21 + if (any(allocatable_y /= 21)) stop 21 + ! Allocatable arrays are referenced with array indexing. + ! { dg-final { scan-tree-dump-times "\\(\\*D.\\d+\\)\\\[S.\\d+ \\+ \\D.\\d+\\\] = 21;" 1 "original" } } + end subroutine check_allocatable_array_scalarized + subroutine cares(assumed_rank_x) + integer :: assumed_rank_x(..) + select rank(rank_1_var_x => assumed_rank_x) + rank(1) + rank_1_var_x(3) = 22 + end select + end subroutine cares + subroutine check_assumed_rank_elem + integer :: x(6) + x = 0 + call cares(x) + if (any(x /= (/ 0, 0, 22, 0, 0, 0 /))) stop 22 + ! Assumed rank arrays are referenced with pointer arithmetic. + ! { dg-final { scan-tree-dump-times "\\*\\(\\(integer\\(kind=4\\) \\*\\) __tmp_INTEGER_4_rank_1\\.data \\+ \\(sizetype\\) \\(\\(__tmp_INTEGER_4_rank_1\\.offset \\+ __tmp_INTEGER_4_rank_1\\.dim\\\[0\\\]\\.stride \\* 3\\) \\* 4\\)\\) = 22;" 1 "original" } } + end subroutine check_assumed_rank_elem + subroutine carss(assumed_rank_y) + integer :: assumed_rank_y(..) + select rank(rank_1_var_y => assumed_rank_y) + rank(1) + rank_1_var_y = 23 + end select + end subroutine carss + subroutine check_assumed_rank_scalarized + integer :: y(7) + call carss(y) + if (any(y /= 23)) stop 23 + ! Assumed rank arrays are referenced with pointer arithmetic. + ! { dg-final { scan-tree-dump-times "\\*\\(\\(integer\\(kind=4\\) \\*\\) D.\\d+ \\+ \\(sizetype\\) \\(\\(S.\\d+ \\* D.\\d+ \\+ D.\\d+\\) \\* 4\\)\\) = 23;" 1 "original" } } + end subroutine check_assumed_rank_scalarized + subroutine casces(assumed_shape_cont_x) + integer, dimension(:), contiguous :: assumed_shape_cont_x + assumed_shape_cont_x(4) = 24 + end subroutine casces + subroutine check_assumed_shape_cont_elem + integer :: x(8) + x = 0 + call casces(x) + if (any(x /= (/ 0, 0, 0, 24, 0, 0, 0, 0 /))) stop 24 + ! Contiguous assumed shape arrays are referenced with array indexing. + ! { dg-final { scan-tree-dump-times "\\(\\*assumed_shape_cont_x.\\d+\\)\\\[stride.\\d+ \\* 4 \\+ offset.\\d+\\\] = 24;" 1 "original" } } + end subroutine check_assumed_shape_cont_elem + subroutine cascss(assumed_shape_cont_y) + integer, dimension(:), contiguous :: assumed_shape_cont_y + assumed_shape_cont_y = 25 + end subroutine cascss + subroutine check_assumed_shape_cont_scalarized + integer :: y(9) + call cascss(y) + if (any(y /= 25)) stop 25 + ! Contiguous assumed shape arrays are referenced with array indexing. + ! { dg-final { scan-tree-dump-times "\\(\\*assumed_shape_cont_y.\\d+\\)\\\[S.\\d+ \\* D.\\d+ \\+ D.\\d+\\\] = 25;" 1 "original" } } + end subroutine check_assumed_shape_cont_scalarized +end program p + diff --git a/Fortran/gfortran/regression/array_return_value_1.f90 b/Fortran/gfortran/regression/array_return_value_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_return_value_1.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! Tests the fix for PR27124 in which the unpacking of argument +! temporaries and of array result temporaries occurred in the +! incorrect order. +! +! Test is based on the original example, provided by +! Philippe Schaffnit +! + PROGRAM Test + INTEGER :: Array(2, 3) = reshape ((/1,4,2,5,3,6/),(/2,3/)) + integer :: Brray(2, 3) = 0 + Brray(1,:) = Function_Test (Array(1,:)) + if (any(reshape (Brray, (/6/)) .ne. (/11, 0, 12, 0, 13, 0/))) STOP 1 + Array(1,:) = Function_Test (Array(1,:)) + if (any(reshape (Array, (/6/)) .ne. (/11, 4, 12, 5, 13, 6/))) STOP 2 + + contains + FUNCTION Function_Test (Input) + INTEGER, INTENT(IN) :: Input(1:3) + INTEGER :: Function_Test(1:3) + Function_Test = Input + 10 + END FUNCTION Function_Test + END PROGRAM Test + diff --git a/Fortran/gfortran/regression/array_section_1.f90 b/Fortran/gfortran/regression/array_section_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_section_1.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! Tests the fix for PR30003, in which the 'end' of an array section +! would not be evaluated at all if it was on the lhs of an assignment +! or would be evaluated many times if bound checking were on. +! +! Contributed by Erik Edelmann +! + implicit none + integer :: a(5), b(3), cnt + + b = [ 1, 2, 3 ] +! Check the lhs references + cnt = 0 + a(bar(1):3) = b + if (cnt /= 1) STOP 1 + cnt = 0 + a(1:bar(3)) = b + if (cnt /= 1) STOP 2 + cnt = 0 + a(1:3:bar(1)) = b + if (cnt /= 1) STOP 3 +! Check the rhs references + cnt = 0 + a(1:3) = b(bar(1):3) + if (cnt /= 1) STOP 4 + cnt = 0 + a(1:3) = b(1:bar(3)) + if (cnt /= 1) STOP 5 + cnt = 0 + a(1:3) = b(1:3:bar(1)) + if (cnt /= 1) STOP 6 +contains + integer function bar(n) + integer, intent(in) :: n + cnt = cnt + 1 + bar = n + end function bar +end diff --git a/Fortran/gfortran/regression/array_section_2.f90 b/Fortran/gfortran/regression/array_section_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_section_2.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR38033 - size(a) was not stabilized correctly and so the expression was +! evaluated twice outside the loop and then within the scalarization loops. +! +! Contributed by Thomas Bruel +! +program test + integer, parameter :: n = 100 + real, pointer :: a(:),temp(:) ! pointer or allocatable have the same effect + allocate(a(n), temp(n)) + temp(1:size(a)) = a +end program +! { dg-final { scan-tree-dump-times "MAX_EXPR\[^\n\t\]+ubound\[^\n\t\]+lbound" 1 "original" } } diff --git a/Fortran/gfortran/regression/array_section_3.f90 b/Fortran/gfortran/regression/array_section_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_section_3.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! +! PR fortran/54225 +! +! Contributed by robb wu +! +program test + implicit none + real :: A(2,3) + + print *, A(1, *) ! { dg-error "Expected array subscript" } +end program + +subroutine test2 +integer, dimension(2) :: a +a(*) = 1 ! { dg-error "Expected array subscript" } +end diff --git a/Fortran/gfortran/regression/array_simplify_1.f90 b/Fortran/gfortran/regression/array_simplify_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_simplify_1.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! Tests the fix for PR24168, in which line would return +! Error: Incompatible ranks 2 and 1 in assignment at (1) +! This came about because the simplification of the binary +! operation, in the first actual argument of spread, was not +! returning the rank of the result. Thus the error could +! be generated with any operator and other intrinsics than +! cshift. +! +! Contributed by Steve Kargl +! + integer, parameter :: nx=2, ny=2 + real, dimension(nx, ny) :: f + f = spread(2 * cshift((/ 1, 2 /), nx/2), 2, ny) +end + diff --git a/Fortran/gfortran/regression/array_simplify_2.f90 b/Fortran/gfortran/regression/array_simplify_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_simplify_2.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! PR 85102 - this used to ICE +! Original test case by Gerhard Steinmetz +program p + integer, parameter :: a((1+2)) = 1 + integer, parameter :: b((1+1)+1) = 1 + integer, parameter :: c = dot_product(a, a) + integer, parameter :: d = dot_product(b,b) + if (c /= 3) stop 1 + if (d /= 3) stop 2 + end program p diff --git a/Fortran/gfortran/regression/array_simplify_3.f90 b/Fortran/gfortran/regression/array_simplify_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_simplify_3.f90 @@ -0,0 +1,9 @@ +! { dg-do run } +! PR 71203 - this used to ICE +program p + integer :: i + integer, parameter :: x(2) = 0 + integer, parameter :: y(*) = [(x(i:i), i=1,2)] + if (size(y,1) /= 2) stop 1 + if (any(y /= 0)) stop 2 +end diff --git a/Fortran/gfortran/regression/array_simplify_4.f90 b/Fortran/gfortran/regression/array_simplify_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_simplify_4.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR fortran/92996 +! +! Contributed by G. Steinmetz +! + +module m + integer, parameter :: d(2) = [0,0] +end module m + +subroutine one +use m +print size([1,2],dim=d(1)) ! { dg-error "'dim' argument of 'size' intrinsic at .1. is not a valid dimension index" } +end + +subroutine two +complex, parameter :: x = 1 + +stop x ! { dg-error "STOP code at .1. must be either INTEGER or CHARACTER type" } +end + +program p + integer, parameter :: a(2) = [1, 2] + stop a(1) ! OK + stop a ! { dg-error "STOP code at .1. must be scalar" } + stop a(1,1) ! { dg-error "Rank mismatch in array reference at .1. .2/1." } +end diff --git a/Fortran/gfortran/regression/array_temporaries_1.f90 b/Fortran/gfortran/regression/array_temporaries_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_temporaries_1.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-Warray-temporaries" } + +subroutine bar(a) + real, dimension(2) :: a +end + +program main + integer, parameter :: n=3 + integer :: i + real, dimension(n) :: a, b + + a = 0.2 + i = 2 + a(i:i+1) = a(1:2) ! { dg-warning "Creating array temporary" } + a = cshift(a,1) ! { dg-warning "Creating array temporary" } + b = cshift(a,1) + call bar(a(1:3:2)) ! { dg-warning "Creating array temporary" } +end program main diff --git a/Fortran/gfortran/regression/array_temporaries_2.f90 b/Fortran/gfortran/regression/array_temporaries_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_temporaries_2.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-fcheck-array-temporaries" } + program test + implicit none + integer :: a(3,3) + call foo(a(:,1)) ! OK, no temporary created + call foo(a(1,:)) ! BAD, temporary var created +contains + subroutine foo(x) + integer :: x(3) + x = 5 + end subroutine foo +end program test + +! { dg-output "At line 7 of file .*array_temporaries_2.f90(\r*\n+)Fortran runtime warning: An array temporary was created for argument 'x' of procedure 'foo'" } diff --git a/Fortran/gfortran/regression/array_temporaries_3.f90 b/Fortran/gfortran/regression/array_temporaries_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_temporaries_3.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! PR38119 - The scalarizer got the loop size wrong +! for the temporary coming from the call to 'same'. +! +! Contributed by Mikael Morin +! based on a program by Vivek Rao. +! +module bar + implicit none + character(len = 2) :: c(1) +contains + elemental function trim_append (xx,yy) result(xy) + character (len = *), intent(in) :: xx,yy + character (len = len (xx) + len (yy)) :: xy + xy = trim (xx) // trim (yy) + end function trim_append + function same(xx) result(yy) + character (len = *), intent(in) :: xx(:) + character (len = len (xx)) :: yy(size (xx)) + yy = xx + end function same + subroutine xmain() + c = trim_append(["a"],same(["b"])) ! The problem occurred here + end subroutine xmain +end module bar + use bar + call xmain + if (c(1) .ne. "ab") STOP 1 +end diff --git a/Fortran/gfortran/regression/array_temporaries_4.f90 b/Fortran/gfortran/regression/array_temporaries_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_temporaries_4.f90 @@ -0,0 +1,59 @@ +! { dg-do compile } +! { dg-options "-Warray-temporaries" } +! Tests the fix for PR80164, in which the compiler segfaulted on this +! when using -Warray-temporaries +! +!****************************************************************************** +module global + type :: a + integer :: b + character(8):: c + end type a + interface assignment(=) + module procedure a_to_a, c_to_a, a_to_c + end interface + interface operator(.ne.) + module procedure a_ne_a + end interface + + type(a) :: x(4), y(4) + logical :: l1(4), t = .true., f= .false. +contains +!****************************************************************************** + elemental subroutine a_to_a (m, n) + type(a), intent(in) :: n + type(a), intent(out) :: m + m%b = len ( trim(n%c)) + m%c = n%c + end subroutine a_to_a + elemental subroutine c_to_a (m, n) + character(8), intent(in) :: n + type(a), intent(out) :: m + m%b = m%b + 1 + m%c = n + end subroutine c_to_a + elemental subroutine a_to_c (m, n) + type(a), intent(in) :: n + character(8), intent(out) :: m + m = n%c + end subroutine a_to_c +!****************************************************************************** + elemental logical function a_ne_a (m, n) + type(a), intent(in) :: n + type(a), intent(in) :: m + a_ne_a = (m%b .ne. n%b) .or. (m%c .ne. n%c) + end function a_ne_a +!****************************************************************************** + elemental function foo (m) + type(a) :: foo + type(a), intent(in) :: m + foo%b = 0 + foo%c = m%c + end function foo +end module global +!****************************************************************************** +program test + use global + x = (/a (0, "one"),a (0, "two"),a (0, "three"),a (0, "four")/) ! { dg-warning "Creating array temporary" } + y = x +end program test diff --git a/Fortran/gfortran/regression/array_temporaries_5.f90 b/Fortran/gfortran/regression/array_temporaries_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/array_temporaries_5.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! { dg-options "-fcheck-array-temporaries -fno-check-array-temporaries" } +! +! PR fortran/87919 +! +! Ensure -fno-check-array-temporaries disables array temporary checking. +! + +! Note that 'include' drops the dg-output check from the original test case. +include 'array_temporaries_2.f90' diff --git a/Fortran/gfortran/regression/arrayio_0.f90 b/Fortran/gfortran/regression/arrayio_0.f90 --- /dev/null +++ b/Fortran/gfortran/regression/arrayio_0.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! Tests fix for PR20840 - would ICE with vector subscript in +! internal unit. +! +! Contributed by Paul Thomas +! + character(len=12), dimension(4) :: iu, buff + character(len=48), dimension(2) :: iue + equivalence (iu, iue) + integer, dimension(4) :: v = (/2,1,4,3/) + iu = (/"Vector ","subscripts","not ","allowed! "/) + read (iu, '(a12/)') buff + read (iue(1), '(4a12)') buff + read (iu(4:1:-1), '(a12/)') buff + read (iu(v), '(a12/)') buff ! { dg-error "with vector subscript" } + read (iu((/2,4,3,1/)), '(a12/)') buff ! { dg-error "with vector subscript" } + print *, buff + end + diff --git a/Fortran/gfortran/regression/arrayio_1.f90 b/Fortran/gfortran/regression/arrayio_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/arrayio_1.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! PR 21875 : Test formatted input/output to/from character arrays. +! Contributed by Jerry DeLisle . + program arrayio_1 + implicit none + integer :: i(6),j,k + character(12) :: r(12,2) = '0123456789AB' + +! Write to and read from a whole character array + + i = (/(j,j=1,6)/) + write(r,'(3(2x,i4/)/3(3x,i6/))') i + i = 0 + read(r,'(3(2x,i4/)/3(3x,i6/))') i + if (any(i.ne.(/(j,j=1,6)/))) STOP 1 + do j=1,12 + do k=1,2 + if ((j.gt.8.and.k.eq.1).or.(k.eq.2)) then + if (r(j,k).ne.'0123456789AB') STOP 2 + end if + end do + end do + + ! Write to a portion of a character array + r = '0123456789AB' + write(r(3:9,1),'(6(i12/))') i + if (r(2,1).ne.'0123456789AB') STOP 3 + do j=3,8 + if (iachar(trim(adjustl(r(j,1))))-46.ne.j) STOP 4 + end do + if (r(9,1).ne.' ') STOP 5 + end program arrayio_1 diff --git a/Fortran/gfortran/regression/arrayio_10.f90 b/Fortran/gfortran/regression/arrayio_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/arrayio_10.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! PR29563 Internal read loses data. +! Test case submitted by Jerry DeLisle +! Without patch, values get muddled. +program pr29563 + character(len=4), dimension(3)::arraydata = (/'1123',' 456','789 '/) + real(kind=8), dimension(3) :: tmp + read(arraydata,*,iostat=iostat)tmp + if (tmp(1).ne.1123.0) STOP 1 + if (tmp(2).ne.456.0) STOP 2 + if (tmp(3).ne.789.0) STOP 3 +end program pr29563 \ No newline at end of file diff --git a/Fortran/gfortran/regression/arrayio_11.f90 b/Fortran/gfortran/regression/arrayio_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/arrayio_11.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! Tests the fix for PR30284, in which the substring plus +! component reference for an internal file would cause an ICE. +! +! Contributed by Harald Anlauf + +program gfcbug51 + implicit none + + type :: date_t + character(len=12) :: date ! yyyymmddhhmm + end type date_t + + type year_t + integer :: year = 0 + end type year_t + + type(date_t) :: file(3) + type(year_t) :: time(3) + + FILE%date = (/'200612231200', '200712231200', & + '200812231200'/) + + call date_to_year (FILE) + if (any (time%year .ne. (/2006, 2007, 2008/))) STOP 1 + + call month_to_date ((/8, 9, 10/), FILE) + if ( any (file%date .ne. (/'200608231200', '200709231200', & + '200810231200'/))) STOP 2 + +contains + + subroutine date_to_year (d) + type(date_t) :: d(3) + read (d%date(1:4),'(i4)') time%year + end subroutine + + subroutine month_to_date (m, d) + type(date_t) :: d(3) + integer :: m(:) + write (d%date(5:6),'(i2.2)') m + end subroutine month_to_date + +end program gfcbug51 diff --git a/Fortran/gfortran/regression/arrayio_12.f90 b/Fortran/gfortran/regression/arrayio_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/arrayio_12.f90 @@ -0,0 +1,41 @@ +! { dg-do run } +! Tests the fix for PR30626, in which the substring reference +! for an internal file would cause an ICE. +! +! Contributed by Francois-Xavier Coudert + +program gfcbug51 + implicit none + + character(len=12) :: cdate(3) ! yyyymmddhhmm + + type year_t + integer :: year = 0 + end type year_t + + type(year_t) :: time(3) + + cdate = (/'200612231200', '200712231200', & + '200812231200'/) + + call date_to_year (cdate) + if (any (time%year .ne. (/2006, 2007, 2008/))) STOP 1 + + call month_to_date ((/8, 9, 10/), cdate) + if ( any (cdate .ne. (/'200608231200', '200709231200', & + '200810231200'/))) STOP 2 + +contains + + subroutine date_to_year (d) + character(len=12) :: d(3) + read (cdate(:)(1:4),'(i4)') time%year + end subroutine + + subroutine month_to_date (m, d) + character(len=12) :: d(3) + integer :: m(:) + write (cdate(:)(5:6),'(i2.2)') m + end subroutine month_to_date + +end program gfcbug51 diff --git a/Fortran/gfortran/regression/arrayio_13.f90 b/Fortran/gfortran/regression/arrayio_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/arrayio_13.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! PR60810 Bogus end-of-file +program readstrlist + character(len=80), dimension(2) :: ver + integer :: a, b, c + a = 1 + b = 2 + c = 3 + ver(1) = '285 383' + ver(2) = '985' + read( ver, *) a, b, c + if (a /= 285 .or. b /= 383 .or. c /= 985) STOP 1 + !write ( *, *) a, b, c +end diff --git a/Fortran/gfortran/regression/arrayio_14.f90 b/Fortran/gfortran/regression/arrayio_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/arrayio_14.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! PR61173.f90 Bogus END condition +module bd + character(len=25, kind=1), dimension(:), allocatable, save :: source + contains + subroutine init_data + allocate(source(2)) + source=[" 1 1 1 ", " 4 4 4 "] + end subroutine init_data +end module bd +program read_internal + use bd + integer :: x(6),i + + call init_data + read(source,*) (x(i), i=1,6) + if (any(x/=[1,1,1,4,4,4])) STOP 1 +end program read_internal diff --git a/Fortran/gfortran/regression/arrayio_15.f90 b/Fortran/gfortran/regression/arrayio_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/arrayio_15.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! PR61499 +program read_internal + + integer :: x(9),i,iostat + character(len=512) :: iomsg + character(kind=1,len=30), dimension(:), allocatable, save :: source + allocate(source(3)) + source=[" 1 1 -1"," 1 -1 1"," -1 1 1"] !This fails + read(source,*) (x(i), i=1,6) +end program read_internal diff --git a/Fortran/gfortran/regression/arrayio_16.f90 b/Fortran/gfortran/regression/arrayio_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/arrayio_16.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! PR61640 KIND=4 Character Array Internal Unit Read Fail +program read_internal + integer :: x(9),i + integer :: y(9) + character(kind=4,len=30), dimension(3) :: source + + y = reshape ((/ 1,1,-1,1,-1,1,-1,1,1 /), shape(x)) + source=[4_" 1 1 -1",4_" 1 -1 1",4_" -1 1 1"] + !print *, (trim(source(i)), i=1,3) + read(source,*) (x(i), i=1,9) ! This read fails for KIND=4 character + if (any(x /= y )) STOP 1 +end program read_internal diff --git a/Fortran/gfortran/regression/arrayio_2.f90 b/Fortran/gfortran/regression/arrayio_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/arrayio_2.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! PR 21875 : Test formatted input/output to/from character arrays. +! This test ckecks proper positioning and padding with trailing blanks +! after write operations. Contributed by Paul Thomas. + program arrayio_2 + implicit none + integer :: i=2 + character(len=12), dimension(4,2) :: r = "0123456789ab" + character(len=80) :: f + + f = '("hello"/"world")' + + write(r(1:4,i-1), f) + + f = '("hello",t1,"HELLO",1x,"!"/"world",tl12,"WORLD")' + + write(r((i-1):(i+1),i), f) + + if ( r(1,1).ne.'hello ' .or. & + r(2,1).ne.'world ' .or. & + r(3,1).ne.'0123456789ab' .or. & + r(4,1).ne.'0123456789ab' .or. & + r(1,2).ne.'HELLO ! ' .or. & + r(2,2).ne.'WORLD ' .or. & + r(3,2).ne.'0123456789ab' .or. & + r(4,2).ne.'0123456789ab') STOP 1 + + end program arrayio_2 diff --git a/Fortran/gfortran/regression/arrayio_3.f90 b/Fortran/gfortran/regression/arrayio_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/arrayio_3.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! PR 21875 : Test formatted input/output to/from character arrays. +! This test deliberately exceeds the record length in a write and verifies +! the error message. Contributed by Jerry DeLisle . + program arrayio_3 + implicit none + integer :: i(6),j,ierr + character(12) :: r(4,2) = '0123456789AB' + +! Write using a format string that defines a record greater than +! the length of an element in the character array. + + i = (/(j,j=1,6)/) + write(r,'(3(2x,i4/)/3(4x,i9/))', iostat=ierr) i + if (ierr.ne.-2) STOP 1 + end program arrayio_3 diff --git a/Fortran/gfortran/regression/arrayio_4.f90 b/Fortran/gfortran/regression/arrayio_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/arrayio_4.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! PR 24244 : Test formatted input/output to/from character arrays. +! This test checks array I/O with strides other than 1. +! Contributed by Jerry DeLisle . +program arrayio_4 + implicit none + integer :: ierr + character(12) :: r(2,3,4) = '0123456789AB' + + write(r(::2,:,::1),'(i5)', iostat=ierr) 1,2,3,4,5 + if (ierr.ne.0) STOP 1 + + write(r(:,:,::2),'(i5)', iostat=ierr) 1,2,3,4,5 + if (ierr.ne.0) STOP 2 + + write(r(::1,::2,::1),'(i5)', iostat=ierr) 1,2,3,4,5 + if (ierr.ne.0) STOP 3 + + write(r(::1,::1,::1),'(i5)', iostat=ierr) 1,2,3,4,5 + if (ierr.ne.0) STOP 4 +end program arrayio_4 + diff --git a/Fortran/gfortran/regression/arrayio_5.f90 b/Fortran/gfortran/regression/arrayio_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/arrayio_5.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! PR 21875 : Test formatted input/output to/from character arrays. +! This test checks the error checking for end of file condition. +! Contributed by Jerry DeLisle . +program arrayio_5 + implicit none + integer :: i,ierr + character(12) :: r(10) = '0123456789AB' + + write(r,'(i12)',iostat=ierr) 1,2,3,4,5,6,7,8,9,10,11 + if (ierr.ne.-1) STOP 1 + end program arrayio_5 + diff --git a/Fortran/gfortran/regression/arrayio_6.f90 b/Fortran/gfortran/regression/arrayio_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/arrayio_6.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! PR24224 Test formatted input/output to/from character arrays with strides +! other than 1. Contributed by Jerry DeLisle . + program arrayio_6 + implicit none + integer :: i(3),j,k(3) + character(12) :: r(4,4,4) = '0123456789AB' + character(12) :: s(64) + equivalence(r,s) + + i = (/(j,j=1,3)/) + write(r(1:4:2,2:4:1,3:4:2),'(3(2x,i4/)/3(3x,i6/))') i + + if (s(36).ne.'0123456789AB') STOP 1 + if (s(37).ne.' 1 ') STOP 2 + if (s(38).ne.'0123456789AB') STOP 3 + if (s(39).ne.' 2 ') STOP 4 + if (s(40).ne.'0123456789AB') STOP 5 + if (s(41).ne.' 3 ') STOP 6 + if (s(42).ne.'0123456789AB') STOP 7 + if (s(43).ne.' ') STOP 8 + if (s(44).ne.'0123456789AB') STOP 9 + if (s(45).ne.' ') STOP 10 + if (s(46).ne.'0123456789AB') STOP 11 + + k = i + i = 0 + read(r(1:4:2,2:4:1,3:4:2),'(3(2x,i4/)/3(3x,i6/))') i + if (any(i.ne.k)) STOP 12 + + end program arrayio_6 diff --git a/Fortran/gfortran/regression/arrayio_7.f90 b/Fortran/gfortran/regression/arrayio_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/arrayio_7.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR24224 Test formatted input/output to/from character arrays with strides +! other than 1. Test that reading stops at the end of the current record. +! Contributed by Jerry DeLisle . +program arrayio_7 + character*4, dimension(8) :: abuf = (/"0123","4567","89AB","CDEF", & + "0123","4567","89AB","CDEF"/) + character*4, dimension(2,4) :: buf + character*8 :: a + equivalence (buf,abuf) + read(buf(2, 1:3:2), '(a8)') a + if (a.ne."4567") STOP 1 +end program arrayio_7 diff --git a/Fortran/gfortran/regression/arrayio_8.f90 b/Fortran/gfortran/regression/arrayio_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/arrayio_8.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR28339, This test checks that internal unit array I/O handles a full record +! and advances to the next record properly. Test case derived from PR +! Submitted by Jerry DeLisle + program main + integer i + character*8 rec(3) + rec = "" + write (rec,fmt=99999) + if (rec(1).ne.'12345678') STOP 1 + if (rec(2).ne.'record2') STOP 2 + if (rec(3).ne.'record3') STOP 3 +99999 format ('12345678',/'record2',/'record3') + end + diff --git a/Fortran/gfortran/regression/arrayio_9.f90 b/Fortran/gfortran/regression/arrayio_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/arrayio_9.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! PR29563 Internal read loses data. +! Test from test case. Submitted by Jerry DeLisle +! Without patch, last value in array was being skipped in the read. +program pr29563 + character(len=10), dimension(3)::arraydata = (/' 1 2 3',' 4 5 6',' 7 8 9'/) + real(kind=8), dimension(3,3) :: tmp + tmp = 0.0 + read(arraydata,*,iostat=iostat)((tmp(i,j),j=1,3),i=1,3) + if (tmp(3,3)-9.0.gt.0.0000001) STOP 1 +end program pr29563 \ No newline at end of file diff --git a/Fortran/gfortran/regression/arrayio_derived_1.f90 b/Fortran/gfortran/regression/arrayio_derived_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/arrayio_derived_1.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! PR 24862: IO for arrays of derived type handled incorrectly. +program arrayio_derived_1 + implicit none + type tp + integer :: i + character(len=1) :: c + end type tp + type(tp) :: x(5) + character(len=500) :: a + integer :: i, b(5) + + x%i = 256 + x%c = "q" + + write(a, *) x%i + read(a, *) b + do i = 1, 5 + if (b(i) /= 256) then + STOP 1 + end if + end do + write(a, *) x ! Just test that the library doesn't abort. + write(a, *) x(:)%i + b = 0 + read(a, *) b + do i = 1, 5 + if (b(i) /= 256) then + STOP 2 + end if + end do + +end program arrayio_derived_1 diff --git a/Fortran/gfortran/regression/arrayio_derived_2.f90 b/Fortran/gfortran/regression/arrayio_derived_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/arrayio_derived_2.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! PR 24266: IO to/from arrays that are components of derived types. +program main + implicit none + + type ice + character(len=80) :: mess(3) + end type ice + type(ice) :: tp + integer :: i + character(len=80) :: mess + + write(tp%mess,*) "message" + read(tp%mess,*) mess + print *, mess + +end program main diff --git a/Fortran/gfortran/regression/assign-debug.f90 b/Fortran/gfortran/regression/assign-debug.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assign-debug.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "-fcompare-debug -O2" } + program test + integer i + common i + assign 2000 to i ! { dg-warning "Deleted feature: ASSIGN statement" } +2000 continue + end diff --git a/Fortran/gfortran/regression/assign.f90 b/Fortran/gfortran/regression/assign.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assign.f90 @@ -0,0 +1,8 @@ +! { dg-do run } +! Program to test ASSIGNing a label to common variable. PR18827. + program test + integer i + common i + assign 2000 to i ! { dg-warning "Deleted feature: ASSIGN statement" } +2000 continue + end diff --git a/Fortran/gfortran/regression/assign_1.f90 b/Fortran/gfortran/regression/assign_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assign_1.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! Option passed to avoid excess errors from obsolete warning +! { dg-options "-w" } + integer i(5) + assign 1000 to i ! { dg-error "scalar default INTEGER" } + 1000 continue + end diff --git a/Fortran/gfortran/regression/assign_10.f90 b/Fortran/gfortran/regression/assign_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assign_10.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! { dg-options "-O3 -fdump-tree-original" } +! Tests the fix for PR33850, in which one of the two assignments +! below would produce an unnecessary temporary for the index +! expression, following the fix for PR33749. +! +! Contributed by Dick Hendrickson on comp.lang.fortran, +! " Most elegant syntax for inverting a permutation?" 20071006 +! + integer(4) :: p4(4) = (/2,4,1,3/) + integer(4) :: q4(4) = (/2,4,1,3/) + integer(8) :: p8(4) = (/2,4,1,3/) + integer(8) :: q8(4) = (/2,4,1,3/) + p4(q4) = (/(i, i = 1, 4)/) + q4(q4) = (/(i, i = 1, 4)/) + p8(q8) = (/(i, i = 1, 4)/) + q8(q8) = (/(i, i = 1, 4)/) + if (any(p4 .ne. q4)) STOP 1 + if (any(p8 .ne. q8)) STOP 2 +end +! Whichever is the default length for array indices will yield +! parm 18 times, because a temporary is not necessary. The other +! cases will all yield a temporary, so that atmp appears 18 times. +! Note that it is the kind conversion that generates the temp. +! +! { dg-final { scan-tree-dump-times "parm" 20 "original" } } +! { dg-final { scan-tree-dump-times "atmp" 20 "original" } } diff --git a/Fortran/gfortran/regression/assign_11.f90 b/Fortran/gfortran/regression/assign_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assign_11.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR 70260 - this used to ICE +! Original test case by Gernard Steinmetz +subroutine s (f) + integer, external :: f, g + integer :: h + g = f(2) ! { dg-error "Illegal assignment to external procedure" } + h = g(2) +end diff --git a/Fortran/gfortran/regression/assign_2.f90 b/Fortran/gfortran/regression/assign_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assign_2.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! Option passed to avoid excess errors from obsolete warning +! { dg-options "-w" } +! PR18827 + integer i,j + common /foo/ i,j + assign 1000 to j + j = 5 + goto j + 1000 continue + end diff --git a/Fortran/gfortran/regression/assign_3.f90 b/Fortran/gfortran/regression/assign_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assign_3.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! Option passed to avoid excess errors from obsolete warning +! { dg-options "-w" } +! PR18827 + integer i,j + equivalence (i,j) + assign 1000 to i + write (*, j) ! { dg-error "not been assigned a format label" } + goto j ! { dg-error "not been assigned a target label" } + 1000 continue + end diff --git a/Fortran/gfortran/regression/assign_4.f b/Fortran/gfortran/regression/assign_4.f --- /dev/null +++ b/Fortran/gfortran/regression/assign_4.f @@ -0,0 +1,11 @@ +! { dg-do compile } +! Option passed to avoid excess errors from obsolete warning +! { dg-options "-w" } +! PR17423 + program testit +c + assign 12 to i + write(*, i) + 0012 format (" **** ASSIGN FORMAT NUMBER TO INTEGER VARIABLE ****" ) + end + diff --git a/Fortran/gfortran/regression/assign_5.f90 b/Fortran/gfortran/regression/assign_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assign_5.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! Assign a label to a dummy argument. +! Option passed to avoid excess errors from obsolete warning +! { dg-options "-w" } + +subroutine s1 (a) +integer a +assign 777 to a +go to a +777 continue +end +program test +call s1 (1) +end + diff --git a/Fortran/gfortran/regression/assign_6.f b/Fortran/gfortran/regression/assign_6.f --- /dev/null +++ b/Fortran/gfortran/regression/assign_6.f @@ -0,0 +1,10 @@ +C { dg-do run } +C Option passed to avoid excess errors from obsolete warning +C { dg-options "-w" } +C PR22290 + + integer nz + assign 93 to nz + go to nz,(93) + 93 continue + end diff --git a/Fortran/gfortran/regression/assign_7.f b/Fortran/gfortran/regression/assign_7.f --- /dev/null +++ b/Fortran/gfortran/regression/assign_7.f @@ -0,0 +1,16 @@ +C { dg-do compile } +C Option passed to avoid excess errors from obsolete warning +C { dg-options "-w" } + + PROGRAM FM013 + IF (ICZERO) 31270, 1270, 31270 + 1270 CONTINUE + 1272 ASSIGN 1273 TO J + 1273 ASSIGN 1274 TO J + 1274 ASSIGN 1275 TO J + GOTO 1276 + 1275 continue + 1276 GOTO J, ( 1272, 1273, 1274, 1275 ) +31270 IVDELE = IVDELE + 1 + END + diff --git a/Fortran/gfortran/regression/assign_8.f90 b/Fortran/gfortran/regression/assign_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assign_8.f90 @@ -0,0 +1,4 @@ +! { dg-do compile } +! PR fortran/20883 + write (*, a) b ! { dg-error "must be of type default-kind CHARACTER or of INTEGER" } + end diff --git a/Fortran/gfortran/regression/assign_9.f90 b/Fortran/gfortran/regression/assign_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assign_9.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! Tests the fix for PR33749, in which one of the two assignments +! below would not produce a temporary for the index expression. +! +! Contributed by Dick Hendrickson on comp.lang.fortran, +! " Most elegant syntax for inverting a permutation?" 20071006 +! + integer(4) :: p(4) = (/2,4,1,3/) + integer(8) :: q(4) = (/2,4,1,3/) + p(p) = (/(i, i = 1, 4)/) + q(q) = (/(i, i = 1, 4)/) + if (any(p .ne. q)) STOP 1 +end + diff --git a/Fortran/gfortran/regression/assign_func_dtcomp_1.f90 b/Fortran/gfortran/regression/assign_func_dtcomp_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assign_func_dtcomp_1.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! { dg-options "-O0" } +! +! Test fix for PR18022. +! +! Contributed by Paul Thomas +! +program assign_func_dtcomp + implicit none + type :: mytype + real :: x + real :: y + end type mytype + type (mytype), dimension (4) :: z + + type :: thytype + real :: x(4) + end type thytype + type (thytype) :: w + real, dimension (4) :: a = (/1.,2.,3.,4./) + real, dimension (4) :: b = (/5.,6.,7.,8./) + + +! Test the original problem is fixed. + z(:)%x = foo (a) + z(:)%y = foo (b) + + + if (any(z%x.ne.a).or.any(z%y.ne.b)) STOP 1 + +! Make sure we did not break anything on the way. + w%x(:) = foo (b) + a = foo (b) + + if (any(w%x.ne.b).or.any(a.ne.b)) STOP 2 + +contains + + function foo (v) result (ans) + real, dimension (:), intent(in) :: v + real, dimension (size(v)) :: ans + ans = v + end function foo + + +end program assign_func_dtcomp + diff --git a/Fortran/gfortran/regression/assignment_1.f90 b/Fortran/gfortran/regression/assignment_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assignment_1.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! { dg-options -Wsurprising } +integer, pointer :: p +integer, target :: t, s + +! The tests for character pointers are currently commented out, +! because they don't yet work correctly. +! This is PR 17192 +!!$character*5, pointer :: d +!!$character*5, target :: c, e + +t = 1 +p => s +! We didn't dereference the pointer in the following line. +p = f() ! { dg-warning "POINTER-valued function" } +p = p+1 +if (p.ne.2) STOP 1 +if (p.ne.s) STOP 2 + +!!$! verify that we also dereference correctly the result of a function +!!$! which returns its result by reference +!!$c = "Hallo" +!!$d => e +!!$d = g() ! dg-warning "POINTER valued function" "" +!!$if (d.ne."Hallo") STOP 3 + +contains +function f() +integer, pointer :: f +f => t +end function f +!!$function g() +!!$character, pointer :: g +!!$g => c +!!$end function g +end diff --git a/Fortran/gfortran/regression/assignment_2.f90 b/Fortran/gfortran/regression/assignment_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assignment_2.f90 @@ -0,0 +1,48 @@ +! { dg-do compile } +! +! PR fortran/35033 +! +! The checks for assignments were too strict. +! +MODULE m1 + INTERFACE ASSIGNMENT(=) + SUBROUTINE s(a,b) + REAL,INTENT(OUT) :: a(1,*) + REAL,INTENT(IN) :: b(:) + END SUBROUTINE + END Interface +contains + subroutine test1() + REAL,POINTER :: p(:,:),q(:) + CALL s(p,q) + p = q + end subroutine test1 +end module m1 + +MODULE m2 + INTERFACE ASSIGNMENT(=) + SUBROUTINE s(a,b) + REAL,INTENT(OUT),VOLATILE :: a(1,*) + REAL,INTENT(IN) :: b(:) + END SUBROUTINE + END Interface +contains + subroutine test1() + REAL,POINTER :: p(:,:),q(:) + CALL s(p,q) ! { dg-error "requires an assumed-shape or pointer-array dummy" } +!TODO: The following is rightly rejected but the error message is misleading. +! The actual reason is the mismatch between pointer array and VOLATILE + p = q ! { dg-error "Incompatible ranks" } + end subroutine test1 +end module m2 + +MODULE m3 + INTERFACE ASSIGNMENT(=) + module procedure s + END Interface +contains + SUBROUTINE s(a,b) ! { dg-error "must not redefine an INTRINSIC type" } + REAL,INTENT(OUT),VOLATILE :: a(1,*) + REAL,INTENT(IN) :: b(:,:) + END SUBROUTINE +end module m3 diff --git a/Fortran/gfortran/regression/assignment_3.f90 b/Fortran/gfortran/regression/assignment_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assignment_3.f90 @@ -0,0 +1,61 @@ +! { dg-do compile } +! PR fortran/36316 +! +! gfortran generated a mismatching tree ("type mismatch in binary expression") +! for array bounds (mixing integer kind=4/kind=8 without fold_convert). +! +MODULE YOMCAIN + +IMPLICIT NONE +SAVE + +TYPE distributed_vector +REAL, pointer :: local(:) +INTEGER(4) :: global_length,local_start +INTEGER(8) :: local_end +END TYPE distributed_vector + +INTERFACE ASSIGNMENT (=) +MODULE PROCEDURE assign_ar_dv +END INTERFACE + +INTERFACE OPERATOR (*) +MODULE PROCEDURE multiply_dv_dv +END INTERFACE + +CONTAINS + +SUBROUTINE assign_ar_dv (handle,pvec) + +! copy array to the distributed_vector + +REAL, INTENT(IN) :: pvec(:) +TYPE (distributed_vector), INTENT(INOUT) :: handle + +handle%local(:) = pvec(:) + +RETURN +END SUBROUTINE assign_ar_dv + +FUNCTION multiply_dv_dv (handle1,handle2) + +! multiply two distributed_vectors + +TYPE (distributed_vector), INTENT(IN) :: handle2 +TYPE (distributed_vector), INTENT(IN) :: handle1 +REAL :: multiply_dv_dv(handle1%local_start:handle1%local_end) + +multiply_dv_dv = handle1%local(:) * handle2%local(:) + +RETURN +END FUNCTION multiply_dv_dv + + +SUBROUTINE CAININAD_SCALE_DISTVEC () +TYPE (distributed_vector) :: PVAZG +TYPE (distributed_vector) :: ZTEMP +TYPE (distributed_vector) :: SCALP_DV + +ZTEMP = PVAZG * SCALP_DV +END SUBROUTINE CAININAD_SCALE_DISTVEC +END MODULE YOMCAIN diff --git a/Fortran/gfortran/regression/assignment_4.f90 b/Fortran/gfortran/regression/assignment_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assignment_4.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-Wall" } +! +! PR 55855: [OOP] incorrect warning with procedure pointer component on pointer-valued base object +! +! Contributed by Andrew Benson + + implicit none + type :: event + procedure(logical), pointer, nopass :: task + end type event + logical :: r + type(event), pointer :: myEvent + allocate(myEvent) + r=myEvent%task() ! { dg-warning "uninitialized" } +end diff --git a/Fortran/gfortran/regression/associate_1.f03 b/Fortran/gfortran/regression/associate_1.f03 --- /dev/null +++ b/Fortran/gfortran/regression/associate_1.f03 @@ -0,0 +1,111 @@ +! { dg-do run } +! { dg-options "-std=f2003 -cpp" } + +! PR fortran/38936 +! Check the basic semantics of the ASSOCIATE construct. + +PROGRAM main + IMPLICIT NONE + REAL :: a, b, c + INTEGER, ALLOCATABLE :: arr(:) + INTEGER :: mat(3, 3) + + TYPE :: myt + INTEGER :: comp + END TYPE myt + + TYPE(myt) :: tp + + a = -2.0 + b = 3.0 + c = 4.0 + + ! Simple association to expressions. + ASSOCIATE (r => SQRT (a**2 + b**2 + c**2), t => a + b) + PRINT *, t, a, b + IF (ABS (r - SQRT (4.0 + 9.0 + 16.0)) > 1.0e-3) STOP 1 + IF (ABS (t - a - b) > 1.0e-3) STOP 2 + END ASSOCIATE + + ! Test association to arrays. + ALLOCATE (arr(3)) + arr = (/ 1, 2, 3 /) + ASSOCIATE (doubled => 2 * arr, xyz => func ()) + IF (SIZE (doubled) /= SIZE (arr)) STOP 3 + IF (doubled(1) /= 2 .OR. doubled(2) /= 4 .OR. doubled(3) /= 6) & + STOP 4 + + IF (ANY (xyz /= (/ 1, 3, 5 /))) STOP 5 + END ASSOCIATE + + ! Target is vector-indexed. + ASSOCIATE (foo => arr((/ 3, 1 /))) + IF (LBOUND (foo, 1) /= 1 .OR. UBOUND (foo, 1) /= 2) STOP 6 + IF (foo(1) /= 3 .OR. foo(2) /= 1) STOP 7 + END ASSOCIATE + + ! Named and nested associate. + myname: ASSOCIATE (x => a - b * c) + ASSOCIATE (y => 2.0 * x) + IF (ABS (y - 2.0 * (a - b * c)) > 1.0e-3) STOP 8 + END ASSOCIATE + END ASSOCIATE myname ! Matching end-label. + + ! Correct behavior when shadowing already existing names. + ASSOCIATE (a => 1 * b, b => 1 * a, x => 1, y => 2) + IF (ABS (a - 3.0) > 1.0e-3 .OR. ABS (b + 2.0) > 1.0e-3) STOP 9 + ASSOCIATE (x => 1 * y, y => 1 * x) + IF (x /= 2 .OR. y /= 1) STOP 10 + END ASSOCIATE + END ASSOCIATE + + ! Association to variables. + mat = 0 + mat(2, 2) = 5; + ASSOCIATE (x => arr(2), y => mat(2:3, 1:2)) + IF (x /= 2) STOP 11 + IF (ANY (LBOUND (y) /= (/ 1, 1 /) .OR. UBOUND (y) /= (/ 2, 2 /))) & + STOP 12 + IF (y(1, 2) /= 5) STOP 13 + + x = 7 + y = 8 + END ASSOCIATE + IF (arr(2) /= 7 .OR. ANY (mat(2:3, 1:2) /= 8)) STOP 14 + + ! Association to derived type and component. + tp = myt (1) + ASSOCIATE (x => tp, y => tp%comp) + IF (x%comp /= 1) STOP 15 + IF (y /= 1) STOP 16 + y = 5 + IF (x%comp /= 5) STOP 17 + END ASSOCIATE + IF (tp%comp /= 5) STOP 18 + + ! Association to character variables. + CALL test_char (5) + +CONTAINS + + FUNCTION func () + INTEGER :: func(3) + func = (/ 1, 3, 5 /) + END FUNCTION func + + ! Test association to character variable with automatic length. + SUBROUTINE test_char (n) + INTEGER, INTENT(IN) :: n + + CHARACTER(LEN=n) :: str + + str = "foobar" + ASSOCIATE (my => str) + IF (LEN (my) /= n) STOP 19 + IF (my /= "fooba") STOP 20 + my = "abcdef" + END ASSOCIATE + IF (str /= "abcde") STOP 21 + END SUBROUTINE test_char + +END PROGRAM main diff --git a/Fortran/gfortran/regression/associate_10.f90 b/Fortran/gfortran/regression/associate_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_10.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! PR fortran/51383 +! +! Contributed by kaiserkarl31@yahoo.com +! +! Was failing before at the ref resolution of y1(1)%i. +! +program extend + type :: a + integer :: i + end type a + type, extends (a) :: b + integer :: j + end type b + type (a) :: x(2) + type (b) :: y(2) + associate (x1 => x, y1 => y) + x1(1)%i = 1 + ! Commenting out the following line will avoid the error + y1(1)%i = 2 + end associate +end program extend diff --git a/Fortran/gfortran/regression/associate_11.f90 b/Fortran/gfortran/regression/associate_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_11.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/55134 +! +! Contributed by Valery Weber +! +program bug + implicit none + integer,dimension(1)::i + i(:)=1 + associate(a =>i) + call foo(a) + end associate +! write(*,*) i + if (i(1) /= 2) STOP 1 +contains + subroutine foo(v) + integer, dimension(*) :: v + v(1)=2 + end subroutine foo +end program bug + +! { dg-final { scan-tree-dump-times "foo ..integer.kind=4..0:. . restrict. a.data.;" 1 "original" } } diff --git a/Fortran/gfortran/regression/associate_12.f90 b/Fortran/gfortran/regression/associate_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_12.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! PR 55199: [OOP] Equivalenced variable has wrong type when used with generic member function +! +! Contributed by Rich Townsend + +module assoc_err_m + implicit none + type :: foo_t + contains + procedure :: func_1 + generic :: func => func_1 + end type +contains + real function func_1 (this) + class(foo_t), intent(in) :: this + end function +end module + +program assoc_err + use assoc_err_m + implicit none + type(foo_t) :: f + associate(b => f%func()) + print *, 1. + b + end associate +end program diff --git a/Fortran/gfortran/regression/associate_13.f90 b/Fortran/gfortran/regression/associate_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_13.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! +! Tests the fix for PR56047. This is actually a development of +! the test case of comment #10. +! +! Reported by Juergen Reuter +! + implicit none + type :: process_variant_def_t + integer :: i + end type + type :: process_component_def_t + class(process_variant_def_t), allocatable :: variant_def + end type + type(process_component_def_t), dimension(1:2) :: initial + allocate (initial(1)%variant_def, source = process_variant_def_t (99)) + associate (template => initial(1)%variant_def) + template%i = 77 + end associate + if (initial(1)%variant_def%i .ne. 77) STOP 1 +end diff --git a/Fortran/gfortran/regression/associate_14.f90 b/Fortran/gfortran/regression/associate_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_14.f90 @@ -0,0 +1,56 @@ +! { dg-do compile } +! Tests the fix for PR55984. +! +! Contributed by Sylwester Arabas +! +module bcd_m + type, abstract :: bcd_t + contains + procedure(bcd_fill_halos), deferred :: fill_halos + end type + abstract interface + subroutine bcd_fill_halos(this) + import :: bcd_t + class(bcd_t ) :: this + end subroutine + end interface +end module + +module solver_m + use bcd_m + type, abstract :: solver_t + integer :: n, hlo + class(bcd_t), pointer :: bcx, bcy + contains + procedure(solver_advop), deferred :: advop + end type + abstract interface + subroutine solver_advop(this) + import solver_t + class(solver_t) :: this + end subroutine + end interface + contains +end module + +module solver_mpdata_m + use solver_m + type :: mpdata_t + class(bcd_t), pointer :: bcx, bcy + contains + procedure :: advop => mpdata_advop + end type + contains + subroutine mpdata_advop(this) + class(mpdata_t) :: this + associate ( bcx => this%bcx, bcy => this%bcy ) + call bcx%fill_halos() + end associate + end subroutine +end module + + use solver_mpdata_m + class(mpdata_t), allocatable :: that + call mpdata_advop (that) +end + diff --git a/Fortran/gfortran/regression/associate_15.f90 b/Fortran/gfortran/regression/associate_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_15.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! Test the fix for PR58085, where the offset for 'x' was set to zero, +! rather than -1. +! +! Contributed by Vladimir Fuka +! +module foo +contains + function bar (arg) result (res) + integer arg, res(3) + res = [arg, arg+1, arg +2] + end function +end module + use foo + real d(3,3) + integer a,b,c + character(48) line1, line2 + associate (x=>shape(d)) + a = x(1) + b = x(2) + write (line1, *) a, b + write (line2, *) x + if (trim (line1) .ne. trim (line2)) STOP 1 + end associate + associate (x=>[1,2]) + a = x(1) + b = x(2) + write (line1, *) a, b + write (line2, *) x + if (trim (line1) .ne. trim (line2)) STOP 2 + end associate + associate (x=>bar(5)) ! make sure that we haven't broken function association + a = x(1) + b = x(2) + c = x(3) + write (line1, *) a, b, c + write (line2, *) x + if (trim (line1) .ne. trim (line2)) STOP 3 + end associate +end diff --git a/Fortran/gfortran/regression/associate_16.f90 b/Fortran/gfortran/regression/associate_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_16.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! PR 60834 - this used to ICE. + +module m + implicit none + type :: t + real :: diffusion=1. + end type +contains + subroutine solve(this, x) + class(t), intent(in) :: this + real, intent(in) :: x(:) + integer :: i + integer, parameter :: n(1:5)=[(i,i=1, 5)] + + associate( nu=>this%diffusion) + associate( exponential=>exp(-(x(i)-n) )) + do i = 1, size(x) + end do + end associate + end associate + end subroutine solve +end module m diff --git a/Fortran/gfortran/regression/associate_17.f90 b/Fortran/gfortran/regression/associate_17.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_17.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! Test the fix for PR61406 +! Contributed by Adam Hirst +program test + implicit none + real :: theta = 1.0 + + associate (n => [cos(theta), sin(theta)]) + if (abs (norm2(n) - 1.0) .gt. 1.0e-4) STOP 1 + end associate + +end program test diff --git a/Fortran/gfortran/regression/associate_18.f08 b/Fortran/gfortran/regression/associate_18.f08 --- /dev/null +++ b/Fortran/gfortran/regression/associate_18.f08 @@ -0,0 +1,80 @@ +! { dg-do run } +! +! Contributed by Antony Lewis +! Andre Vehreschild +! Check that associating array-sections/scalars is working +! with class arrays. +! + +program associate_18 + Type T + integer :: map = 1 + end Type T + + class(T), allocatable :: av(:) + class(T), allocatable :: am(:,:) + class(T), pointer :: pv(:) + class(T), pointer :: pm(:,:) + + integer :: iv(5) = 17 + integer :: im(4,5) = 23 + integer :: expect(20) = 23 + integer :: c + + allocate(av(2)) + associate(i => av(1)) + i%map = 2 + end associate + if (any (av%map /= [2,1])) STOP 1 + deallocate(av) + + allocate(am(3,4)) + associate(pam => am(2:3, 2:3)) + pam%map = 7 + pam(1,2)%map = 8 + end associate + if (any (reshape(am%map, [12]) /= [1,1,1, 1,7,7, 1,8,7, 1,1,1])) STOP 2 + deallocate(am) + + allocate(pv(2)) + associate(i => pv(1)) + i%map = 2 + end associate + if (any (pv%map /= [2,1])) STOP 3 + deallocate(pv) + + allocate(pm(3,4)) + associate(ppm => pm(2:3, 2:3)) + ppm%map = 7 + ppm(1,2)%map = 8 + end associate + if (any (reshape(pm%map, [12]) /= [1,1,1, 1,7,7, 1,8,7, 1,1,1])) STOP 4 + deallocate(pm) + + associate(i => iv(1)) + i = 7 + end associate + if (any (iv /= [7, 17, 17, 17, 17])) STOP 5 + + associate(pam => im(2:3, 2:3)) + pam = 9 + pam(1,2) = 10 + do c = 1, 2 + pam(2, c) = 0 + end do + end associate + if (any (reshape(im, [20]) /= [23,23,23,23, 23,9,0,23, & + 23,10,0,23, 23,23,23,23, 23,23,23,23])) STOP 6 + + expect(2:3) = 9 + do c = 1, 5 + im = 23 + associate(pam => im(:, c)) + pam(2:3) = 9 + end associate + if (any (reshape(im, [20]) /= expect)) STOP 7 + ! Shift expect + expect = [expect(17:), expect(:16)] + end do +end program + diff --git a/Fortran/gfortran/regression/associate_19.f03 b/Fortran/gfortran/regression/associate_19.f03 --- /dev/null +++ b/Fortran/gfortran/regression/associate_19.f03 @@ -0,0 +1,23 @@ +! { dg-do run } +! +! Contributed by mrestelli@gmail.com +! Adapated by Andre Vehreschild +! Test that fix for PR69296 is working. + +program p + implicit none + + integer :: j, a(2,6), i(3,2) + + a(1,:) = (/ ( j , j=1,6) /) + a(2,:) = (/ ( -10*j , j=1,6) /) + + i(:,1) = (/ 1 , 3 , 5 /) + i(:,2) = (/ 4 , 5 , 6 /) + + associate( ai => a(:,i(:,1)) ) + if (any(shape(ai) /= [2, 3])) STOP 1 + if (any(reshape(ai, [6]) /= [1 , -10, 3, -30, 5, -50])) STOP 2 + end associate + +end program p diff --git a/Fortran/gfortran/regression/associate_2.f95 b/Fortran/gfortran/regression/associate_2.f95 --- /dev/null +++ b/Fortran/gfortran/regression/associate_2.f95 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-std=f95" } + +! PR fortran/38936 +! Test that F95 rejects ASSOCIATE. + +PROGRAM main + IMPLICIT NONE + + ASSOCIATE (a => 5) ! { dg-error "Fortran 2003" } + END ASSOCIATE +END PROGRAM main diff --git a/Fortran/gfortran/regression/associate_20.f03 b/Fortran/gfortran/regression/associate_20.f03 --- /dev/null +++ b/Fortran/gfortran/regression/associate_20.f03 @@ -0,0 +1,31 @@ +! { dg-do run } +! +! Contributed by mrestelli@gmail.com +! Adapated by Andre Vehreschild +! Test that fix for PR69296 is working. + +program p + implicit none + + type foo + integer :: i + end type + + integer :: j, i(3,2) + class(foo), allocatable :: a(:,:) + + allocate (a(2,6)) + + a(1,:)%i = (/ ( j , j=1,6) /) + a(2,:)%i = (/ ( -10*j , j=1,6) /) + + i(:,1) = (/ 1 , 3 , 5 /) + i(:,2) = (/ 4 , 5 , 6 /) + + associate( ai => a(:,i(:,1))%i ) + if (any(shape(ai) /= [2, 3])) STOP 1 + if (any(reshape(ai, [6]) /= [1 , -10, 3, -30, 5, -50])) STOP 2 + end associate + + deallocate(a) +end program p diff --git a/Fortran/gfortran/regression/associate_21.f90 b/Fortran/gfortran/regression/associate_21.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_21.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-ffrontend-optimize" } +! PR 69742 - this used to ICE with front-end optimizatoin +! Original test case by Marco Restelli. +program p + implicit none + integer, allocatable :: i(:), j + + allocate( i(5) ) + i = (/( j , j=1,5 )/) + + ! The ICE appears when "size(i)" is used twice in associate + associate( i5 => i(size(i):size(i)) ) ! this gives ICE + !associate( i5 => i(size(2*i):size(i)) ) ! this works + i5 = 2 + end associate + + write(*,*) i +end program p diff --git a/Fortran/gfortran/regression/associate_22.f90 b/Fortran/gfortran/regression/associate_22.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_22.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +program foo + + implicit none + + character(len=4) :: s + character(len=10) :: a + + ! This works. + s = 'abc' + associate(t => s) + if (trim(t) /= 'abc') STOP 1 + end associate + + ! This failed. + associate(u => 'abc') + if (trim(u) /= 'abc') STOP 2 + end associate + + ! This failed. + a = s // 'abc' + associate(v => s // 'abc') + if (trim(v) /= trim(a)) STOP 3 + end associate + + ! This failed. + a = trim(s) // 'abc' + associate(w => trim(s) // 'abc') + if (trim(w) /= trim(a)) STOP 4 + end associate + + ! This failed. + associate(x => trim('abc')) + if (trim(x) /= 'abc') STOP 5 + end associate + +end program foo diff --git a/Fortran/gfortran/regression/associate_23.f90 b/Fortran/gfortran/regression/associate_23.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_23.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! +! Tests the fix for PR64933 +! +! Contributed by Olivier Marsden +! +program test_this + implicit none + character(len = 15) :: char_var, char_var_dim (3) + character(len = 80) :: buffer + +! Original failing case reported in PR + ASSOCIATE(should_work=>char_var) + should_work = "test succesful" + write (buffer, *) should_work(5:14) + END ASSOCIATE + + if (trim (buffer) .ne. " succesful") STOP 1 + +! Found to be failing during debugging + ASSOCIATE(should_work=>char_var_dim) + should_work = ["test SUCCESFUL", "test_SUCCESFUL", "test.SUCCESFUL"] + write (buffer, *) should_work(:)(5:14) + END ASSOCIATE + + if (trim (buffer) .ne. " SUCCESFUL_SUCCESFUL.SUCCESFUL") STOP 2 + +! Found to be failing during debugging + ASSOCIATE(should_work=>char_var_dim(1:2)) + should_work = ["test SUCCESFUL", "test_SUCCESFUL"] + write (buffer, *) should_work(:)(5:14) + END ASSOCIATE + + if (trim (buffer) .ne. " SUCCESFUL_SUCCESFUL") STOP 3 + +end program diff --git a/Fortran/gfortran/regression/associate_24.f90 b/Fortran/gfortran/regression/associate_24.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_24.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! +! From posting by Spectrum to clf on thread entitled "Bounds for array pointer dummy argument". +! +PROGRAM X + implicit none + TYPE T + INTEGER :: I + END TYPE T + TYPE(T), TARGET :: T1( 0:3 ) + + associate( P => T1 % I ) + call check (lbound (P, 1), ubound (P, 1) ,1 , 4) + endassociate + + associate( P2 => T1(:) % I ) + call check (lbound (P2, 1), ubound (P2, 1) ,1 , 4) + endassociate + + associate( Q => T1 ) + call check (lbound (Q, 1), ubound (Q, 1) ,0 , 3) + endassociate + + associate( Q2 => T1(:) ) + call check (lbound (Q2, 1), ubound (Q2, 1) ,1 , 4) + endassociate +contains + subroutine check (lbnd, ubnd, lower, upper) + integer :: lbnd, ubnd, lower, upper + if (lbnd .ne. lower) STOP 1 + if (ubnd .ne. upper) STOP 2 + end subroutine +END PROGRAM X diff --git a/Fortran/gfortran/regression/associate_25.f90 b/Fortran/gfortran/regression/associate_25.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_25.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! +! Checks the fix for PR60483. +! +! Contributed by Anthony Lewis +! +module A + implicit none + Type T + integer :: val = 2 + contains + final :: testfree + end type + integer :: final_flag = 0 +contains + subroutine testfree(this) + Type(T) this + final_flag = this%val + final_flag + end subroutine + subroutine Testf() + associate(X => T()) ! This was failing: Symbol 'x' at (1) has no IMPLICIT type + final_flag = X%val + end associate +! This should now be 4 but the finalization is not happening. +! TODO put it right! + if (final_flag .ne. 2) STOP 1 + end subroutine Testf +end module + + use A + call Testf +end diff --git a/Fortran/gfortran/regression/associate_26.f90 b/Fortran/gfortran/regression/associate_26.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_26.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! Test the fix for PR78152 +! +! Contributed by +! +program co_assoc + implicit none + integer, parameter :: p = 5 + real, allocatable :: a(:,:)[:,:] + allocate (a(p,p)[2,*]) + associate (i => a(1:p, 1:p)) + end associate +end program co_assoc diff --git a/Fortran/gfortran/regression/associate_26a.f90 b/Fortran/gfortran/regression/associate_26a.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_26a.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } +! +! Test the fix for PR78152 and the followup in PR82868 +! +! Contributed by +! +program co_assoc + implicit none + integer, parameter :: p = 5 + real, allocatable :: a(:,:)[:,:] + allocate (a(p,p)[2,*]) + associate (i => a(1:p, 1:p)) + end associate +end program co_assoc diff --git a/Fortran/gfortran/regression/associate_27.f90 b/Fortran/gfortran/regression/associate_27.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_27.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! +! Test the fix for PR80120 +! +! Contributed by Marco Restelli +! +program p + implicit none + + type :: t + character(len=25) :: text(2) + end type t + type(t) :: x + + x%text(1) = "ABC" + x%text(2) = "defgh" + + associate( c => x%text ) + if (c(1)(:maxval(len_trim(c))) .ne. trim (x%text(1))) STOP 1 + if (c(2)(:maxval(len_trim(c))) .ne. trim (x%text(2))) STOP 2 + end associate + +end program p diff --git a/Fortran/gfortran/regression/associate_28.f90 b/Fortran/gfortran/regression/associate_28.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_28.f90 @@ -0,0 +1,64 @@ +! { dg-do run } +! +! Test the fix for PR81903 +! +! Contributed by Karl May +! +Module TestMod_A + Type :: TestType_A + Real, Allocatable :: a(:,:) + End type TestType_A +End Module TestMod_A +Module TestMod_B + Type :: TestType_B + Real, Pointer, contiguous :: a(:,:) + End type TestType_B +End Module TestMod_B +Module TestMod_C + use TestMod_A + use TestMod_B + Implicit None + Type :: TestType_C + Class(TestType_A), Pointer :: TT_A(:) + Type(TestType_B), Allocatable :: TT_B(:) + contains + Procedure, Pass :: SetPt => SubSetPt + End type TestType_C + Interface + Module Subroutine SubSetPt(this) + class(TestType_C), Intent(InOut), Target :: this + End Subroutine + End Interface +End Module TestMod_C +Submodule(TestMod_C) SetPt +contains + Module Procedure SubSetPt + Implicit None + integer :: i + integer :: sum_a = 0 + outer:block + associate(x=>this%TT_B,y=>this%TT_A) + Do i=1,size(x) + x(i)%a=>y(i)%a + sum_a = sum_a + sum (int (x(i)%a)) + End Do + end associate + End block outer + if (sum_a .ne. 30) STOP 1 + End Procedure +End Submodule SetPt +Program Test + use TestMod_C + use TestMod_A + Implicit None + Type(TestType_C) :: tb + Type(TestType_A), allocatable, Target :: ta(:) + integer :: i + real :: src(2,2) = reshape ([(real(i), i = 1,4)],[2,2]) + allocate(ta(2),tb%tt_b(2)) + do i=1,size(ta) + allocate(ta(i)%a(2,2), source = src*real(i)) + End do + tb%TT_A=>ta + call tb%setpt() +End Program Test diff --git a/Fortran/gfortran/regression/associate_29.f90 b/Fortran/gfortran/regression/associate_29.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_29.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! +! Test the fix for PR82121 +! +! Contributed by Iain Miller +! +MODULE YOMCDDH + IMPLICIT NONE + SAVE + TYPE :: TCDDH + CHARACTER(len=12),ALLOCATABLE :: CADHTLS(:) + END TYPE TCDDH + CHARACTER(len=12),ALLOCATABLE :: CADHTTS(:) + TYPE(TCDDH), POINTER :: YRCDDH => NULL() +END MODULE YOMCDDH + + +SUBROUTINE SUCDDH() + USE YOMCDDH , ONLY : YRCDDH,CADHTTS + IMPLICIT NONE + ALLOCATE (YRCDDH%CADHTLS(20)) + ALLOCATE (CADHTTS(20)) + ASSOCIATE(CADHTLS=>YRCDDH%CADHTLS, NORMCHAR=>CADHTTS) +! Direct reference to character array compiled correctly +! YRCDDH%CADHTLS(1)='SVGTLF' +! Reference to associated variable name failed to compile + CADHTLS(2)='SVGTLT' + NORMCHAR(1)='SVLTTC' + END ASSOCIATE +END SUBROUTINE SUCDDH diff --git a/Fortran/gfortran/regression/associate_3.f03 b/Fortran/gfortran/regression/associate_3.f03 --- /dev/null +++ b/Fortran/gfortran/regression/associate_3.f03 @@ -0,0 +1,37 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } + +! PR fortran/38936 +! Check for errors with ASSOCIATE during parsing. + +PROGRAM main + IMPLICIT NONE + + ASSOCIATE ! { dg-error "Expected association list" } + + ASSOCIATE () ! { dg-error "Expected association" } + + ASSOCIATE (a => 1) 5 ! { dg-error "Junk after ASSOCIATE" } + + ASSOCIATE (x =>) ! { dg-error "Invalid association target" } + + ASSOCIATE (=> 5) ! { dg-error "Expected association" } + + ASSOCIATE (x => 5, ) ! { dg-error "Expected association" } + + myname: ASSOCIATE (a => 1) + END ASSOCIATE ! { dg-error "Expected block name of 'myname'" } + + ASSOCIATE (b => 2) + END ASSOCIATE myname ! { dg-error "Syntax error in END ASSOCIATE" } + + myname2: ASSOCIATE (c => 3) + END ASSOCIATE myname3 ! { dg-error "Expected label 'myname2'" } + + ASSOCIATE (a => 1, b => 2, a => 3) ! { dg-error "Duplicate name 'a'" } + + ASSOCIATE (a => 5) + INTEGER :: b ! { dg-error "Unexpected data declaration statement" } + END ASSOCIATE +END PROGRAM main ! { dg-error "Expecting END ASSOCIATE" } +! { dg-error "Unexpected end of file" "" { target "*-*-*" } 0 } diff --git a/Fortran/gfortran/regression/associate_30.f90 b/Fortran/gfortran/regression/associate_30.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_30.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! Test the fix for PR67543 +! +! Contributed by Gerhard Steinmetz +! + subroutine s1 + associate (x => null()) ! { dg-error "cannot be NULL()" } + end associate + end subroutine diff --git a/Fortran/gfortran/regression/associate_32.f03 b/Fortran/gfortran/regression/associate_32.f03 --- /dev/null +++ b/Fortran/gfortran/regression/associate_32.f03 @@ -0,0 +1,93 @@ +! { dg-do run } +! +! Tests fix for PR77296 and other bugs found on the way. +! +! Contributed by Matt Thompson +! +program test + + implicit none + type :: str_type + character(len=:), allocatable :: str + end type + + character(len=:), allocatable :: s, sd(:) + character(len=2), allocatable :: sf, sfd(:) + character(len=6) :: str + type(str_type) :: string + + s = 'ab' + associate(ss => s) + if (ss .ne. 'ab') STOP 1! This is the original bug. + ss = 'c' + end associate + if (s .ne. 'c ') STOP 2! No reallocation within ASSOCIATE block! + + sf = 'c' + associate(ss => sf) + if (ss .ne. 'c ') STOP 3! This the bug in comment #2 of the PR. + ss = 'cd' + end associate + + sd = [s, sf] + associate(ss => sd) + if (any (ss .ne. ['c ','cd'])) STOP 4 + end associate + + sfd = [sd,'ef'] + associate(ss => sfd) + if (any (ss .ne. ['c ','cd','ef'])) STOP 5 + ss = ['gh'] + end associate + if (any (sfd .ne. ['gh','cd','ef'])) STOP 6! No reallocation! + + string%str = 'xyz' + associate(ss => string%str) + if (ss .ne. 'xyz') STOP 7 + ss = 'c' + end associate + if (string%str .ne. 'c ') STOP 8! No reallocation! + + str = "foobar" + call test_char (5 , str) + IF (str /= "abcder") STOP 9 + + associate(ss => foo()) + if (ss .ne. 'pqrst') STOP 10 + end associate + + associate(ss => bar()) + if (ss(2) .ne. 'uvwxy') STOP 11 + end associate + +! The deallocation is not strictly necessary but it does allow +! other memory leakage to be tested for. + deallocate (s, sd, sf, sfd, string%str) +contains + +! This is a modified version of the subroutine in associate_1.f03. +! 'str' is now a dummy. + SUBROUTINE test_char (n, str) + INTEGER, INTENT(IN) :: n + + CHARACTER(LEN=n) :: str + + ASSOCIATE (my => str) + IF (LEN (my) /= n) STOP 12 + IF (my /= "fooba") STOP 13 + my = "abcde" + END ASSOCIATE + IF (str /= "abcde") STOP 14 + END SUBROUTINE test_char + + function foo() result(res) + character (len=:), pointer :: res + allocate (res, source = 'pqrst') + end function + + function bar() result(res) + character (len=:), allocatable :: res(:) + allocate (res, source = ['pqrst','uvwxy']) + end function + +end program test diff --git a/Fortran/gfortran/regression/associate_33.f03 b/Fortran/gfortran/regression/associate_33.f03 --- /dev/null +++ b/Fortran/gfortran/regression/associate_33.f03 @@ -0,0 +1,11 @@ +! { dg-do run } +! +! Test the fix for PR83898.f90 +! +! Contributed by G Steinmetz +! +program p + associate (x => ['1','2']) + if (any (x .ne. ['1','2'])) STOP 1 + end associate +end diff --git a/Fortran/gfortran/regression/associate_34.f90 b/Fortran/gfortran/regression/associate_34.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_34.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! +! Test the fix for PR84115. +! +! Contributed by G Steinmetz +! + character(:), allocatable :: chr + allocate (chr, source = "abc") + call s(chr, "abc") + chr = "mary had a little lamb" + call s(chr, "mary had a little lamb") + deallocate (chr) +contains + subroutine s(x, carg) + character(:), allocatable :: x + character(*) :: carg + associate (y => x) + if (y .ne. carg) STOP 1 + end associate + end +end diff --git a/Fortran/gfortran/regression/associate_35.f90 b/Fortran/gfortran/regression/associate_35.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_35.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! +! Test the fix for PR84115 comment #1. +! +! Contributed by G Steinmetz +! + character(:), allocatable :: dum + dum = "s1" + call s1 (dum) + dum = "s2" + call s2 (dum) + dum = "s3" + call s3 (dum) +contains + subroutine s1(x) + character(:), allocatable :: x + associate (y => x//x) + if (y .ne. x//x) stop 1 + end associate + end + + subroutine s2(x) + character(:), allocatable :: x + associate (y => [x]) + if (any(y .ne. [x])) stop 2 + end associate + end + + subroutine s3(x) + character(:), allocatable :: x + associate (y => [x,x]) + if (any(y .ne. [x,x])) stop 3 + end associate + end +end diff --git a/Fortran/gfortran/regression/associate_36.f90 b/Fortran/gfortran/regression/associate_36.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_36.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! +! Test the fix for PR83344. +! +! Contributed by Janne Blomqvist +! and Steve Kargl +! +program foo + implicit none + character(len=1) a + character(len=2) b + character(len=3) c + a = 'a' + call bah(a, len (a)) + b = 'bb' + call bah(b, len (b)) + c = 'ccc' + call bah(c, len (c)) + contains + subroutine bah(x, clen) + implicit none + integer :: clen + character(len=*), intent(in) :: x + associate(y => x) + if (len(y) .ne. clen) stop 1 + if (y .ne. x) stop 2 + end associate + end subroutine bah +end program foo diff --git a/Fortran/gfortran/regression/associate_37.f90 b/Fortran/gfortran/regression/associate_37.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_37.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-fcoarray=single" } +! +! Tests the fix for the regression PR83901. +! +! Contributed by G Steinmetz +! +program p + character(8), allocatable :: x[:] + allocate (x[*]) + x = 'abc' + associate (y => x) + if (y .ne. 'abc') stop 1 + end associate +end diff --git a/Fortran/gfortran/regression/associate_38.f90 b/Fortran/gfortran/regression/associate_38.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_38.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! +! Test the fix for PR49636 in which the 'span' of 'ty1' was not used +! in the descriptor of 'i'. +! +! Contributed by Fred Krogh +! +program test + type ty1 + integer :: k + integer :: i + end type ty1 + type ty2 + type(ty1) :: j(3) + end type ty2 + + type(ty2) t2 + t2%j(1:3)%i = [ 1, 3, 5 ] + associate (i=>t2%j%i) + if (any (t2%j(1:3)%i .ne. i(1:3))) stop 1 + end associate +end program test diff --git a/Fortran/gfortran/regression/associate_39.f90 b/Fortran/gfortran/regression/associate_39.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_39.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! PR 86935: Bad locus in ASSOCIATE statement +! +! Contributed by Janus Weil + +implicit none + +type :: t + real :: r = 0.5 + integer :: i = 3 +end type + +type(t) :: x + +associate (r => x%r, & + i => x%ii) ! { dg-error "Invalid association target" } + +end diff --git a/Fortran/gfortran/regression/associate_4.f08 b/Fortran/gfortran/regression/associate_4.f08 --- /dev/null +++ b/Fortran/gfortran/regression/associate_4.f08 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-std=f2008 -fcoarray=single" } + +! PR fortran/38936 +! Check for error with coindexed target. + +PROGRAM main + IMPLICIT NONE + INTEGER :: a[*] + + ASSOCIATE (x => a[1]) ! { dg-error "must not be coindexed" } +END PROGRAM main diff --git a/Fortran/gfortran/regression/associate_40.f90 b/Fortran/gfortran/regression/associate_40.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_40.f90 @@ -0,0 +1,96 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Test the fix for the second part of PR87359 in which the reallocation on +! assignment for components of associate names was disallowed by r264358. +! -fcheck-all exposed the mismatch in array shapes. The deallocations at +! the end of the main program are there to make sure that valgrind does +! not report an memory leaks. +! +! Contributed by Juergen Reuter +! +module phs_fks + implicit none + private + public :: phs_identifier_t + public :: phs_fks_t + type :: phs_identifier_t + integer, dimension(:), allocatable :: contributors + contains + procedure :: init => phs_identifier_init + end type phs_identifier_t + + type :: phs_fks_t + type(phs_identifier_t), dimension(:), allocatable :: phs_identifiers + end type phs_fks_t +contains + + subroutine phs_identifier_init & + (phs_id, contributors) + class(phs_identifier_t), intent(out) :: phs_id + integer, intent(in), dimension(:) :: contributors + allocate (phs_id%contributors (size (contributors))) + phs_id%contributors = contributors + end subroutine phs_identifier_init + +end module phs_fks + +!!!!! + +module instances + use phs_fks + implicit none + private + public :: process_instance_t + + type :: nlo_event_deps_t + type(phs_identifier_t), dimension(:), allocatable :: phs_identifiers + end type nlo_event_deps_t + + type :: process_instance_t + type(phs_fks_t), pointer :: phs => null () + type(nlo_event_deps_t) :: event_deps + contains + procedure :: init => process_instance_init + procedure :: setup_real_event_kinematics => pi_setup_real_event_kinematics + end type process_instance_t + +contains + + subroutine process_instance_init (instance) + class(process_instance_t), intent(out), target :: instance + integer :: i + integer :: i_born, i_real + allocate (instance%phs) + end subroutine process_instance_init + + subroutine pi_setup_real_event_kinematics (process_instance) + class(process_instance_t), intent(inout) :: process_instance + integer :: i_real, i + associate (event_deps => process_instance%event_deps) + i_real = 2 + associate (phs => process_instance%phs) + allocate (phs%phs_identifiers (3)) + call phs%phs_identifiers(1)%init ([1]) + call phs%phs_identifiers(2)%init ([1,2]) + call phs%phs_identifiers(3)%init ([1,2,3]) + process_instance%event_deps%phs_identifiers = phs%phs_identifiers ! Error: mismatch in array shapes. + end associate + end associate + end subroutine pi_setup_real_event_kinematics + +end module instances + +!!!!! + +program main + use instances, only: process_instance_t + implicit none + type(process_instance_t), allocatable, target :: process_instance + allocate (process_instance) + call process_instance%init () + call process_instance%setup_real_event_kinematics () + if (associated (process_instance%phs)) deallocate (process_instance%phs) + if (allocated (process_instance)) deallocate (process_instance) +end program main +! { dg-final { scan-tree-dump-times "__builtin_realloc" 2 "original" } } diff --git a/Fortran/gfortran/regression/associate_41.f90 b/Fortran/gfortran/regression/associate_41.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_41.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! +! Test the fix for PR86372 in which the associate name string length was +! not being set, thereby causing a segfault. +! +! Contributed by Janus Weil +! +program xxx + + character(len=50) :: s + + s = repeat ('*', len(s)) + call sub(s) + if (s .ne. '**'//'123'//repeat ('*', len(s) - 5)) stop 1 + +contains + + subroutine sub(str) + character(len=*), intent(inout) :: str + associate (substr => str(3:5)) + substr = '123' + end associate + end subroutine + +end diff --git a/Fortran/gfortran/regression/associate_42.f90 b/Fortran/gfortran/regression/associate_42.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_42.f90 @@ -0,0 +1,41 @@ +! { dg-do run } +! +! Tests the fix for a bug that was found in the course of fixing PR87566. +! +! Contributed by Paul Thomas +! + call AddArray +contains + subroutine AddArray() + type Object_array_pointer + class(*), pointer :: p(:) => null() + end type Object_array_pointer + + type (Object_array_pointer) :: obj + character(3), target :: tgt1(2) = ['one','two'] + character(5), target :: tgt2(2) = ['three','four '] + real, target :: tgt3(3) = [1.0,2.0,3.0] + + obj%p => tgt1 + associate (point => obj%p) + select type (point) ! Used to ICE here. + type is (character(*)) + if (any (point .ne. tgt1)) stop 1 + end select + point => tgt2 + end associate + + select type (z => obj%p) + type is (character(*)) + if (any (z .ne. tgt2)) stop 2 + end select + + obj%p => tgt3 + associate (point => obj%p) + select type (point) + type is (real) + if (any (point .ne. tgt3)) stop 3 + end select + end associate + end subroutine AddArray +end diff --git a/Fortran/gfortran/regression/associate_43.f90 b/Fortran/gfortran/regression/associate_43.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_43.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! +! Check that PR83146 remains fixed. +! +! Contributed by Neil Carlson +! + type foo + integer n + end type + type bar + type(foo) array(2) + end type + + type(bar) b + integer :: m=0 + + b%array(1)%n = 42 + b%array(2)%n = 43 + + call assoc(1) + m = 1 + call assoc(2) +contains + subroutine assoc (n) + integer :: n + associate (n_array => b%array%n) + select case (n_array(n)) + case (42) + if (m .ne. 0) stop 1 + case default + if (m .eq. 0) stop 2 + end select + end associate + end subroutine assoc +end \ No newline at end of file diff --git a/Fortran/gfortran/regression/associate_44.f90 b/Fortran/gfortran/regression/associate_44.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_44.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! Test the fix for PR56386 +! +! Contributed by Vladimir Fuka +! +subroutine CustomSolidBodies + implicit none + + type inner + real :: elev + end type + + type :: outer + type(inner),dimension(0) :: PrPoints + end type + + type(outer) :: SB + + associate (Prter=>SB%PrPoints) + PrTer%elev=0 ! ICE here + end associate +end subroutine CustomSolidBodies diff --git a/Fortran/gfortran/regression/associate_45.f90 b/Fortran/gfortran/regression/associate_45.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_45.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! +! Test the fix for PR58618 by checking that substring associate targets +! work correctly. +! +! Contributed by Vladimir Fuka +! + character(5) :: s(2) = ['abcde','fghij'] + character (6), pointer :: ptr => NULL() + character (6), target :: tgt = 'lmnopq' + + associate (x=>s(2)(3:4)) + if (x .ne. 'hi') stop 1 + x = 'uv' + end associate + if (any (s .ne. ['abcde','fguvj'])) stop 2 + +! Unity based substrings are cast differently. */ + associate (x=>s(1)(1:4)) + if (x .ne. 'abcd') stop 3 + x(2:3) = 'wx' + end associate + if (any (s .ne. ['awxde','fguvj'])) stop 4 + +! Make sure that possible misidentifications do not occur. + ptr => tgt + associate (x=>ptr) + if (x .ne. 'lmnopq') stop 5 + x(2:3) = 'wx' + end associate + if (tgt .ne. 'lwxopq') stop 6 + + associate (x=>ptr(5:6)) + if (x .ne. 'pq') stop 7 + x = 'wx' + end associate + if (tgt .ne. 'lwxowx') stop 8 + end diff --git a/Fortran/gfortran/regression/associate_46.f90 b/Fortran/gfortran/regression/associate_46.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_46.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! +! Check the fix for PR88143, in which the associate name caused +! a segfault in resolve.c. Make sure that the associate construct +! does its job correctly, as well as compiles. +! +! Contributed by Andrew Wood +! +MODULE m + IMPLICIT NONE + TYPE t + INTEGER, DIMENSION(:), ALLOCATABLE :: i + END TYPE + CONTAINS + SUBROUTINE s(x, idx1, idx2, k) + CLASS(*), DIMENSION(:), INTENT(IN), OPTIONAL :: x + INTEGER :: idx1, idx2, k + SELECT TYPE ( x ) + CLASS IS ( t ) + ASSOCIATE ( j => x(idx1)%i ) + k = j(idx2) + END ASSOCIATE + END SELECT + END +END + + use m + class (t), allocatable :: c(:) + integer :: k + allocate (c(2)) + allocate (c(1)%i, source = [3,2,1]) + allocate (c(2)%i, source = [6,5,4]) + call s(c, 1, 3, k) + if (k .ne. 1) stop 1 + call s(c, 2, 1, k) + if (k .ne. 6) stop 2 +end diff --git a/Fortran/gfortran/regression/associate_47.f90 b/Fortran/gfortran/regression/associate_47.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_47.f90 @@ -0,0 +1,69 @@ +! { dg-do run } +! +! Test the fix for PR88247 and more besides :-) +! +! Contributed by Gerhard Steinmetz +! +program p + type t + character(:), allocatable :: c + character(:), dimension(:), allocatable :: d + end type + type(t), allocatable :: x + + call foo ('abcdef','ghijkl') + associate (y => [x%c(:)]) + if (y(1) .ne. 'abcdef') stop 1 + end associate + + call foo ('ghi','ghi') + associate (y => [x%c(2:)]) + if (y(1) .ne. 'hi') stop 2 + end associate + + call foo ('lmnopq','ghijkl') + associate (y => [x%c(:3)]) + if (y(1) .ne. 'lmn') stop 3 + end associate + + call foo ('abcdef','ghijkl') + associate (y => [x%c(2:4)]) + if (y(1) .ne. 'bcd') stop 4 + end associate + + call foo ('lmnopqrst','ghijklmno') + associate (y => x%d(:)) + if (len(y) .ne. 9) stop 5 + if (any (y .ne. ['lmnopqrst','ghijklmno'])) stop 5 + y(1) = 'zqrtyd' + end associate + if (x%d(1) .ne. 'zqrtyd') stop 5 + +! Substrings of arrays still do not work correctly. + call foo ('lmnopqrst','ghijklmno') + associate (y => x%d(:)(2:4)) +! if (any (y .ne. ['mno','hij'])) stop 6 + end associate + + call foo ('abcdef','ghijkl') + associate (y => [x%d(:)]) + if (len(y) .ne. 6) stop 7 + if (any (y .ne. ['abcdef','ghijkl'])) stop 7 + end associate + + call foo ('lmnopqrst','ghijklmno') + associate (y => [x%d(2:1:-1)]) + if (len(y) .ne. 9) stop 8 + if (any (y .ne. ['ghijklmno','lmnopqrst'])) stop 8 + end associate + + deallocate (x) +contains + subroutine foo (c1, c2) + character(*) :: c1, c2 + if (allocated (x)) deallocate (x) + allocate (x) + x%c = c1 + x%d = [c1, c2] + end subroutine foo +end diff --git a/Fortran/gfortran/regression/associate_48.f90 b/Fortran/gfortran/regression/associate_48.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_48.f90 @@ -0,0 +1,41 @@ +! { dg-do run } +! +! Test the fix for PR90498. +! +! Contributed by Vladimir Fuka +! + type field_names_a + class(*), pointer :: var(:) =>null() + end type + + type(field_names_a),pointer :: a(:) + allocate (a(2)) + + allocate (a(1)%var(2), source = ["hello"," vlad"]) + allocate (a(2)%var(2), source = ["HELLO"," VLAD"]) + call s(a) + deallocate (a(1)%var) + deallocate (a(2)%var) + deallocate (a) +contains + subroutine s(a) + + type(field_names_a) :: a(:) + + select type (var => a(1)%var) + type is (character(*)) + if (any (var .ne. ["hello"," vlad"])) stop 1 + class default + stop + end select + + associate (var => a(2)%var) + select type (var) + type is (character(*)) + if (any (var .ne. ["HELLO"," VLAD"])) stop 2 + class default + stop + end select + end associate + end +end diff --git a/Fortran/gfortran/regression/associate_49.f90 b/Fortran/gfortran/regression/associate_49.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_49.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! +! Test the fix for PR91588, in which the declaration of 'a' caused +! an ICE. +! +! Contributed by Gerhardt Steinmetz +! +program p + character(4), parameter :: parm = '7890' + associate (z => '1234') + block + integer(len(z)) :: a + if (kind(a) .ne. 4) stop 1 + end block + end associate + associate (z => '123') + block + integer(len(z)+1) :: a + if (kind(a) .ne. 4) stop 2 + end block + end associate + associate (z => 1_8) + block + integer(kind(z)) :: a + if (kind(a) .ne. 8) stop 3 + end block + end associate + associate (z => parm) + block + integer(len(z)) :: a + if (kind(a) .ne. 4) stop 4 + end block + end associate +end diff --git a/Fortran/gfortran/regression/associate_5.f03 b/Fortran/gfortran/regression/associate_5.f03 --- /dev/null +++ b/Fortran/gfortran/regression/associate_5.f03 @@ -0,0 +1,43 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } + +! PR fortran/38936 +! Check for errors with ASSOCIATE during resolution. + +PROGRAM main + IMPLICIT NONE + INTEGER :: nontarget + INTEGER :: arr(3) + INTEGER, POINTER :: ptr + + ASSOCIATE (a => 5) ! { dg-error "is used as array" } + PRINT *, a(3) + END ASSOCIATE + + ASSOCIATE (a => nontarget) + ptr => a ! { dg-error "neither TARGET nor POINTER" } + END ASSOCIATE + + ASSOCIATE (a => 5, b => arr((/ 1, 3 /))) + a = 4 ! { dg-error "variable definition context" } + b = 7 ! { dg-error "variable definition context" } + CALL test2 (a) ! { dg-error "variable definition context" } + CALL test2 (b) ! { dg-error "variable definition context" } + END ASSOCIATE + +CONTAINS + + SUBROUTINE test (x) + INTEGER, INTENT(IN) :: x + ASSOCIATE (y => x) ! { dg-error "variable definition context" } + y = 5 ! { dg-error "variable definition context" } + CALL test2 (x) ! { dg-error "variable definition context" } + END ASSOCIATE + END SUBROUTINE test + + ELEMENTAL SUBROUTINE test2 (x) + INTEGER, INTENT(OUT) :: x + x = 5 + END SUBROUTINE test2 + +END PROGRAM main diff --git a/Fortran/gfortran/regression/associate_50.f90 b/Fortran/gfortran/regression/associate_50.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_50.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR 92780 - this used to ICE instead of being rejected. +! Test case by Gerhard Steinmetz. + +program p + associate (y => p) ! { dg-error "Invalid association target" } + end associate ! { dg-error "Expecting END PROGRAM statement" } +end program p diff --git a/Fortran/gfortran/regression/associate_51.f90 b/Fortran/gfortran/regression/associate_51.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_51.f90 @@ -0,0 +1,61 @@ +! { dg-do compile } +! +! PR fortran/92994 +! +! Contributed by G. Steinmetz +! +recursive function f() result(z) + associate (y1 => f()) + end associate + associate (y2 => f) ! { dg-error "is a procedure name" } + end associate +end + +recursive function f2() + associate (y1 => f2()) ! { dg-error "Invalid association target" } + end associate ! { dg-error "Expecting END FUNCTION statement" } +end + +recursive function f3() + associate (y1 => f3) + print *, y1() ! { dg-error "Expected array subscript" } + end associate + associate (y2 => f3) ! { dg-error "Associate-name 'y2' at \\(1\\) is used as array" } + print *, y2(1) + end associate +end + +subroutine p2 + type t + end type + type(t) :: z = t() + associate (y => t()) + end associate +end + +subroutine p3 + procedure() :: g + associate (y => g) ! { dg-error "is a procedure name" } + end associate +end + +subroutine p4 + external :: g + associate (y => g) ! { dg-error "is a procedure name" } + end associate +end + +recursive subroutine s + associate (y => s) ! { dg-error "is a procedure name" } + end associate +end + +recursive subroutine s2 + associate (y => (s2)) ! { dg-error "Associating selector-expression at .1. yields a procedure" } + end associate +end + +program p + associate (y => (p)) ! { dg-error "Invalid association target" } + end associate ! { dg-error "Expecting END PROGRAM statement" } +end diff --git a/Fortran/gfortran/regression/associate_52.f90 b/Fortran/gfortran/regression/associate_52.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_52.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! +! PR fortran/93427 +! +! Contributed by Andrew Benson +! +module a + +type :: t +end type t + +contains + +recursive function b() + class(t), pointer :: b + type(t) :: c + allocate(t :: b) + select type (b) + type is (t) + b=c + end select +end function b + +end module a diff --git a/Fortran/gfortran/regression/associate_53.f90 b/Fortran/gfortran/regression/associate_53.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_53.f90 @@ -0,0 +1,71 @@ +! { dg-do compile } +! +! PR fortran/93363 +! +! Contributed by G. Steinmetz + +program p + type t + integer :: a + end type + type(t) :: z + z = t(1) + associate (var1 => t) ! { dg-error "Derived type 't' cannot be used as a variable" } + end associate +end + +subroutine sub + if (f() /= 1) stop + associate (var2 => f) ! { dg-error "Associating entity 'f' at .1. is a procedure name" } + end associate + block + block + associate (var2a => f) ! { dg-error "Associating entity 'f' at .1. is a procedure name" } + end associate + end block + end block +contains + integer function f() + f = 1 + associate (var3 => f) + end associate + block + block + associate (var4 => f) + end associate + end block + end block + end + integer recursive function f2() result(res) + res = 1 + associate (var5 => f2) ! { dg-error "Associating entity 'f2' at .1. is a procedure name" } + end associate + block + block + associate (var6 => f2) ! { dg-error "Associating entity 'f2' at .1. is a procedure name" } + end associate + end block + end block + end + subroutine subsub + associate (var7 => f) ! { dg-error "Associating entity 'f' at .1. is a procedure name" } + end associate + block + block + associate (var8 => f) ! { dg-error "Associating entity 'f' at .1. is a procedure name" } + end associate + end block + end block + end +end + +subroutine sub2 + interface g + procedure s + end interface + associate (var9 => g) ! { dg-error "Associating entity 'g' at .1. is a procedure name" } + end associate +contains + subroutine s + end +end diff --git a/Fortran/gfortran/regression/associate_54.f90 b/Fortran/gfortran/regression/associate_54.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_54.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! +! Test the fix for PR93701. +! +! Contributed by Simon Brass +! +module test + implicit none + + integer, parameter :: N_STATE = 1, & + TEST_STATE = 1 + + type :: test_t + integer, dimension(:), allocatable :: state + end type test_t + +contains + + subroutine test_allocate (obj) + class(test_t), intent(out) :: obj + allocate (obj%state(N_STATE)) + end subroutine test_allocate + + subroutine test_alter_state1 (obj, a) + class(test_t), intent(inout) :: obj + integer, intent(in) :: a + associate (state => obj%state(TEST_STATES)) ! { dg-error "is used as array" } +! state = a + state(TEST_STATE) = a ! { dg-error "array reference of a non-array" } + end associate + end subroutine test_alter_state1 + +end module test diff --git a/Fortran/gfortran/regression/associate_55.f90 b/Fortran/gfortran/regression/associate_55.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_55.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! +! Test the fix for PR93701. +! +! Contributed by Simon Brass +! +module test + implicit none + + integer, parameter :: N_STATE = 1, & + TEST_STATE = 1 + + type :: test_t + integer, dimension(:), allocatable :: state + end type test_t + +contains + + subroutine test_allocate (obj) + class(test_t), intent(out) :: obj + allocate (obj%state(N_STATE)) + end subroutine test_allocate + + + subroutine test_alter_state2 (obj, a) + class(test_t), intent(inout) :: obj + integer, intent(in) :: a + associate (state => obj%state(TEST_STATES)) ! { dg-error "no IMPLICIT type" } + state = a ! { dg-error "vector-indexed target" } +! state(TEST_STATE) = a + end associate + end subroutine test_alter_state2 + +end module test + diff --git a/Fortran/gfortran/regression/associate_56.f90 b/Fortran/gfortran/regression/associate_56.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_56.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! +! Test the fix for PR93701. +! +! Contributed by Simon Brass +! +module test + implicit none + + integer, parameter :: N_STATE = 1, & + TEST_STATE = 1 + + type :: test_t + integer, dimension(:), allocatable :: state + end type test_t + +contains + + subroutine test_allocate (obj) + class(test_t), intent(out) :: obj + allocate (obj%state(N_STATE)) + end subroutine test_allocate + + + subroutine test_alter_state2 (obj, a) + class(test_t), intent(inout) :: obj + integer, intent(in) :: a + integer, dimension(2) :: TEST_STATES = [1,2] + associate (state => obj%state(TEST_STATES)) + state = a ! { dg-error "vector-indexed target" } + state(TEST_STATE) = a ! { dg-error "vector-indexed target" } + end associate + end subroutine test_alter_state2 + +end module test + diff --git a/Fortran/gfortran/regression/associate_57.f90 b/Fortran/gfortran/regression/associate_57.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_57.f90 @@ -0,0 +1,47 @@ +! { dg-do compile } +! PR 96386 - this used to cause an ICE. +! Test case by Menno Deij - van Rijswijk. + +MODULE assoc + +TYPE Level3 + INTEGER :: someNumber +END TYPE Level3 + +TYPE Level2 + INTEGER :: nLevel3 + TYPE (Level3), ALLOCATABLE :: levels3(:) + +END TYPE Level2 + +TYPE Level1 + INTEGER :: nLevel2 + TYPE (Level2), ALLOCATABLE :: levels2(:) +END TYPE Level1 + +TYPE outer_type + INTEGER :: nLevel1 + TYPE (Level1), ALLOCATABLE :: levels1(:) +END TYPE outer_type + +TYPE(outer_type), TARGET :: outer + +CONTAINS + +SUBROUTINE internal_compiler_error_repro() + +INTEGER F,B,Z + +ASSOCIATE(l1 => outer%levels1 ) ! <-- this gives an ICE +!ASSOCIATE(l1 => outer%levels1(:) ) ! <-- No ICE if array spec is added + DO F=1,outer%nLevel1 + ASSOCIATE(l2 => l1(F)%levels2 ) + DO B=1,l2(F)%nLevel3 ! <-- condition for ICE to be triggered + + END DO + END ASSOCIATE + END DO +END ASSOCIATE + +END SUBROUTINE internal_compiler_error_repro +end module diff --git a/Fortran/gfortran/regression/associate_58.f90 b/Fortran/gfortran/regression/associate_58.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_58.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! +! PR fortran/104570 +! The following used to cause an ICE because the string length +! evaluation of the (y) expression was not prepared to handle +! a non-scalar expression. + +program p + character(:), allocatable :: x(:) + x = ['abc'] + call s +contains + subroutine s + associate (y => x) + associate (z => (y)) + print *, z + end associate + end associate + end +end + diff --git a/Fortran/gfortran/regression/associate_59.f90 b/Fortran/gfortran/regression/associate_59.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associate_59.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/103590 - ICE: find_array_spec(): Missing spec +! Contributed by G.Steinmetz + +program p + associate (a => 1) + print *, [character(a(1)) :: '1'] ! { dg-error "Scalar INTEGER expression" } + end associate +end diff --git a/Fortran/gfortran/regression/associate_6.f03 b/Fortran/gfortran/regression/associate_6.f03 --- /dev/null +++ b/Fortran/gfortran/regression/associate_6.f03 @@ -0,0 +1,37 @@ +! { dg-do compile } +! { dg-options "-std=f2003 -fdump-tree-original" } + +! PR fortran/38936 +! Check that array expression association (with correct bounds) works for +! complicated expressions. + +! Contributed by Daniel Kraft, d@domob.eu. + +MODULE m + IMPLICIT NONE + +CONTAINS + + PURE FUNCTION func (n) + INTEGER, INTENT(IN) :: n + INTEGER :: func(2 : n+1) + + INTEGER :: i + + func = (/ (i, i = 1, n) /) + END FUNCTION func + +END MODULE m + +PROGRAM main + USE :: m + IMPLICIT NONE + + ASSOCIATE (arr => func (4)) + ! func should only be called once here, not again for the bounds! + + IF (LBOUND (arr, 1) /= 1 .OR. UBOUND (arr, 1) /= 4) STOP 1 + IF (arr(1) /= 1 .OR. arr(4) /= 4) STOP 2 + END ASSOCIATE +END PROGRAM main +! { dg-final { scan-tree-dump-times "func" 2 "original" } } diff --git a/Fortran/gfortran/regression/associate_7.f03 b/Fortran/gfortran/regression/associate_7.f03 --- /dev/null +++ b/Fortran/gfortran/regression/associate_7.f03 @@ -0,0 +1,21 @@ +! { dg-do run } +! { dg-options "-std=f2003 " } + +! PR fortran/38936 +! Check association and pointers. + +! Contributed by Daniel Kraft, d@domob.eu. + +PROGRAM main + IMPLICIT NONE + INTEGER, TARGET :: tgt + INTEGER, POINTER :: ptr + + tgt = 1 + ASSOCIATE (x => tgt) + ptr => x + IF (ptr /= 1) STOP 1 + ptr = 2 + END ASSOCIATE + IF (tgt /= 2) STOP 2 +END PROGRAM main diff --git a/Fortran/gfortran/regression/associate_8.f03 b/Fortran/gfortran/regression/associate_8.f03 --- /dev/null +++ b/Fortran/gfortran/regression/associate_8.f03 @@ -0,0 +1,37 @@ +! { dg-do run } +! { dg-options "-std=f2003 " } + +! PR fortran/38936 +! Check associate to polymorphic entities. + +! Contributed by Tobias Burnus, burnus@gcc.gnu.org. + +type t +end type t + +type, extends(t) :: t2 +end type t2 + +class(t), allocatable :: a, b +allocate( t :: a) +allocate( t2 :: b) + +associate ( one => a, two => b) + select type(two) + type is (t) + STOP 1 + type is (t2) + print *, 'OK', two + class default + STOP 2 + end select + select type(one) + type is (t2) + STOP 3 + type is (t) + print *, 'OK', one + class default + STOP 4 + end select +end associate +end diff --git a/Fortran/gfortran/regression/associate_9.f03 b/Fortran/gfortran/regression/associate_9.f03 --- /dev/null +++ b/Fortran/gfortran/regression/associate_9.f03 @@ -0,0 +1,47 @@ +! { dg-do run } +! { dg-options "-std=f2003 " } + + +! PR fortran/38936 +! Association to derived-type, where the target type is not know +! during parsing (only resolution). + +! Contributed by Daniel Kraft, d@domob.eu. + +MODULE m + IMPLICIT NONE + + TYPE :: mynum + INTEGER :: comp + END TYPE mynum + + INTERFACE OPERATOR(+) + MODULE PROCEDURE add + END INTERFACE OPERATOR(+) + +CONTAINS + + PURE FUNCTION add (a, b) + TYPE(mynum), INTENT(IN) :: a, b + TYPE(mynum) :: add + + add%comp = a%comp + b%comp + END FUNCTION add + +END MODULE m + +PROGRAM main + USE :: m + IMPLICIT NONE + + TYPE(mynum) :: a + a = mynum (5) + + ASSOCIATE (x => add (a, a)) + IF (x%comp /= 10) STOP 1 + END ASSOCIATE + + ASSOCIATE (x => a + a) + IF (x%comp /= 10) STOP 2 + END ASSOCIATE +END PROGRAM main diff --git a/Fortran/gfortran/regression/associated_1.f90 b/Fortran/gfortran/regression/associated_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associated_1.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! PR 25292: Check that the intrinsic associated works with functions returning +! pointers as arguments +program test + real, pointer :: a, b + + nullify(a,b) + if(associated(a,b).or.associated(a,a)) STOP 1 + allocate(a) + if(associated(b,a)) STOP 2 + if (.not.associated(x(a))) STOP 3 + if (.not.associated(a, x(a))) STOP 4 + + nullify(b) + if (associated(x(b))) STOP 5 + allocate(b) + if (associated(x(b), x(a))) STOP 6 + +contains + + function x(a) RESULT(b) + real, pointer :: a,b + b => a + end function x + +end program test diff --git a/Fortran/gfortran/regression/associated_2.f90 b/Fortran/gfortran/regression/associated_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associated_2.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! Tests the implementation of 13.14.13 of the f95 standard +! in respect of zero character and zero array length. +! +! Contributed by Paul Thomas +! + call test1 () + call test2 () + call test3 (0) + call test3 (1) +contains + subroutine test1 () + integer, pointer, dimension(:, :, :) :: a, b + allocate (a(2,0,2)) + b => a +! Even though b is zero length, associated returns true because +! the target argument is not present (case (i)) + if (.not. associated (b)) STOP 1 + deallocate (a) + nullify(a) + if(associated(a,a)) STOP 2 + allocate (a(2,1,2)) + b => a + if (.not.associated (b)) STOP 3 + deallocate (a) + end subroutine test1 + subroutine test2 () + integer, pointer, dimension(:, :, :) :: a, b + allocate (a(2,0,2)) + b => a +! Associated returns false because target is present (case(iii)). + if (associated (b, a)) STOP 4 + deallocate (a) + allocate (a(2,1,2)) + b => a + if (.not.associated (b, a)) STOP 5 + deallocate (a) + end subroutine test2 + subroutine test3 (n) + integer :: n + character(len=n), pointer, dimension(:) :: a, b + allocate (a(2)) + b => a +! Again, with zero character length associated returns false +! if target is present. + if (associated (b, a) .and. (n .eq. 0)) STOP 6 +! + if ((.not.associated (b, a)) .and. (n .ne. 0)) STOP 7 + deallocate (a) + end subroutine test3 +end diff --git a/Fortran/gfortran/regression/associated_3.f90 b/Fortran/gfortran/regression/associated_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associated_3.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! Test for fix of PR27655 +! +!Contributed by Francois-Xavier Coudert + integer, pointer :: i + print *, associated(NULL(),i) ! { dg-error "not permitted as actual argument" } + print *, associated(i,NULL()) ! { dg-error "not permitted as actual argument" } +end diff --git a/Fortran/gfortran/regression/associated_4.f90 b/Fortran/gfortran/regression/associated_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associated_4.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! PR fortran/26801 + implicit none + + integer :: i + integer,target :: u + logical :: l + character(len=8) :: A + type dt + integer, pointer :: a => NULL() + end type dt + type(dt) :: obj(2) + + i = 2 + l = associated(obj(i)%a) + write(A,*) l + l = associated(obj(i)%a,u) + print *, l + write(A,*) l +end diff --git a/Fortran/gfortran/regression/associated_5.f90 b/Fortran/gfortran/regression/associated_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associated_5.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! PR 35719 - associated used to fail with zero-sized automatic arrays +! Test case contributed by Dick Hendrickson + + program try_mf1053 + + call mf1053 ( 1, 2, 3, 4) + end + + SUBROUTINE MF1053 (nf1, nf2, nf3, nf4) + INTEGER, pointer :: ptr(:,:) + INTEGER, target :: ILA1(NF2,NF4:NF3) + + ptr => ILA1 + + if (ASSOCIATED (ptr, ILA1(NF1:NF2,NF4:NF3) ) ) STOP 1 + if ( .not. ASSOCIATED(ptr) ) STOP 2 + + END SUBROUTINE diff --git a/Fortran/gfortran/regression/associated_6.f90 b/Fortran/gfortran/regression/associated_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associated_6.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! +! PR 54881: [4.8 Regression] [OOP] ICE in fold_convert_loc, at fold-const.c:2016 +! +! Contributed by Richard L Lozes + + implicit none + + type treeNode + type(treeNode), pointer :: right => null() + end type + + type(treeNode) :: n + + if (associated(RightOf(n))) STOP 1 + allocate(n%right) + if (.not.associated(RightOf(n))) STOP 2 + deallocate(n%right) + +contains + + function RightOf (theNode) + class(treeNode), pointer :: RightOf + type(treeNode), intent(in) :: theNode + RightOf => theNode%right + end function + +end diff --git a/Fortran/gfortran/regression/associated_7.f90 b/Fortran/gfortran/regression/associated_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associated_7.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! +! PR 55692: ICE on incorrect use of ASSOCIATED function +! +! Contributed by Gilbert Scott + +INTEGER, POINTER :: P1, P2 +PRINT *, ASSOCIATED([P1,P2]) ! { dg-error "must be a POINTER" } +END diff --git a/Fortran/gfortran/regression/associated_8.f90 b/Fortran/gfortran/regression/associated_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associated_8.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! +! Test the fix for PR92959, where compilation of ASSOCIATED segfaulted in 's1' and 's2'. +! +! Contributed by Gerhard Steinmetz +! +program p + character(:), pointer :: x, y => NULL() + character, pointer :: u, v => NULL () + character(4), target :: tgt = "abcd" + +! Manifestly not associated + x => tgt + u => tgt(1:1) + call s1 (.false., 1) + call s2 (.false., 2) +! Manifestly associated + y => x + v => u + call s1 (.true., 3) + call s2 (.true., 4) +! Zero sized storage sequences must give a false. + y => tgt(1:0) + x => y + call s1 (.false., 5) +contains + subroutine s1 (state, err_no) + logical :: state + integer :: err_no + if (associated(x, y) .neqv. state) stop err_no + end + subroutine s2 (state, err_no) + logical :: state + integer :: err_no + if (associated(u, v) .neqv. state) stop err_no + end +end diff --git a/Fortran/gfortran/regression/associated_assumed_rank.f90 b/Fortran/gfortran/regression/associated_assumed_rank.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associated_assumed_rank.f90 @@ -0,0 +1,126 @@ +! { dg-do run } + +! PR fortran/101334 + +implicit none (type, external) +real, target :: AT(10,10), BT +real, contiguous, pointer :: A(:,:) +real, pointer :: B +real, pointer :: AP(:,:), BP +real, pointer :: CP(:), DP(:,:), D, EP(:) + +call test_char() + +A => AT +B => BT + +AP => A +BP => B +call foo(AP,B, A, 1) ! OK - associated +call foo(BP,B, A, 2) ! OK - associated + +! Those are all not associated: + +AP => null() +BP => null() +call foo(AP, B, A, 3) ! LHS not associated +call foo(BP, B, A, 4) ! LHS not associated + +DP => null() +D => null() +call foo(AP, B, DP, 5) ! LHS+RHS not associated +call foo(BP, D, A, 6) ! LHS+RHS not associated + +AP => A +BP => B +call foo(AP, B, DP, 7) ! RHS not associated +call foo(BP, D, A, 8) ! RHS not associated + +CP(1:size(A)) => A +call foo(CP, B, A, 9) ! Shape (rank) differs + +AP => A(2:,:) +call foo(AP, B, A, 10) ! Shape differs + +AP => A(:,2:) +call foo(AP, B, A, 11) ! Shape differs + +AP(10:,10:) => A +call foo(AP, B, A, 12) ! OK - bounds different, shape same + +CP => AT(1:-1, 5) +EP => AT(1:-1, 5) ! Case(i) + case(iv) +call foo2(CP, EP) ! CP associated - but CP not associated with EP +contains +subroutine foo2(p, lpd) + implicit none (type, external) + real, pointer :: p(..) ! "pointer" + real, pointer :: lpd(:) ! array "target" + if (.not.associated(p)) stop 18 ! OK - associated + if (associated(p, lpd)) stop 19 ! .. but for zero-sized array +end + +subroutine foo(p, lp, lpd, cnt) + implicit none (type, external) + real, pointer :: p(..) ! "pointer" + real, pointer :: lp ! scalar "target" + real, pointer :: lpd(:,:) ! array "target" + integer, value :: cnt + + if (cnt == 1) then + if (.not. associated(p, lpd)) stop 1 ! OK + elseif (cnt == 2) then + if (.not. associated(p, lp)) stop 2 ! OK + elseif (cnt == 3) then + if (associated(p, lpd)) stop 3 ! LHS NULL ptr + if (associated(p)) stop 4 ! LHS NULL ptr + elseif (cnt == 4) then + if (associated(p, lp)) stop 5 ! LHS NULL ptr + if (associated(p)) stop 6 ! LHS NULL ptr + elseif (cnt == 5) then + if (associated(p, lpd)) stop 7 ! LHS+RHS NULL ptr + if (associated(p)) stop 8 ! LHS+RHS NULL ptr + elseif (cnt == 6) then + if (associated(p, lp)) stop 9 ! LHS+RHS NULL ptr + if (associated(p)) stop 10 ! LHS+RHS NULL ptr + elseif (cnt == 7) then + if (associated(p, lpd)) stop 11 ! RHS NULL ptr + elseif (cnt == 8) then + if (associated(p, lp)) stop 12 ! RHS NULL ptr + elseif (cnt == 9) then + if (associated(p, lpd)) stop 13 ! rank differs + if (associated(p, lp)) stop 14 ! rank differs + elseif (cnt == 10) then + if (associated(p, lpd)) stop 15 ! shape differs + elseif (cnt == 11) then + if (associated(p, lpd)) stop 16 ! shape differs + elseif (cnt == 12) then + if (.not.associated(p, lpd)) stop 17 ! OK - shape same, lbound different + else + stop 99 + endif +end +subroutine test_char() + character(len=0), target :: str0 + character(len=2), target :: str2 + character(len=:), pointer :: ptr + ptr => str0 + call test_char2(ptr, str0) + ptr => str2 + call test_char2(ptr, str2) +end +subroutine test_char2(x,y) + character(len=:), pointer :: x + character(len=*), target :: y + if (len(y) == 0) then + if (len(x) /= 0) stop 20 + if (.not. associated(x)) stop 21 + if (associated(x, y)) stop 22 + else + if (len(y) /= 2) stop 23 + if (len(x) /= 2) stop 24 + if (.not. associated(x)) stop 25 + if (.not. associated(x, y)) stop 26 + end if +end +end diff --git a/Fortran/gfortran/regression/associated_target_1.f90 b/Fortran/gfortran/regression/associated_target_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associated_target_1.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! This tests the patch for PR27584, where an ICE would ensue if +! a bad argument was fed for the target in ASSOCIATED. +! +! Contributed by Tobias Burnus +! +program test + implicit none + real, pointer :: x + real, target :: y + if(ASSOCIATED(X,(Y))) print *, 'Hello' ! { dg-error "VARIABLE or FUNCTION" } +end program test diff --git a/Fortran/gfortran/regression/associated_target_2.f90 b/Fortran/gfortran/regression/associated_target_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associated_target_2.f90 @@ -0,0 +1,41 @@ +! { dg-do run } +! +! PR fortran/35721 +! +! ASSOCIATED(ptr, trgt) should return true if +! the same storage units (in the same order) +! gfortran was returning false if the strips +! were different but only one (the same!) element +! was present. +! +! Contributed by Dick Hendrickson +! + program try_mg0028 + implicit none + real tda2r(2,3) + + call mg0028(tda2r, 1, 2, 3) + + CONTAINS + + SUBROUTINE MG0028(TDA2R,nf1,nf2,nf3) + integer :: nf1,nf2,nf3 + real, target :: TDA2R(NF2,NF3) + real, pointer :: TLA2L(:,:),TLA2L1(:,:) + logical LL(4) + TLA2L => TDA2R(NF2:NF1:-NF2,NF3:NF1:-NF2) + TLA2L1 => TLA2L + LL(1) = ASSOCIATED(TLA2L) + LL(2) = ASSOCIATED(TLA2L,TLA2L1) + LL(3) = ASSOCIATED(TLA2L,TDA2R) + LL(4) = ASSOCIATED(TLA2L1,TDA2R(2:2,3:1:-2)) !should be true + + if (any(LL .neqv. (/ .true., .true., .false., .true./))) then + print *, LL + print *, shape(TLA2L1) + print *, shape(TDA2R(2:2,3:1:-2)) + stop + endif + + END SUBROUTINE + END PROGRAM diff --git a/Fortran/gfortran/regression/associated_target_3.f90 b/Fortran/gfortran/regression/associated_target_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associated_target_3.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! +! PR fortran/41777 +! +module m +type t2 + integer :: i +end type t2 +interface f + module procedure f2 +end interface f +contains +function f2(a) + type(t2), pointer :: f2,a + f2 => a +end function f2 +end module m + +use m +implicit none +type(t2), pointer :: a +allocate(a) +if (.not. associated(a,f(a))) STOP 1 +call cmpPtr(a,f2(a)) +call cmpPtr(a,f(a)) +deallocate(a) +contains + subroutine cmpPtr(a,b) + type(t2), pointer :: a,b +! print *, associated(a,b) + if (.not. associated (a, b)) STOP 2 + end subroutine cmpPtr +end diff --git a/Fortran/gfortran/regression/associated_target_4.f90 b/Fortran/gfortran/regression/associated_target_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associated_target_4.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! +! PR 44696: [OOP] ASSOCIATED fails on polymorphic variables +! +! Original test case by Hans-Werner Boschmann +! Modified by Janus Weil + +program rte1 + implicit none + type::node_type + class(node_type),pointer::parent,child + integer::id + end type node_type + class(node_type),pointer::root + allocate(root) + allocate(root%child) + root%child%parent=>root + root%id=1 + root%child%id=2 + print *,root%child%id," is child of ",root%id,":" + print *,root%child%parent%id,root%id + if (.not. associated(root%child%parent,root)) STOP 1 +end program rte1 diff --git a/Fortran/gfortran/regression/associated_target_5.f03 b/Fortran/gfortran/regression/associated_target_5.f03 --- /dev/null +++ b/Fortran/gfortran/regression/associated_target_5.f03 @@ -0,0 +1,40 @@ +! { dg-do run } +! Test the fix for PR57522, in which the associate name had a +! 'span' of an INTEGER rather than that of 'mytype'. +! +! Contributed by A Briolat +! +program test_associate + type mytype + integer :: a = 1, b = 2 + end type + type(mytype) :: t(4), u(2,2) + integer :: c(4) + t%a = [0, 1, 2, 3] + t%b = [4, 5, 6, 7] + associate (a => t%a) +! Test 'a' is OK on lhs and/or rhs of assignments + c = a - 1 + if (any (c .ne. [-1,0,1,2])) STOP 1 + a = a + 1 + if (any (a .ne. [1,2,3,4])) STOP 2 + a = t%b + if (any (a .ne. t%b)) STOP 3 +! Test 'a' is OK as an actual argument + c = foo(a) + if (any (c .ne. t%b + 10)) STOP 4 + end associate +! Make sure that the fix works for multi-dimensional arrays... + associate (a => u%a) + if (any (a .ne. reshape ([1,1,1,1],[2,2]))) STOP 5 + end associate +! ...and sections + associate (a => t(2:3)%b) + if (any (a .ne. [5,6])) STOP 6 + end associate +contains + function foo(arg) result(res) + integer :: arg(4), res(4) + res = arg + 10 + end function +end program diff --git a/Fortran/gfortran/regression/associated_target_6.f03 b/Fortran/gfortran/regression/associated_target_6.f03 --- /dev/null +++ b/Fortran/gfortran/regression/associated_target_6.f03 @@ -0,0 +1,49 @@ +! { dg-do run } +! Tests the fix for PR67091 in which the first call to associated +! gave a bad result because the 'target' argument was not being +! correctly handled. +! +! Contributed by 'FortranFan' on clf. +! https://groups.google.com/forum/#!topic/comp.lang.fortran/dN_tQA1Mu-I +! +module m + implicit none + private + type, public :: t + private + integer, pointer :: m_i + contains + private + procedure, pass(this), public :: iptr => getptr + procedure, pass(this), public :: setptr + end type t +contains + subroutine setptr( this, iptr ) + !.. Argument list + class(t), intent(inout) :: this + integer, pointer, intent(inout) :: iptr + this%m_i => iptr + return + end subroutine setptr + function getptr( this ) result( iptr ) + !.. Argument list + class(t), intent(in) :: this + !.. Function result + integer, pointer :: iptr + iptr => this%m_i + end function getptr +end module m + +program p + use m, only : t + integer, pointer :: i + integer, pointer :: j + type(t) :: foo + !.. create i with some value + allocate (i, source=42) + call foo%setptr (i) + if (.not.associated (i, foo%iptr())) STOP 1 ! Gave bad result. + if (.not.associated (foo%iptr(), i)) STOP 2 ! Was OK. + j => foo%iptr() + if (.not.associated (i, j)) STOP 1! Was OK. +end program p diff --git a/Fortran/gfortran/regression/associated_target_7.f90 b/Fortran/gfortran/regression/associated_target_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associated_target_7.f90 @@ -0,0 +1,87 @@ +! { dg-do run } +! +! associated_target_7.f90: Test the fix for PR98565. +! +! Contributed by Yves Secretan +! +MODULE PS_SN0N_M + + IMPLICIT NONE + PRIVATE + + TYPE, PUBLIC :: DT_GRID_T + INTEGER :: NNT + CONTAINS + ! PASS + END TYPE DT_GRID_T + + TYPE, PUBLIC :: LM_ELEM_T + CLASS(DT_GRID_T), POINTER :: PGRID + CONTAINS + PROCEDURE, PUBLIC :: REQPGRID => LM_ELEM_REGPGRID + END TYPE LM_ELEM_T + + TYPE, PUBLIC :: PS_SN0N_T + CLASS(DT_GRID_T), POINTER :: PGRID + + CONTAINS + PROCEDURE, PUBLIC :: ASGOELE => PS_SN0N_ASGOELE + END TYPE PS_SN0N_T + + +CONTAINS + !------------------------------------------------------------------------ + !------------------------------------------------------------------------ + FUNCTION LM_ELEM_REGPGRID(SELF) RESULT(PGRID) + CLASS(DT_GRID_T), POINTER :: PGRID + CLASS(LM_ELEM_T), INTENT(IN) :: SELF + PGRID => SELF%PGRID + RETURN + END FUNCTION LM_ELEM_REGPGRID + + !------------------------------------------------------------------------ + !------------------------------------------------------------------------ + FUNCTION PS_SN0N_ASGOELE(SELF, OELE) RESULT(ERMSG) + + INTEGER :: ERMSG + CLASS(PS_SN0N_T), INTENT(IN) :: SELF + CLASS(LM_ELEM_T), INTENT(IN) :: OELE + + !CLASS(DT_GRID_T), POINTER :: PGRID + LOGICAL :: ISOK + !------------------------------------------------------------------------ + + ! ASSOCIATED with temp variable compiles + !PGRID => OELE%REQPGRID() + !ISOK = ASSOCIATED(SELF%PGRID, PGRID) + + ! ASSOCIATE without temp variable crashes with ICE + ISOK = ASSOCIATED(SELF%PGRID, OELE%REQPGRID()) + ERMSG = 0 + IF (ISOK) ERMSG = 1 + + RETURN + END FUNCTION PS_SN0N_ASGOELE + +END MODULE PS_SN0N_M + + + USE PS_SN0N_M + CLASS(PS_SN0N_T), ALLOCATABLE :: SELF + CLASS(LM_ELEM_T), ALLOCATABLE :: OELE + TYPE (DT_GRID_T), TARGET :: GRID1 = DT_GRID_T (42) + TYPE (DT_GRID_T), TARGET :: GRID2 = DT_GRID_T (84) + + ALLOCATE (PS_SN0N_T :: SELF) + ALLOCATE (LM_ELEM_T :: OELE) + SELF%PGRID => GRID1 + + OELE%PGRID => NULL () + IF (SELF%ASGOELE (OELE) .NE. 0) STOP 1 + + OELE%PGRID => GRID2 + IF (SELF%ASGOELE (OELE) .NE. 0) STOP 2 + + OELE%PGRID => GRID1 + IF (SELF%ASGOELE (OELE) .NE. 1) STOP 3 +END diff --git a/Fortran/gfortran/regression/associated_target_8.f90 b/Fortran/gfortran/regression/associated_target_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associated_target_8.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! PR fortran/100892 - procedure pointer to function returning array of size n + +module m + implicit none + procedure(func1), pointer :: my_ptr => null() +contains + subroutine test_sub + if (associated (my_ptr, func1)) print *,'associated' + end subroutine test_sub + function func1 (n) + integer, intent(in) :: n + real, dimension(n) :: func1 + func1 = 0. + end function +end module m diff --git a/Fortran/gfortran/regression/associative_1.f90 b/Fortran/gfortran/regression/associative_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/associative_1.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-O1 -fno-signed-zeros -fno-trapping-math -fdump-tree-optimized" } +! Fortran defaults to associative by default, +! with -fno-signed-zeros -fno-trapping-math this should optimize away all additions +SUBROUTINE S1(a) + REAL :: a + a=1+a-1 +END SUBROUTINE S1 +! { dg-final { scan-tree-dump-times " \\\+ " 0 "optimized" } } diff --git a/Fortran/gfortran/regression/assumed_charlen_arg_1.f90 b/Fortran/gfortran/regression/assumed_charlen_arg_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_charlen_arg_1.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! From PR 33881 + call create_watch_ss(" ") +contains + subroutine create_watch_actual(name) + character(len=1) :: name(1) + end subroutine create_watch_actual + + subroutine create_watch_ss(name,clock) + character(len=*) :: name + integer, optional :: clock + if (present(clock)) then + call create_watch_actual((/name/)) + else + call create_watch_actual((/name/)) + end if + end subroutine create_watch_ss +end diff --git a/Fortran/gfortran/regression/assumed_charlen_arg_2.f90 b/Fortran/gfortran/regression/assumed_charlen_arg_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_charlen_arg_2.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR 50585: [4.6/4.7 Regression] ICE with assumed length character array argument +! +! Contributed by Stuart Mentzer + +SUBROUTINE SUB1( str ) + IMPLICIT NONE + CHARACTER(len=*) :: str(2) + CALL SUB2( str(1)(:3) ) +END SUBROUTINE + +SUBROUTINE SUB2( str ) + IMPLICIT NONE + CHARACTER(*) :: str +END SUBROUTINE diff --git a/Fortran/gfortran/regression/assumed_charlen_dummy.f90 b/Fortran/gfortran/regression/assumed_charlen_dummy.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_charlen_dummy.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! Test the fix for PR fortran/39893. +! Original testcase provided by Deji Akingunola. +! Reduced testcase provided by Dominique d'Humieres. +! + SUBROUTINE XAUTOGET() + CHARACTER*(*) DICBA ! { dg-error "Entity with assumed character" } + DATA DICBA /"CLIP" / + RETURN + END diff --git a/Fortran/gfortran/regression/assumed_charlen_function_1.f90 b/Fortran/gfortran/regression/assumed_charlen_function_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_charlen_function_1.f90 @@ -0,0 +1,79 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! Tests the patch for PRs 25084, 20852, 25085 and 25086, all of +! which involve assumed character length functions. +! Compiled from original PR testcases, which were all contributed +! by Joost VandeVondele +! +! PR25084 - the error is not here but in any use of .IN. +! It is OK to define an assumed character length function +! in an interface but it cannot be invoked (5.1.1.5). + +MODULE M1 + TYPE SET + INTEGER CARD + END TYPE SET +END MODULE M1 + +MODULE INTEGER_SETS + INTERFACE OPERATOR (.IN.) + FUNCTION ELEMENT(X,A) ! { dg-error "cannot be assumed character length" } + USE M1 + CHARACTER(LEN=*) :: ELEMENT + INTEGER, INTENT(IN) :: X + TYPE(SET), INTENT(IN) :: A + END FUNCTION ELEMENT + END INTERFACE +END MODULE + +! 5.1.1.5 of the Standard: A function name declared with an asterisk +! char-len-param shall not be array-valued, pointer-valued, recursive +! or pure +! +! PR20852 +RECURSIVE FUNCTION TEST() ! { dg-error "cannot be recursive" } + CHARACTER(LEN=*) :: TEST + TEST = "" +END FUNCTION + +!PR25085 +FUNCTION F1() ! { dg-error "cannot be array-valued" } + CHARACTER(LEN=*), DIMENSION(10) :: F1 + F1 = "" +END FUNCTION F1 + +!PR25086 +FUNCTION F2() result(f4) ! { dg-error "cannot be pointer-valued" } + CHARACTER(LEN=*), POINTER :: f4 + f4 = "" +END FUNCTION F2 + +!PR????? +pure FUNCTION F3() ! { dg-error "cannot be pure" } + CHARACTER(LEN=*) :: F3 + F3 = "" +END FUNCTION F3 + +function not_OK (ch) + character(*) not_OK, ch ! OK in an external function + not_OK = ch +end function not_OK + + use m1 + + character(4) :: answer + character(*), external :: not_OK + integer :: i + type (set) :: z + + interface + function ext (i) + character(*) :: ext + integer :: i + end function ext + end interface + + answer = not_OK ("unOK") ! { dg-error "since it is not a dummy" } + +END + diff --git a/Fortran/gfortran/regression/assumed_charlen_function_2.f90 b/Fortran/gfortran/regression/assumed_charlen_function_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_charlen_function_2.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! Tests the fix for PR25416, which ICED in gfc_conv_function_call, when +! treating SPREAD in the statement below. +! +! Contributed by Ulrich Weigand +function bug(self,strvec) result(res) + character(*) :: self + character(*), dimension(:), intent(in) :: strvec + logical(kind=kind(.true.)) :: res + + res = any(index(strvec,spread(self,1,size(strvec))) /= 0) +end function + diff --git a/Fortran/gfortran/regression/assumed_charlen_function_3.f90 b/Fortran/gfortran/regression/assumed_charlen_function_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_charlen_function_3.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! Tests the patch for PRs 25084, 20852, 25085 and 25086, all of +! which involve assumed character length functions. +! This test checks the things that should not emit errors. +! +! Contributed by Paul Thomas +! +function is_OK (ch) ! { dg-warning "Obsolescent feature" } + character(*) is_OK, ch ! OK in an external function + is_OK = ch +end function is_OK + +! The warning occurs twice for the next line; for 'more_OK' and for 'fcn'; +function more_OK (ch, fcn) ! { dg-warning "Obsolescent feature" } + character(*) more_OK, ch + character (*), external :: fcn ! OK as a dummy argument + more_OK = fcn (ch) +end function more_OK + + character(4) :: answer + character(4), external :: is_OK, more_OK + + answer = is_OK ("isOK") ! LEN defined in calling scope + print *, answer + + answer = more_OK ("okay", is_OK) ! Actual arg has defined LEN + print *, answer + + answer = also_OK ("OKOK") + print *, answer + +contains + function also_OK (ch) + character(4) also_OK + character(*) ch + also_OK = is_OK (ch) ! LEN obtained by host association + end function also_OK +END + diff --git a/Fortran/gfortran/regression/assumed_charlen_function_4.f90 b/Fortran/gfortran/regression/assumed_charlen_function_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_charlen_function_4.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +! Tests the fix for PR28600 in which the declaration for the +! character length n, would be given the DECL_CONTEXT of 'gee' +! thus causing an ICE. +! +! Contributed by Francois-Xavier Coudert +! +subroutine bar(s, n) + integer n + character s*(n) + character*3, dimension(:), pointer :: m + s = "" +contains + subroutine gee + m(1) = s(1:3) + end subroutine gee +end subroutine bar diff --git a/Fortran/gfortran/regression/assumed_charlen_function_5.f90 b/Fortran/gfortran/regression/assumed_charlen_function_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_charlen_function_5.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! Tests the patch for PR28890, in which a reference to a legal reference +! to an assumed character length function, passed as a dummy, would +! cause an ICE. +! +! Contributed by Paul Thomas +! +character(*) function charrext (n) ! { dg-warning "Obsolescent feature" } + character(26) :: alpha ="abcdefghijklmnopqrstuvwxyz" + charrext = alpha (1:n) +end function charrext + + character(26), external :: charrext + interface + integer(4) function test(charr, i) ! { dg-warning "Obsolescent feature" } + character(*), external :: charr + integer :: i + end function test + end interface + + do j = 1 , 26 + m = test (charrext, j) + m = ctest (charrext, 27 - j) + end do +contains + integer(4) function ctest(charr, i) ! { dg-warning "Obsolescent feature" } + character(*) :: charr + integer :: i + print *, charr(i) + ctest = 1 + end function ctest +end + +integer(4) function test(charr, i) ! { dg-warning "Obsolescent feature" } + character(*) :: charr + integer :: i + print *, charr(i) + test = 1 +end function test + diff --git a/Fortran/gfortran/regression/assumed_charlen_function_6.f90 b/Fortran/gfortran/regression/assumed_charlen_function_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_charlen_function_6.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } + +! PR fortran/41615 +! Output nicer error message for invalid assumed-len character function result +! depending on what kind of contained procedure it is. + +module funcs + implicit none +contains + function assumed_len(x) ! { dg-error "module procedure" } + character(*) assumed_len + integer, intent(in) :: x + end function assumed_len +end module funcs + +module mod2 + implicit none +contains + subroutine mysub () + contains + function assumed_len(x) ! { dg-error "internal function" } + character(*) assumed_len + integer, intent(in) :: x + end function assumed_len + end subroutine +end module mod2 + +program main + implicit none +contains + function assumed_len(x) ! { dg-error "internal function" } + character(*) assumed_len + integer, intent(in) :: x + end function assumed_len +end program main diff --git a/Fortran/gfortran/regression/assumed_charlen_function_7.f90 b/Fortran/gfortran/regression/assumed_charlen_function_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_charlen_function_7.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +! Test the fix for PR49630, comment #11. +! +! Contributed by Vittorio Zecca +! +module abc + implicit none + type,abstract::abc_abstract + contains + procedure(abc_interface),deferred::abc_function + end type abc_abstract + type,extends(abc_abstract)::abc_type + contains + procedure::abc_function + end type abc_type + abstract interface + function abc_interface(this) ! { dg-error "assumed character length result" } + import abc_abstract + class(abc_abstract),intent(in)::this + character(len=*)::abc_interface + end function abc_interface + end interface +contains + function abc_function(this) + class(abc_type),intent(in)::this + character(len=5)::abc_function + abc_function="hello" + end function abc_function + subroutine do_something(this) + class(abc_abstract),intent(in)::this + print *,this%abc_function() + end subroutine do_something +end module abc diff --git a/Fortran/gfortran/regression/assumed_charlen_in_main.f90 b/Fortran/gfortran/regression/assumed_charlen_in_main.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_charlen_in_main.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! Tests the fix for PR28771 in which an assumed character length variable with an initializer could +! survive in the main program without causing an error. +! +! Contributed by Martin Reinecke +! Modified to test fix of regression reported by P.Schaffnit@access.rwth-aachen.de + +subroutine poobar () + ! The regression caused an ICE here + CHARACTER ( LEN = * ), PARAMETER :: Markers(5) = (/ "Error ", & + & "Fehler", & + & "Erreur", & + & "Stop ", & + & "Arret " /) + character(6) :: recepteur (5) + recepteur = Markers +end subroutine poobar + +! If the regression persisted, the compilation would stop before getting here +program test + character(len=*), parameter :: foo = 'test' ! Parameters must work. + character(len=4) :: bar = foo + character(len=*) :: foobar = 'This should fail' ! { dg-error "must be a dummy" } + print *, bar + call poobar () +end + diff --git a/Fortran/gfortran/regression/assumed_charlen_needed_1.f90 b/Fortran/gfortran/regression/assumed_charlen_needed_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_charlen_needed_1.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! Tests the fix for PR24557 in which the return of a +! temporary character(*) array would cause an ICE. +! +! Test case provided by Erik Edelmann +! + character(4) :: a(2) + print *, fun (a) +contains + function fun (arg) + character (*) :: arg (10) + integer :: fun(size(arg)) + fun = 1 + end function fun +end diff --git a/Fortran/gfortran/regression/assumed_charlen_parameter.f90 b/Fortran/gfortran/regression/assumed_charlen_parameter.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_charlen_parameter.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/82049 +! Original code contributed by John Harper +program ice ! f2003 + implicit none + character(*), parameter:: a = 'ice', b = '*' + character(*), parameter:: c(2) = [character(len(a)) :: a, b] + print "(2A4)",adjustr(c) +end program ice diff --git a/Fortran/gfortran/regression/assumed_charlen_sharing.f90 b/Fortran/gfortran/regression/assumed_charlen_sharing.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_charlen_sharing.f90 @@ -0,0 +1,29 @@ +! This testcase was miscompiled, because ts.cl +! in function bar was initially shared between both +! dummy arguments. Although it was later unshared, +! all expressions which copied ts.cl from bar2 +! before that used incorrectly bar1's length +! instead of bar2. +! { dg-do run } + +subroutine foo (foo1, foo2) + implicit none + integer, intent(in) :: foo2 + character(*), intent(in) :: foo1(foo2) +end subroutine foo + +subroutine bar (bar1, bar2) + implicit none + character(*), intent(in) :: bar1, bar2 + + call foo ((/ bar2 /), 1) +end subroutine bar + +program test + character(80) :: str1 + character(5) :: str2 + + str1 = 'String' + str2 = 'Strng' + call bar (str2, str1) +end program test diff --git a/Fortran/gfortran/regression/assumed_charlen_substring_1.f90 b/Fortran/gfortran/regression/assumed_charlen_substring_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_charlen_substring_1.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-O -fdump-tree-original" } +! PR 51338 - this used to ICE. +! Original test case by Bud Davis. +subroutine foo(a,b) + character(len=*) :: a + if (a(1:) /= a(1:)) call do_not_use +end subroutine foo +! { dg-final { scan-tree-dump-times "do_not_use" 0 "original" } } diff --git a/Fortran/gfortran/regression/assumed_dummy_1.f90 b/Fortran/gfortran/regression/assumed_dummy_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_dummy_1.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! Tests the fix for PRs 19358, 19477, 21211 and 21622. +! +! Note that this tests only the valid cases with explicit interfaces. +! +! Contributed by Paul Thomas +! +module global +contains + SUBROUTINE goo (x, i) + REAL, DIMENSION(i:) :: x + integer :: i + x (3) = 99.0 + END SUBROUTINE goo +end module global + +SUBROUTINE foo (x, i) + REAL, DIMENSION(i:) :: x + integer :: i + x (4) = 42.0 +END SUBROUTINE foo + +program test + use global + real, dimension(3) :: y = 0 + integer :: j = 2 + +interface + SUBROUTINE foo (x, i) + REAL, DIMENSION(i:) :: x + integer :: i + END SUBROUTINE foo +end interface + call foo (y, j) + call goo (y, j) + call roo (y, j) + if (any(y.ne.(/21.0, 99.0, 42.0/))) STOP 1 +contains + SUBROUTINE roo (x, i) + REAL, DIMENSION(i:) :: x + integer :: i + x (2) = 21.0 + END SUBROUTINE roo +end program test diff --git a/Fortran/gfortran/regression/assumed_dummy_2.f90 b/Fortran/gfortran/regression/assumed_dummy_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_dummy_2.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } + + double precision :: arr(5, 8) + call bar (arr) +contains + subroutine foo (arr) + double precision :: arr(:,:) + arr(3, 4) = 24 + end subroutine foo + subroutine bar (arr) + double precision :: arr(5,*) + call foo (arr) ! { dg-error "cannot be an assumed-size array" } + call foo (arr (:, :8)) + end subroutine +end diff --git a/Fortran/gfortran/regression/assumed_len.f90 b/Fortran/gfortran/regression/assumed_len.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_len.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! Test of the patch for PR29941, in which LEN threw an error with +! an assumed size argument. +! +! Contributed by William Mitchell +! +subroutine whatever(str) +character(len=*), dimension(*) :: str +integer :: i +i = len(str) +end subroutine whatever diff --git a/Fortran/gfortran/regression/assumed_present.f90 b/Fortran/gfortran/regression/assumed_present.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_present.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! This tests the fix for the regression PR25785, where line 7 started +! generating an assumed size error. +! Contributed by Dale Ranta + subroutine my_sio_file_write_common(data_c1) + character, intent(in), optional :: data_c1(*) + if (present(data_c1)) then + endif + end subroutine my_sio_file_write_common diff --git a/Fortran/gfortran/regression/assumed_rank_1.f90 b/Fortran/gfortran/regression/assumed_rank_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_1.f90 @@ -0,0 +1,145 @@ +! { dg-do run } +! { dg-additional-sources assumed_rank_1_c.c } +! +! PR fortran/48820 +! +! Assumed-rank tests +! + +implicit none + +interface + subroutine check_value(b, n, val) + integer :: b(..) + integer, value :: n + integer :: val(n) + end subroutine +end interface + +integer, target :: x(2:5,4:7), y(-4:4) +integer, allocatable, target :: z(:,:,:,:) +integer, allocatable :: val(:) +integer :: i + +allocate(z(1:4, -2:5, 4, 10:11)) + +if (rank(x) /= 2) STOP 1 +val = [(2*i+3, i = 1, size(x))] +x = reshape (val, shape(x)) +call foo(x, rank(x), lbound(x), ubound(x), val) +call foo2(x, rank(x), lbound(x), ubound(x), val) +call bar(x,x,.true.) +call bar(x,prsnt=.false.) + +if (rank(y) /= 1) STOP 2 +val = [(2*i+7, i = 1, size(y))] +y = reshape (val, shape(y)) +call foo(y, rank(y), lbound(y), ubound(y), val) +call foo2(y, rank(y), lbound(y), ubound(y), val) +call bar(y,y,.true.) +call bar(y,prsnt=.false.) + +if (rank(z) /= 4) STOP 3 +val = [(2*i+5, i = 1, size(z))] +z(:,:,:,:) = reshape (val, shape(z)) +call foo(z, rank(z), lbound(z), ubound(z), val) +call foo(z, rank(z), lbound(z), ubound(z), val) +call foo2(z, rank(z), lbound(z), ubound(z), val) +call bar(z,z,.true.) +call bar(z,prsnt=.false.) + +contains + subroutine bar(a,b, prsnt) + integer, pointer, optional, intent(in) :: a(..),b(..) + logical, value :: prsnt + if (.not. associated(a)) STOP 4 + if (present(b)) then + ! The following is not valid. + ! Technically, it could be allowed and might be in Fortran 2015: + ! if (.not. associated(a,b)) STOP 5 + else + if (.not. associated(a)) STOP 6 + end if + if (.not. present(a)) STOP 7 + if (prsnt .neqv. present(b)) STOP 8 + end subroutine + + ! POINTER argument - bounds as specified before + subroutine foo(a, rnk, low, high, val) + integer,pointer, intent(in) :: a(..) + integer, value :: rnk + integer, intent(in) :: low(:), high(:), val(:) + integer :: i + + + + if (rank(a) /= rnk) STOP 9 + if (size(low) /= rnk .or. size(high) /= rnk) STOP 10 + if (size(a) /= product (high - low +1)) STOP 11 + + if (rnk > 0) then + if (low(1) /= lbound(a,1)) STOP 12 + if (high(1) /= ubound(a,1)) STOP 13 + if (size (a,1) /= high(1)-low(1)+1) STOP 14 + end if + + do i = 1, rnk + if (low(i) /= lbound(a,i)) STOP 15 + if (high(i) /= ubound(a,i)) STOP 16 + if (size (a,i) /= high(i)-low(i)+1) STOP 17 + end do + call check_value (a, rnk, val) + call foo2(a, rnk, low, high, val) + end subroutine + + ! Non-pointer, non-allocatable bounds. lbound == 1 + subroutine foo2(a, rnk, low, high, val) + integer, intent(in) :: a(..) + integer, value :: rnk + integer, intent(in) :: low(:), high(:), val(:) + integer :: i + + if (rank(a) /= rnk) STOP 18 + if (size(low) /= rnk .or. size(high) /= rnk) STOP 19 + if (size(a) /= product (high - low +1)) STOP 20 + + if (rnk > 0) then + if (1 /= lbound(a,1)) STOP 21 + if (high(1)-low(1)+1 /= ubound(a,1)) STOP 22 + if (size (a,1) /= high(1)-low(1)+1) STOP 23 + end if + + do i = 1, rnk + if (1 /= lbound(a,i)) STOP 24 + if (high(i)-low(i)+1 /= ubound(a,i)) STOP 25 + if (size (a,i) /= high(i)-low(i)+1) STOP 26 + end do + call check_value (a, rnk, val) + end subroutine foo2 + + ! ALLOCATABLE argument - bounds as specified before + subroutine foo3 (a, rnk, low, high, val) + integer, allocatable, intent(in), target :: a(..) + integer, value :: rnk + integer, intent(in) :: low(:), high(:), val(:) + integer :: i + + if (rank(a) /= rnk) STOP 27 + if (size(low) /= rnk .or. size(high) /= rnk) STOP 28 + if (size(a) /= product (high - low +1)) STOP 29 + + if (rnk > 0) then + if (low(1) /= lbound(a,1)) STOP 30 + if (high(1) /= ubound(a,1)) STOP 31 + if (size (a,1) /= high(1)-low(1)+1) STOP 32 + end if + + do i = 1, rnk + if (low(i) /= lbound(a,i)) STOP 33 + if (high(i) /= ubound(a,i)) STOP 34 + if (size (a,i) /= high(i)-low(i)+1) STOP 35 + end do + call check_value (a, rnk, val) + call foo(a, rnk, low, high, val) + end subroutine +end diff --git a/Fortran/gfortran/regression/assumed_rank_10.f90 b/Fortran/gfortran/regression/assumed_rank_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_10.f90 @@ -0,0 +1,105 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/48820 +! +! Ensure that the value of scalars to assumed-rank arrays is +! copied back, if and only its pointer address could have changed. +! +program test + implicit none + type t + integer :: aa + end type t + + integer, allocatable :: iia + integer, pointer :: iip + + type(t), allocatable :: jja + type(t), pointer :: jjp + + logical :: is_present + + is_present = .true. + + allocate (iip, jjp) + + iia = 7 + iip = 7 + jja = t(88) + jjp = t(88) + + call faa(iia, jja) ! Copy back + if (iia /= 7 .and. jja%aa /= 88) STOP 1 + call fai(iia, jja) ! No copy back + if (iia /= 7 .and. jja%aa /= 88) STOP 2 + + call fpa(iip, jjp) ! Copy back + if (iip /= 7 .and. jjp%aa /= 88) STOP 3 + call fpi(iip, jjp) ! No copy back + if (iip /= 7 .and. jjp%aa /= 88) STOP 4 + + call fnn(iia, jja) ! No copy back + if (iia /= 7 .and. jja%aa /= 88) STOP 5 + call fno(iia, jja) ! No copy back + if (iia /= 7 .and. jja%aa /= 88) STOP 6 + call fnn(iip, jjp) ! No copy back + if (iip /= 7 .and. jjp%aa /= 88) STOP 7 + call fno(iip, jjp) ! No copy back + if (iip /= 7 .and. jjp%aa /= 88) STOP 8 + + is_present = .false. + + call fpa(null(), null()) ! No copy back + call fpi(null(), null()) ! No copy back + call fno(null(), null()) ! No copy back + + call fno() ! No copy back + +contains + + subroutine faa (xx1, yy1) + integer, allocatable :: xx1(..) + type(t), allocatable :: yy1(..) + if (.not. allocated (xx1)) STOP 9 + if (.not. allocated (yy1)) STOP 10 + end subroutine faa + subroutine fai (xx1, yy1) + integer, allocatable, intent(in) :: xx1(..) + type(t), allocatable, intent(in) :: yy1(..) + if (.not. allocated (xx1)) STOP 11 + if (.not. allocated (yy1)) STOP 12 + end subroutine fai + subroutine fpa (xx1, yy1) + integer, pointer :: xx1(..) + type(t), pointer :: yy1(..) + if (is_present .neqv. associated (xx1)) STOP 13 + if (is_present .neqv. associated (yy1)) STOP 14 + end subroutine fpa + + subroutine fpi (xx1, yy1) + integer, pointer, intent(in) :: xx1(..) + type(t), pointer, intent(in) :: yy1(..) + if (is_present .neqv. associated (xx1)) STOP 15 + if (is_present .neqv. associated (yy1)) STOP 16 + end subroutine fpi + + subroutine fnn(xx2,yy2) + integer :: xx2(..) + type(t) :: yy2(..) + end subroutine fnn + + subroutine fno(xx2,yy2) + integer, optional :: xx2(..) + type(t), optional :: yy2(..) + if (is_present .neqv. present (xx2)) STOP 17 + if (is_present .neqv. present (yy2)) STOP 18 + end subroutine fno +end program test + +! We should have exactly one copy back per variable +! +! { dg-final { scan-tree-dump-times "iip = .integer.kind=4. .. desc.\[0-9\]+.data;" 1 "original" } } +! { dg-final { scan-tree-dump-times "iia = .integer.kind=4. .. desc.\[0-9\]+.data;" 1 "original" } } +! { dg-final { scan-tree-dump-times "jjp = .struct t .. desc.\[0-9\]+.data;" 1 "original" } } +! { dg-final { scan-tree-dump-times "jja = .struct t .. desc.\[0-9\]+.data;" 1 "original" } } diff --git a/Fortran/gfortran/regression/assumed_rank_11.f90 b/Fortran/gfortran/regression/assumed_rank_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_11.f90 @@ -0,0 +1,52 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/48820 +! +! Assumed-rank tests +subroutine foo(X) + integer :: x(..) + codimension :: x[*] ! { dg-error "The assumed-rank array 'x' at .1. shall not have a codimension" } +end + +subroutine foo2(X) + integer, dimension(..) :: x[*] ! { dg-error "The assumed-rank array at .1. shall not have a codimension" } +end + +subroutine foo3(X) + integer, codimension[*] :: x(..) ! { dg-error "The assumed-rank array at .1. shall not have a codimension" } +end + +subroutine foo4(X) + integer, codimension[*], dimension(..) :: x ! { dg-error "The assumed-rank array at .1. shall not have a codimension" } +end + +subroutine bar(X) + integer :: x[*] + dimension :: x(..) ! { dg-error "The assumed-rank array 'x' at .1. shall not have a codimension" } +end + +subroutine foobar(X) + integer :: x + codimension :: x[*] + dimension :: x(..) ! { dg-error "The assumed-rank array 'x' at .1. shall not have a codimension" } +end + +subroutine barfoo(X) + integer :: x + dimension :: x(..) + codimension :: x[*] ! { dg-error "The assumed-rank array 'x' at .1. shall not have a codimension" } +end + +subroutine orig(X) ! { dg-error "may not have the VALUE or CODIMENSION attribute" } + integer :: x(..)[*] +end + +subroutine val1(X) + integer, value :: x(..) ! { dg-error "VALUE attribute conflicts with DIMENSION attribute" } +end + +subroutine val2(X) + integer, value :: x + dimension :: x(..) ! { dg-error "VALUE attribute conflicts with DIMENSION attribute" } +end diff --git a/Fortran/gfortran/regression/assumed_rank_12.f90 b/Fortran/gfortran/regression/assumed_rank_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_12.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/48820 +! +! Ensure that the value of scalars to assumed-rank arrays is +! copied back - and everything happens in the correct order. + +call sub(f()) +contains +subroutine sub(x) + integer, pointer :: x(..) +end subroutine sub +function f() result(res) + integer, pointer :: res +end function f +end + +! { dg-final { scan-tree-dump " = f \\(\\);.*desc.0.dtype = .*;.*desc.0.data = .void .. D.*;.*sub \\(&desc.0\\);.*D.*= .integer.kind=4. .. desc.0.data;" "original" } } + diff --git a/Fortran/gfortran/regression/assumed_rank_13.f90 b/Fortran/gfortran/regression/assumed_rank_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_13.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! +! PR fortran/57458 +! +! + + integer, pointer, asynchronous :: i(:) + integer, pointer, volatile :: j(:) + call foo(i) + call foo2(i) + call foo3(j) + call foo4(j) +contains + subroutine foo(x) + type(*), dimension(:), asynchronous :: x + end subroutine foo + subroutine foo2(x) + type(*), dimension(..), asynchronous :: x + end subroutine foo2 + subroutine foo3(x) + type(*), dimension(:), asynchronous :: x + end subroutine foo3 + subroutine foo4(x) + type(*), dimension(..), asynchronous :: x + end subroutine foo4 +end diff --git a/Fortran/gfortran/regression/assumed_rank_14.f90 b/Fortran/gfortran/regression/assumed_rank_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_14.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +! PR fortran/83184 +! + +integer n1(..) /1/ +! { dg-error "Assumed-rank array.*must be a dummy argument" "" { target *-*-* } 7 } +! { dg-error "Assumed-rank variable.*actual argument" "" { target *-*-* } 7 } + +end diff --git a/Fortran/gfortran/regression/assumed_rank_15.f90 b/Fortran/gfortran/regression/assumed_rank_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_15.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-fdec-structure" } +! +! PR fortran/83184 +! + +structure /s/ + integer n(..) /1/ ! { dg-error "must have an explicit shape" } +end structure + +end diff --git a/Fortran/gfortran/regression/assumed_rank_16.f90 b/Fortran/gfortran/regression/assumed_rank_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_16.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! +! Tests the fix for PR89363, in which the rank of unallocated or unassociated +! entities, argument associated with assumed rank dummies, was not being set. +! +! Contributed by Reinhold Bader +! +module mod_ass_rank_02 + implicit none +contains + subroutine procr(this,flag) + real, allocatable :: this(..) + logical :: flag + if (rank(this) /= 2 .or. allocated(this)) then + write(*,*) 'FAIL procr', rank(this), allocated(this) + flag = .FALSE. + end if + end subroutine procr + subroutine procs(this,flag) + real, allocatable :: this(..) + logical :: flag + if (rank(this) /= 2 .or. .not. allocated(this)) then + write(*,*) 'FAIL procs status', rank(this), allocated(this) + flag = .FALSE. + end if + if (size(this,1) /= 2 .and. size(this,2) /= 5) then + write(*,*) 'FAIL procs shape', size(this) + flag = .FALSE. + end if + end subroutine procs +end module mod_ass_rank_02 +program ass_rank_02 + use mod_ass_rank_02 + implicit none + real, allocatable :: x(:,:) + logical :: flag + + flag = .TRUE. + call procr(x,flag) + if (.not.flag) stop 1 + allocate(x(2,5)) + call procs(x,flag) + if (.not.flag) stop 2 + deallocate(x) +end program ass_rank_02 diff --git a/Fortran/gfortran/regression/assumed_rank_17.f90 b/Fortran/gfortran/regression/assumed_rank_17.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_17.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! +! Tests the fix for PR89364, in which the ubound and the last element of +! shape were note returning -1 for assumed rank entities, argument +! associated with assumed size dummies. +! +! Contributed by Reinhold Bader +! +module mod_ass_rank_04 + implicit none +contains + subroutine si(this) + real :: this(4, *) + call sa(this) + end subroutine si + subroutine sa(this) + real :: this(..) + if (rank(this) /= 2) then + stop 1 + end if + if (maxval(abs(shape(this) - [4,-1])) > 0) then + stop 2 + end if + if (ubound(this,2) /= lbound(this,2) - 2) then + stop 3 + end if + end subroutine sa +end module mod_ass_rank_04 +program ass_rank_04 + use mod_ass_rank_04 + implicit none + real :: y(9) + call si(y(2)) +end program ass_rank_04 diff --git a/Fortran/gfortran/regression/assumed_rank_18.f90 b/Fortran/gfortran/regression/assumed_rank_18.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_18.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! PR 91643 - this used to cause an ICE. +! Original test case by Gerhard Steinmetz. +program p + real :: z(3) = [1.0, 2.0, 3.0] + call g(z) +contains + subroutine g(x) + real :: x(..) + select rank (x) + rank (1) + call h(x) + end select + end + subroutine h(x) + real :: x(*) + if (x(1) /= 1.0) stop 1 + end +end diff --git a/Fortran/gfortran/regression/assumed_rank_19.f90 b/Fortran/gfortran/regression/assumed_rank_19.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_19.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! +! PR fortran/93957 +! +! Contributed by José Rui Faustino de Sousa + +function f_ice(this) result(that) bind(c) + use, intrinsic :: iso_c_binding, only: c_int + + implicit none + + integer(kind=c_int), intent(in) :: this(..) + integer(kind=c_int) :: that + + that = size(this) + return +end function f_ice + +program ice_p + use, intrinsic :: iso_c_binding, only: c_int + implicit none + + interface + function f_ice(this) result(that) bind(c) + use, intrinsic :: iso_c_binding, only: c_int + integer(kind=c_int), intent(in) :: this(..) + integer(kind=c_int) :: that + end function f_ice + end interface + + integer(kind=c_int), parameter :: n = 10 + + integer(kind=c_int) :: intp(n) + + if(size(intp)/=n) stop 1 + if(f_ice(intp)/=n) stop 2 +end program ice_p diff --git a/Fortran/gfortran/regression/assumed_rank_1_c.c b/Fortran/gfortran/regression/assumed_rank_1_c.c --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_1_c.c @@ -0,0 +1,16 @@ +/* Called by assumed_rank_1.f90. */ + +#include /* For abort(). */ + +struct array { + int *data; +}; + +void check_value_ (struct array *b, int n, int val[]) +{ + int i; + + for (i = 0; i < n; i++) + if (b->data[i] != val[i]) + abort (); +} diff --git a/Fortran/gfortran/regression/assumed_rank_2.f90 b/Fortran/gfortran/regression/assumed_rank_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_2.f90 @@ -0,0 +1,135 @@ +! { dg-do run } +! { dg-options "-fcheck=all" } +! +! PR fortran/48820 +! +! Assumed-rank tests - same as assumed_rank_1.f90, +! but with bounds checks and w/o call to C function +! + +implicit none + +integer, target :: x(2:5,4:7), y(-4:4) +integer, allocatable, target :: z(:,:,:,:) +integer, allocatable :: val(:) +integer :: i + +allocate(z(1:4, -2:5, 4, 10:11)) + +if (rank(x) /= 2) STOP 1 +val = [(2*i+3, i = 1, size(x))] +x = reshape (val, shape(x)) +call foo(x, rank(x), lbound(x), ubound(x), val) +call foo2(x, rank(x), lbound(x), ubound(x), val) +call bar(x,x,.true.) +call bar(x,prsnt=.false.) + +if (rank(y) /= 1) STOP 2 +val = [(2*i+7, i = 1, size(y))] +y = reshape (val, shape(y)) +call foo(y, rank(y), lbound(y), ubound(y), val) +call foo2(y, rank(y), lbound(y), ubound(y), val) +call bar(y,y,.true.) +call bar(y,prsnt=.false.) + +if (rank(z) /= 4) STOP 3 +val = [(2*i+5, i = 1, size(z))] +z(:,:,:,:) = reshape (val, shape(z)) +call foo(z, rank(z), lbound(z), ubound(z), val) +call foo(z, rank(z), lbound(z), ubound(z), val) +call foo2(z, rank(z), lbound(z), ubound(z), val) +call bar(z,z,.true.) +call bar(z,prsnt=.false.) + +contains + subroutine bar(a,b, prsnt) + integer, pointer, optional, intent(in) :: a(..),b(..) + logical, value :: prsnt + if (.not. associated(a)) STOP 4 + if (present(b)) then + ! The following is not valid + ! Technically, it could be allowed and might be in Fortran 2015: + ! if (.not. associated(a,b)) STOP 5 + else + if (.not. associated(a)) STOP 6 + end if + if (.not. present(a)) STOP 7 + if (prsnt .neqv. present(b)) STOP 8 + end subroutine + + ! POINTER argument - bounds as specified before + subroutine foo(a, rnk, low, high, val) + integer,pointer, intent(in) :: a(..) + integer, value :: rnk + integer, intent(in) :: low(:), high(:), val(:) + integer :: i + + + + if (rank(a) /= rnk) STOP 9 + if (size(low) /= rnk .or. size(high) /= rnk) STOP 10 + if (size(a) /= product (high - low +1)) STOP 11 + + if (rnk > 0) then + if (low(1) /= lbound(a,1)) STOP 12 + if (high(1) /= ubound(a,1)) STOP 13 + if (size (a,1) /= high(1)-low(1)+1) STOP 14 + end if + + do i = 1, rnk + if (low(i) /= lbound(a,i)) STOP 15 + if (high(i) /= ubound(a,i)) STOP 16 + if (size (a,i) /= high(i)-low(i)+1) STOP 17 + end do + call foo2(a, rnk, low, high, val) + end subroutine + + ! Non-pointer, non-allocatable bounds. lbound == 1 + subroutine foo2(a, rnk, low, high, val) + integer, intent(in) :: a(..) + integer, value :: rnk + integer, intent(in) :: low(:), high(:), val(:) + integer :: i + + if (rank(a) /= rnk) STOP 18 + if (size(low) /= rnk .or. size(high) /= rnk) STOP 19 + if (size(a) /= product (high - low +1)) STOP 20 + + if (rnk > 0) then + if (1 /= lbound(a,1)) STOP 21 + if (high(1)-low(1)+1 /= ubound(a,1)) STOP 22 + if (size (a,1) /= high(1)-low(1)+1) STOP 23 + end if + + do i = 1, rnk + if (1 /= lbound(a,i)) STOP 24 + if (high(i)-low(i)+1 /= ubound(a,i)) STOP 25 + if (size (a,i) /= high(i)-low(i)+1) STOP 26 + end do + end subroutine foo2 + + ! ALLOCATABLE argument - bounds as specified before + subroutine foo3 (a, rnk, low, high, val) + integer, allocatable, intent(in), target :: a(..) + integer, value :: rnk + integer, intent(in) :: low(:), high(:), val(:) + integer :: i + + if (rank(a) /= rnk) STOP 27 + if (size(low) /= rnk .or. size(high) /= rnk) STOP 28 + if (size(a) /= product (high - low +1)) STOP 29 + + if (rnk > 0) then + if (low(1) /= lbound(a,1)) STOP 30 + if (high(1) /= ubound(a,1)) STOP 31 + if (size (a,1) /= high(1)-low(1)+1) STOP 32 + end if + + do i = 1, rnk + if (low(i) /= lbound(a,i)) STOP 33 + if (high(i) /= ubound(a,i)) STOP 34 + if (size (a,i) /= high(i)-low(i)+1) STOP 35 + end do + call foo(a, rnk, low, high, val) + end subroutine +end diff --git a/Fortran/gfortran/regression/assumed_rank_20.f90 b/Fortran/gfortran/regression/assumed_rank_20.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_20.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! +! PR fortran/99043 +! +module assumed_rank_module + implicit none + private + + public :: rank_of_pointer_level1 +contains + subroutine rank_of_pointer_level1(ap,aa) + real, dimension(..), intent(in), pointer :: ap + real, dimension(..), intent(in), allocatable :: aa + if (rank(ap) /= 3) stop 1 + if (rank(aa) /= 3) stop 2 + call rank_of_pointer_level2(ap, aa) + end subroutine rank_of_pointer_level1 + + subroutine rank_of_pointer_level2(ap,aa) + real, dimension(..), intent(in), pointer :: ap + real, dimension(..), intent(in), allocatable :: aa + + if (rank(ap) /= 3) stop 3 + if (rank(aa) /= 3) stop 4 + end subroutine rank_of_pointer_level2 +end module assumed_rank_module + +program assumed_rank + use :: assumed_rank_module, only : rank_of_pointer_level1 + implicit none + real, dimension(:,:,:), pointer :: ap + real, dimension(:,:,:), allocatable :: aa + + ap => null() + call rank_of_pointer_level1(ap, aa) +end program assumed_rank diff --git a/Fortran/gfortran/regression/assumed_rank_21.f90 b/Fortran/gfortran/regression/assumed_rank_21.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_21.f90 @@ -0,0 +1,96 @@ +! { dg-do run } +! +! Test the fix for PR98342. +! +! Contributed by Martin Stein +! +module mod + implicit none + private + public get_tuple, sel_rank1, sel_rank2, sel_rank3 + + type, public :: tuple + integer, dimension(:), allocatable :: t +end type tuple + +contains + +function sel_rank1(x) result(s) + character(len=:), allocatable :: s + type(tuple), dimension(..), intent(in) :: x + select rank (x) + rank (0) + s = '10' + rank (1) + s = '11' + rank default + s = '?' + end select +end function sel_rank1 + +function sel_rank2(x) result(s) + character(len=:), allocatable :: s + class(tuple), dimension(..), intent(in) :: x + select rank (x) + rank (0) + s = '20' + rank (1) + s = '21' + rank default + s = '?' + end select +end function sel_rank2 + +function sel_rank3(x) result(s) + character(len=:), allocatable :: s + class(*), dimension(..), intent(in) :: x + select rank (x) + rank (0) + s = '30' + rank (1) + s = '31' + rank default + s = '?' + end select +end function sel_rank3 + +function get_tuple(t) result(a) + type(tuple) :: a + integer, dimension(:), intent(in) :: t + allocate(a%t, source=t) +end function get_tuple + +end module mod + + +program alloc_rank + use mod + implicit none + + integer, dimension(1:3) :: x + character(len=:), allocatable :: output + type(tuple) :: z + + x = [1,2,3] + z = get_tuple (x) + ! Derived type formal arg + output = sel_rank1(get_tuple (x)) ! runtime: Error in `./alloc_rank.x': + if (output .ne. '10') stop 1 + output = sel_rank1([z]) ! This worked OK + if (output .ne. '11') stop 2 + + ! Class formal arg + output = sel_rank2(get_tuple (x)) ! runtime: Error in `./alloc_rank.x': + if (output .ne. '20') stop 3 + output = sel_rank2([z]) ! This worked OK + if (output .ne. '21') stop 4 + + ! Unlimited polymorphic formal arg + output = sel_rank3(get_tuple (x)) ! runtime: Error in `./alloc_rank.x': + if (output .ne. '30') stop 5 + output = sel_rank3([z]) ! runtime: segmentation fault + if (output .ne. '31') stop 6 + + deallocate (output) + deallocate (z%t) +end program alloc_rank diff --git a/Fortran/gfortran/regression/assumed_rank_22.f90 b/Fortran/gfortran/regression/assumed_rank_22.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_22.f90 @@ -0,0 +1,169 @@ +! { dg-do run } +! { dg-additional-sources assumed_rank_22_aux.c } +! { dg-additional-options "-fdump-tree-original" } +! +! FIXME: wrong extend in array descriptor, see C file. +! { dg-output "c_assumed - 40 - OK" { xfail *-*-* } } +! { dg-output "c_assumed - 100 - OK" { xfail *-*-* } } +! +! PR fortran/94070 +! +! Contributed by Tobias Burnus +! and José Rui Faustino de Sousa +! +program main + implicit none + integer :: A(5,4,2) + integer, allocatable :: B(:,:,:) + integer :: C(5,4,-2:-1) + + interface + subroutine c_assumed (x, num) bind(C) + integer :: x(..) + integer, value :: num + end subroutine + subroutine c_allocated (x) bind(C) + integer, allocatable :: x(..) + end subroutine + end interface + + allocate (B(-1:3,4,-1:-1)) + + call caller (a) ! num=0: assumed-size + call test (b, num=20) ! full array + call test (b(:,:,0:-1), num=40) ! zero-sized array + call test (c, num=60) + call test (c(:,:,:-1), num=80) ! full-size slice + call test (c(:,:,1:-1), num=100) !zero-size array + + call test_alloc(b) + + call c_assumed (b, num=20) + call c_assumed (b(:,:,0:-1), num=40) + call c_assumed (c, num=60) + call c_assumed (c(:,:,:-1), num=80) + call c_assumed (c(:,:,1:-1), num=100) + + call c_allocated (b) +contains + subroutine caller(y) + integer :: y(-1:3,4,*) + call test(y, num=0) + call c_assumed (y, num=0) + end + subroutine test (x, num) + integer :: x(..), num + + ! SIZE (x) + if (num == 0) then + if (size (x) /= -20) stop 1 + elseif (num == 20) then + if (size (x) /= 20) stop 21 + elseif (num == 40) then + if (size (x) /= 0) stop 41 + elseif (num == 60) then + if (size (x) /= 40) stop 61 + elseif (num == 80) then + if (size (x) /= 40) stop 81 + elseif (num == 100) then + if (size (x) /= 0) stop 101 + else + stop 99 ! Invalid num + endif + + ! SIZE (x, dim=...) + if (size (x, dim=1) /= 5) stop num + 2 + if (size (x, dim=2) /= 4) stop num + 3 + + if (num == 0) then + if (size (x, dim=3) /= -1) stop 4 + elseif (num == 20) then + if (size (x, dim=3) /= 1) stop 24 + elseif (num == 40) then + if (size (x, dim=3) /= 0) stop 44 + elseif (num == 60) then + if (size (x, dim=3) /= 2) stop 64 + elseif (num == 80) then + if (size (x, dim=3) /= 2) stop 84 + elseif (num == 100) then + if (size (x, dim=3) /= 0) stop 104 + endif + + ! SHAPE (x) + if (num == 0) then + if (any (shape (x) /= [5, 4, -1])) stop 5 + elseif (num == 20) then + if (any (shape (x) /= [5, 4, 1])) stop 25 + elseif (num == 40) then + if (any (shape (x) /= [5, 4, 0])) stop 45 + elseif (num == 60) then + if (any (shape (x) /= [5, 4, 2])) stop 65 + elseif (num == 80) then + if (any (shape (x) /= [5, 4, 2])) stop 85 + elseif (num == 100) then + if (any (shape (x) /= [5, 4, 0])) stop 105 + endif + + ! LBOUND (X) + if (any (lbound (x) /= [1, 1, 1])) stop num + 6 + + ! LBOUND (X, dim=...) + if (lbound (x, dim=1) /= 1) stop num + 7 + if (lbound (x, dim=2) /= 1) stop num + 8 + if (lbound (x, dim=3) /= 1) stop num + 9 + + ! UBOUND (X) + if (num == 0) then + if (any (ubound (x) /= [5, 4, -1])) stop 11 + elseif (num == 20) then + if (any (ubound (x) /= [5, 4, 1])) stop 31 + elseif (num == 40) then + if (any (ubound (x) /= [5, 4, 0])) stop 51 + elseif (num == 60) then + if (any (ubound (x) /= [5, 4, 2])) stop 71 + elseif (num == 80) then + if (any (ubound (x) /= [5, 4, 2])) stop 91 + elseif (num == 100) then + if (any (ubound (x) /= [5, 4, 0])) stop 111 + endif + + ! UBOUND (X, dim=...) + if (ubound (x, dim=1) /= 5) stop num + 12 + if (ubound (x, dim=2) /= 4) stop num + 13 + if (num == 0) then + if (ubound (x, dim=3) /= -1) stop 14 + elseif (num == 20) then + if (ubound (x, dim=3) /= 1) stop 34 + elseif (num == 40) then + if (ubound (x, dim=3) /= 0) stop 54 + elseif (num == 60) then + if (ubound (x, dim=3) /= 2) stop 74 + elseif (num == 80) then + if (ubound (x, dim=3) /= 2) stop 94 + elseif (num == 100) then + if (ubound (x, dim=3) /= 0) stop 114 + endif + end + + subroutine test_alloc (x) + integer, allocatable :: x(..) + + if (size (x) /= 20) stop 61 + if (size (x, dim=1) /= 5) stop 62 + if (size (x, dim=2) /= 4) stop 63 + if (size (x, dim=3) /= 1) stop 64 + + if (any (shape (x) /= [5, 4, 1])) stop 65 + + if (any (lbound (x) /= [-1, 1, -1])) stop 66 + if (lbound (x, dim=1) /= -1) stop 77 + if (lbound (x, dim=2) /= 1) stop 78 + if (lbound (x, dim=3) /= -1) stop 79 + + if (any (ubound (x) /= [3, 4, -1])) stop 80 + if (ubound (x, dim=1) /= 3) stop 92 + if (ubound (x, dim=2) /= 4) stop 93 + if (ubound (x, dim=3) /= -1) stop 94 + end +end +! { dg-final { scan-tree-dump-not "_gfortran_size" "original" } } diff --git a/Fortran/gfortran/regression/assumed_rank_22_aux.c b/Fortran/gfortran/regression/assumed_rank_22_aux.c --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_22_aux.c @@ -0,0 +1,68 @@ +/* Called by assumed_rank_22.f90. */ + +#include +#include + +void +c_assumed (CFI_cdesc_t *x, int num) +{ + assert (num == 0 || num == 20 || num == 40 || num == 60 || num == 80 + || num == 100); + assert (x->elem_len == sizeof (int)); + assert (x->rank == 3); + assert (x->type == CFI_type_int32_t); + + assert (x->attribute == CFI_attribute_other); + assert (x->dim[0].lower_bound == 0); + assert (x->dim[1].lower_bound == 0); + assert (x->dim[2].lower_bound == 0); + assert (x->dim[0].extent == 5); + assert (x->dim[1].extent == 4); + if (num == 0) + assert (x->dim[2].extent == -1); + else if (num == 20) + assert (x->dim[2].extent == 1); + else if (num == 40) + { + /* FIXME: - dg-output = 'c_assumed ... OK' checked in .f90 file. */ + /* assert (x->dim[2].extent == 0); */ + if (x->dim[2].extent == 0) + __builtin_printf ("c_assumed - 40 - OK\n"); + else + __builtin_printf ("error: c_assumed num=%d: " + "x->dim[2].extent = %d != 0\n", + num, x->dim[2].extent); + } + else if (num == 60) + assert (x->dim[2].extent == 2); + else if (num == 80) + assert (x->dim[2].extent == 2); + else if (num == 100) + { + /* FIXME: - dg-output = 'c_assumed ... OK' checked in .f90 file. */ + /* assert (x->dim[2].extent == 0); */ + if (x->dim[2].extent == 0) + __builtin_printf ("c_assumed - 100 - OK\n"); + else + __builtin_printf ("error: c_assumed num=%d: " + "x->dim[2].extent = %d != 0\n", + num, x->dim[2].extent); + } + else + assert (0); +} + +void +c_allocated (CFI_cdesc_t *x) +{ + assert (x->elem_len == sizeof (int)); + assert (x->rank == 3); + assert (x->type == CFI_type_int32_t); + assert (x->attribute == CFI_attribute_allocatable); + assert (x->dim[0].lower_bound == -1); + assert (x->dim[1].lower_bound == 1); + assert (x->dim[2].lower_bound == -1); + assert (x->dim[0].extent == 5); + assert (x->dim[1].extent == 4); + assert (x->dim[2].extent == 1); +} diff --git a/Fortran/gfortran/regression/assumed_rank_23.f90 b/Fortran/gfortran/regression/assumed_rank_23.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_23.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR fortran/54753 +! TS29113:C535c +! F2018:C839 +! +module m + + interface + subroutine s1 (x, y) + class(*) :: x(..) + class(*), intent (out) :: y(..) + end subroutine + end interface + +end module diff --git a/Fortran/gfortran/regression/assumed_rank_24.f90 b/Fortran/gfortran/regression/assumed_rank_24.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_24.f90 @@ -0,0 +1,137 @@ +! { dg-do run } +! { dg-additional-options "-fcheck=all" } +module m + implicit none (external, type) +contains + subroutine cl(x) + class(*) :: x(..) + if (rank(x) /= 1) stop 1 + if (ubound(x, dim=1) /= -1) stop 2 + select rank (x) + rank (1) + select type (x) + type is (integer) + ! ok + class default + stop 3 + end select + end select + end subroutine + subroutine tp(x) + type(*) :: x(..) + if (rank(x) /= 1) stop 4 + if (ubound(x, dim=1) /= -1) stop 5 + end subroutine + + subroutine foo (ccc, ddd, sss, ttt) + integer :: sss(*), ttt(*) + class(*) :: ccc(*), ddd(*) + call cl(sss) + call tp(ttt) + call cl(ccc) + call tp(ddd) + end + + subroutine foo2 (ccc, ddd, sss, ttt, ispresent) + integer :: sss(*), ttt(*) + class(*) :: ccc(*), ddd(*) + optional :: ccc, ddd, sss, ttt + logical, value :: ispresent + if (present(ccc) .neqv. ispresent) stop 6 + if (present(ccc)) then + call cl(sss) + call tp(ttt) + call cl(ccc) + call tp(ddd) + end if + end +end + +module m2 + implicit none (external, type) +contains + subroutine cl2(x) + class(*), allocatable :: x(..) + if (rank(x) /= 1) stop 7 + if (.not. allocated (x)) & + return + if (lbound(x, dim=1) /= -2) stop 8 + if (ubound(x, dim=1) /= -1) stop 9 + if (size (x, dim=1) /= 2) stop 10 + select rank (x) + rank (1) + select type (x) + type is (integer) + ! ok + class default + stop 11 + end select + end select + end subroutine + + subroutine tp2(x) + class(*), pointer :: x(..) + if (rank(x) /= 1) stop 12 + if (.not. associated (x)) & + return + if (lbound(x, dim=1) /= -2) stop 13 + if (ubound(x, dim=1) /= -1) stop 14 + if (size (x, dim=1) /= 2) stop 15 + select rank (x) + rank (1) + select type (x) + type is (integer) + ! ok + class default + stop 16 + end select + end select + end subroutine + + subroutine foo3 (ccc, ddd, sss, ttt) + class(*), allocatable :: sss(:) + class(*), pointer :: ttt(:) + class(*), allocatable :: ccc(:) + class(*), pointer :: ddd(:) + call cl2(sss) + call tp2(ttt) + call cl2(ccc) + call tp2(ddd) + end + + subroutine foo4 (ccc, ddd, sss, ttt, ispresent) + class(*), allocatable, optional :: sss(:) + class(*), pointer, optional :: ttt(:) + class(*), allocatable, optional :: ccc(:) + class(*), pointer, optional :: ddd(:) + logical, value :: ispresent + if (present(ccc) .neqv. ispresent) stop 17 + if (present(ccc)) then + call cl2(sss) + call tp2(ttt) + call cl2(ccc) + call tp2(ddd) + end if + end +end + +use m +use m2 +implicit none (external, type) +integer :: a(1),b(1),c(1),d(1) +class(*),allocatable :: aa(:),cc(:) +class(*),pointer :: bb(:),dd(:) +call foo (a,b,c,d) +call foo2 (a,b,c,d, .true.) +call foo2 (ispresent=.false.) + +nullify(bb,dd) +call foo3 (aa,bb,cc,dd) +call foo4 (aa,bb,cc,dd, .true.) +call foo4 (ispresent=.false.) +allocate(integer :: aa(-2:-1), bb(-2:-1), cc(-2:-1), dd(-2:-1)) +call foo3 (aa,bb,cc,dd) +call foo4 (aa,bb,cc,dd, .true.) +call foo4 (ispresent=.false.) +deallocate(aa,bb,cc,dd) +end diff --git a/Fortran/gfortran/regression/assumed_rank_3.f90 b/Fortran/gfortran/regression/assumed_rank_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_3.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-options "-fcheck=bounds" } +! { dg-shouldfail "Array reference out of bounds" } +! +! PR fortran/48820 +! +! Do assumed-rank bound checking + +implicit none +integer :: a(4,4) +call bar(a) +contains + subroutine bar(x) + integer :: x(..) + print *, ubound(x,dim=3) ! << wrong dim + end subroutine +end + +! { dg-output "Fortran runtime error: Array reference out of bounds" } diff --git a/Fortran/gfortran/regression/assumed_rank_4.f90 b/Fortran/gfortran/regression/assumed_rank_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_4.f90 @@ -0,0 +1,50 @@ +! { dg-do compile } +! { dg-options "-std=f2008ts" } +! +! PR fortran/48820 +! +! Assumed-rank constraint checks and other diagnostics +! + +subroutine valid1a(x) + integer, intent(in), pointer, contiguous :: x(..) +end subroutine valid1a + +subroutine valid1(x) + integer, intent(in) :: x(..) +end subroutine valid1 + +subroutine valid2(x) + type(*) :: x +end subroutine valid2 + +subroutine foo99(x) + integer x(99) + call valid1(x) ! { dg-error "Explicit interface required" } + call valid2(x(1)) ! { dg-error "Explicit interface required" } +end subroutine foo99 + +subroutine foo(x) + integer :: x(..) + print *, ubound(x,dim=2000) ! { dg-error "is not a valid dimension index" } + call bar(x) ! { dg-error "Assumed-rank argument requires an explicit interface" } + call intnl(x) ! { dg-error "requires that the dummy argument 'x' has assumed-rank" } +contains + subroutine intnl(x) + integer :: x(:) + end subroutine intnl +end subroutine foo + +subroutine foo2(x) + integer :: x(..) + call valid3(x(:)) ! { dg-error "Assumed-rank variable x at .1. shall not have a subobject reference" } + call valid3(x+1) ! { dg-error "Assumed-rank variable x at .1. may only be used as actual argument" } +contains + subroutine valid3(y) + integer :: y(..) + end subroutine +end subroutine + +subroutine foo3() + integer :: x(..) ! { dg-error "Assumed-rank array at .1. must be a dummy argument" } +end subroutine diff --git a/Fortran/gfortran/regression/assumed_rank_5.f90 b/Fortran/gfortran/regression/assumed_rank_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_5.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +! PR fortran/48820 +! +! +subroutine foo(x) + integer :: x(..) ! { dg-error "Fortran 2018: Assumed-rank array" } +end subroutine foo diff --git a/Fortran/gfortran/regression/assumed_rank_6.f90 b/Fortran/gfortran/regression/assumed_rank_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_6.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/48820 +! +! Assumed-rank constraint checks and other diagnostics +! + +subroutine foo(x) ! { dg-error "Assumed-type variable x at .1. may not have the INTENT.OUT. attribute" } + type(*), intent(out) :: x +end subroutine + +subroutine bar(x) + integer, intent(out) :: x(..) +end subroutine bar + +subroutine foo3(y) + integer :: y(..) + y = 7 ! { dg-error "Assumed-rank variable y at .1. may only be used as actual argument" } + print *, y + 10 ! { dg-error "Assumed-rank variable y at .1. may only be used as actual argument" } + print *, y ! { dg-error "Assumed-rank variable y at .1. may only be used as actual argument" } +end subroutine + +subroutine foo2(x, y) + integer :: x(..), y(..) + call valid3(x(:)) ! { dg-error "Assumed-rank variable x at .1. shall not have a subobject reference" } +contains + subroutine valid3(y) + integer :: y(..) + end subroutine +end subroutine + +subroutine foo4(x) + integer, codimension[*] :: x(..) ! { dg-error "The assumed-rank array at .1. shall not have a codimension" } +end subroutine + +subroutine foo5(y) ! { dg-error "may not have the VALUE or CODIMENSION attribute" } + integer :: y(..)[*] +end subroutine diff --git a/Fortran/gfortran/regression/assumed_rank_7.f90 b/Fortran/gfortran/regression/assumed_rank_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_7.f90 @@ -0,0 +1,64 @@ +! { dg-do run } +! +! PR fortran/48820 +! +! Handle type/class for assumed-rank arrays +! +! FIXME: Passing a CLASS to a CLASS has to be re-enabled. +implicit none +type t + integer :: i +end type + +class(T), allocatable :: ac(:,:) +type(T), allocatable :: at(:,:) +integer :: i + +allocate(ac(2:3,2:4)) +allocate(at(2:3,2:4)) + +i = 0 +call foo(ac) +call foo(at) +call bar(ac) +call bar(at) +if (i /= 12) STOP 1 + +contains + subroutine bar(x) + type(t) :: x(..) + if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) STOP 2 + if (size(x) /= 6) STOP 3 + if (size(x,1) /= 2 .or. size(x,2) /= 3) STOP 4 + if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) STOP 5 + i = i + 1 + call foo(x) + call bar2(x) + end subroutine + subroutine bar2(x) + type(t) :: x(..) + if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) STOP 6 + if (size(x) /= 6) STOP 7 + if (size(x,1) /= 2 .or. size(x,2) /= 3) STOP 8 + if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) STOP 9 + i = i + 1 + end subroutine + subroutine foo(x) + class(t) :: x(..) + if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) STOP 10 + if (size(x) /= 6) STOP 11 + if (size(x,1) /= 2 .or. size(x,2) /= 3) STOP 12 + if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) STOP 13 + i = i + 1 + call foo2(x) +! call bar2(x) ! Passing a CLASS to a TYPE does not yet work + end subroutine + subroutine foo2(x) + class(t) :: x(..) + if (lbound(x,1) /= 1 .or. lbound(x,2) /= 1) STOP 14 + if (size(x) /= 6) STOP 15 + if (size(x,1) /= 2 .or. size(x,2) /= 3) STOP 16 + if (ubound(x,1) /= 2 .or. ubound(x,2) /= 3) STOP 17 + i = i + 1 + end subroutine +end diff --git a/Fortran/gfortran/regression/assumed_rank_8.f90 b/Fortran/gfortran/regression/assumed_rank_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_8.f90 @@ -0,0 +1,71 @@ +! { dg-do run } +! { dg-additional-sources assumed_rank_8_c.c } +! +! PR fortran/48820 +! +! Scalars to assumed-rank tests +! +program main + implicit none + + interface + subroutine check (x) + integer :: x(..) + end subroutine check + end interface + + integer, target :: ii, j + integer, allocatable :: kk + integer, pointer :: ll + ii = 489 + j = 0 + call f (ii) + call f (489) + call f () + call f (null()) + call f (kk) + if (j /= 2) STOP 1 + + j = 0 + nullify (ll) + call g (null()) + call g (ll) + call g (ii) + if (j /= 1) STOP 2 + + j = 0 + call h (kk) + kk = 489 + call h (kk) + if (j /= 1) STOP 3 + +contains + + subroutine f (x) + integer, optional :: x(..) + + if (.not. present (x)) return + if (rank (x) /= 0) STOP 1 + call check (x) + j = j + 1 + end subroutine + + subroutine g (x) + integer, pointer, intent(in) :: x(..) + + if (.not. associated (x)) return + if (rank (x) /= 0) STOP 4 + call check (x) + j = j + 1 + end subroutine + + subroutine h (x) + integer, allocatable :: x(..) + + if (.not. allocated (x)) return + if (rank (x) /= 0) STOP 2 + call check (x) + j = j + 1 + end subroutine + +end program main diff --git a/Fortran/gfortran/regression/assumed_rank_8_c.c b/Fortran/gfortran/regression/assumed_rank_8_c.c --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_8_c.c @@ -0,0 +1,25 @@ +/* Called by assumed_rank_8.f90 and assumed_rank_9.f90. */ + +#include /* For abort(). */ + +struct a { + int *dat; +}; + +struct b { + struct a _data; +}; + + +void check_ (struct a *x) +{ + if (*x->dat != 489) + abort (); +} + + +void check2_ (struct b *x) +{ + if (*x->_data.dat != 489) + abort (); +} diff --git a/Fortran/gfortran/regression/assumed_rank_9.f90 b/Fortran/gfortran/regression/assumed_rank_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_9.f90 @@ -0,0 +1,139 @@ +! { dg-do run } +! { dg-additional-sources assumed_rank_8_c.c } +! +! PR fortran/48820 +! +! Scalars to assumed-rank tests +! +program main + implicit none + + type t + integer :: i + end type t + + interface + subroutine check (x) + integer :: x(..) + end subroutine check + subroutine check2 (x) + import t + class(t) :: x(..) + end subroutine check2 + end interface + + integer :: j + + type(t), target :: y + class(t), allocatable, target :: yac + + y%i = 489 + allocate (yac) + yac%i = 489 + j = 0 + call fc() + call fc(null()) + call fc(y) + call fc(yac) + if (j /= 2) STOP 1 + + j = 0 + call gc(null()) + call gc(y) + call gc(yac) + deallocate (yac) + call gc(yac) + if (j /= 2) STOP 2 + + j = 0 + call hc(yac) + allocate (yac) + yac%i = 489 + call hc(yac) + if (j /= 1) STOP 3 + + j = 0 + call ft() + call ft(null()) + call ft(y) + call ft(yac) + if (j /= 2) STOP 4 + + j = 0 + call gt(null()) + call gt(y) + call gt(yac) + deallocate (yac) + call gt(yac) + if (j /= 2) STOP 5 + + j = 0 + call ht(yac) + allocate (yac) + yac%i = 489 + call ht(yac) + if (j /= 1) STOP 6 + +contains + + subroutine fc (x) + class(t), optional :: x(..) + + if (.not. present (x)) return + if (.not. SAME_TYPE_AS (x, yac)) STOP 7 + if (rank (x) /= 0) STOP 1 + call check2 (x) + j = j + 1 + end subroutine + + subroutine gc (x) + class(t), pointer, intent(in) :: x(..) + + if (.not. associated (x)) return + if (.not. SAME_TYPE_AS (x, yac)) STOP 8 + if (rank (x) /= 0) STOP 9 + call check2 (x) + j = j + 1 + end subroutine + + subroutine hc (x) + class(t), allocatable :: x(..) + + if (.not. allocated (x)) return + if (.not. SAME_TYPE_AS (x, yac)) STOP 10 + if (rank (x) /= 0) STOP 2 + call check2 (x) + j = j + 1 + end subroutine + + subroutine ft (x) + type(t), optional :: x(..) + + if (.not. present (x)) return + if (.not. SAME_TYPE_AS (x, yac)) STOP 11 + if (rank (x) /= 0) STOP 3 + call check2 (x) + j = j + 1 + end subroutine + + subroutine gt (x) + type(t), pointer, intent(in) :: x(..) + + if (.not. associated (x)) return + if (.not. SAME_TYPE_AS (x, yac)) STOP 12 + if (rank (x) /= 0) STOP 13 + call check2 (x) + j = j + 1 + end subroutine + + subroutine ht (x) + type(t), allocatable :: x(..) + + if (.not. allocated (x)) return + if (.not. SAME_TYPE_AS (x, yac)) STOP 14 + if (rank (x) /= 0) STOP 4 + call check2 (x) + j = j + 1 + end subroutine + +end program main diff --git a/Fortran/gfortran/regression/assumed_rank_bounds_1.f90 b/Fortran/gfortran/regression/assumed_rank_bounds_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_bounds_1.f90 @@ -0,0 +1,143 @@ +! { dg-do run } +! +! Test the behavior of lbound, ubound of shape with assumed rank arguments +! in an array context (without DIM argument). +! + +program test + + integer :: a(2:4,-2:5) + integer, allocatable :: b(:,:) + integer, pointer :: c(:,:) + character(52) :: buffer + + call foo(a) + + allocate(b(2:4,-2:5)) + call foo(b) + call bar(b) + + allocate(c(2:4,-2:5)) + call foo(c) + call baz(c) + +contains + subroutine foo(arg) + integer :: arg(..) + + !print *, lbound(arg) + !print *, id(lbound(arg)) + if (any(lbound(arg) /= [1, 1])) STOP 1 + if (any(id(lbound(arg)) /= [1, 1])) STOP 2 + buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + write(buffer,*) lbound(arg) + if (buffer /= ' 1 1') STOP 3 + buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + write(buffer,*) id(lbound(arg)) + if (buffer /= ' 1 1') STOP 4 + + !print *, ubound(arg) + !print *, id(ubound(arg)) + if (any(ubound(arg) /= [3, 8])) STOP 5 + if (any(id(ubound(arg)) /= [3, 8])) STOP 6 + buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + write(buffer,*) ubound(arg) + if (buffer /= ' 3 8') STOP 7 + buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + write(buffer,*) id(ubound(arg)) + if (buffer /= ' 3 8') STOP 8 + + !print *, shape(arg) + !print *, id(shape(arg)) + if (any(shape(arg) /= [3, 8])) STOP 9 + if (any(id(shape(arg)) /= [3, 8])) STOP 10 + buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + write(buffer,*) shape(arg) + if (buffer /= ' 3 8') STOP 11 + buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + write(buffer,*) id(shape(arg)) + if (buffer /= ' 3 8') STOP 12 + + end subroutine foo + subroutine bar(arg) + integer, allocatable :: arg(:,:) + + !print *, lbound(arg) + !print *, id(lbound(arg)) + if (any(lbound(arg) /= [2, -2])) STOP 13 + if (any(id(lbound(arg)) /= [2, -2])) STOP 14 + buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + write(buffer,*) lbound(arg) + if (buffer /= ' 2 -2') STOP 15 + buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + write(buffer,*) id(lbound(arg)) + if (buffer /= ' 2 -2') STOP 16 + + !print *, ubound(arg) + !print *, id(ubound(arg)) + if (any(ubound(arg) /= [4, 5])) STOP 17 + if (any(id(ubound(arg)) /= [4, 5])) STOP 18 + buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + write(buffer,*) ubound(arg) + if (buffer /= ' 4 5') STOP 19 + buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + write(buffer,*) id(ubound(arg)) + if (buffer /= ' 4 5') STOP 20 + + !print *, shape(arg) + !print *, id(shape(arg)) + if (any(shape(arg) /= [3, 8])) STOP 21 + if (any(id(shape(arg)) /= [3, 8])) STOP 22 + buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + write(buffer,*) shape(arg) + if (buffer /= ' 3 8') STOP 23 + buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + write(buffer,*) id(shape(arg)) + if (buffer /= ' 3 8') STOP 24 + + end subroutine bar + subroutine baz(arg) + integer, pointer :: arg(..) + + !print *, lbound(arg) + !print *, id(lbound(arg)) + if (any(lbound(arg) /= [2, -2])) STOP 25 + if (any(id(lbound(arg)) /= [2, -2])) STOP 26 + buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + write(buffer,*) lbound(arg) + if (buffer /= ' 2 -2') STOP 27 + buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + write(buffer,*) id(lbound(arg)) + if (buffer /= ' 2 -2') STOP 28 + + !print *, ubound(arg) + !print *, id(ubound(arg)) + if (any(ubound(arg) /= [4, 5])) STOP 29 + if (any(id(ubound(arg)) /= [4, 5])) STOP 30 + buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + write(buffer,*) ubound(arg) + if (buffer /= ' 4 5') STOP 31 + buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + write(buffer,*) id(ubound(arg)) + if (buffer /= ' 4 5') STOP 32 + + !print *, shape(arg) + !print *, id(shape(arg)) + if (any(shape(arg) /= [3, 8])) STOP 33 + if (any(id(shape(arg)) /= [3, 8])) STOP 34 + buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + write(buffer,*) shape(arg) + if (buffer /= ' 3 8') STOP 35 + buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + write(buffer,*) id(shape(arg)) + if (buffer /= ' 3 8') STOP 36 + + end subroutine baz + elemental function id(arg) + integer, intent(in) :: arg + integer :: id + + id = arg + end function id +end program test + diff --git a/Fortran/gfortran/regression/assumed_rank_bounds_2.f90 b/Fortran/gfortran/regression/assumed_rank_bounds_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_bounds_2.f90 @@ -0,0 +1,112 @@ +! { dg-do run } +! +! Test the behavior of lbound, ubound of shape with assumed rank arguments +! in an array context (without DIM argument). +! + +program test + + integer :: a(2:4,-2:5) + integer, allocatable :: b(:,:) + integer, allocatable :: c(:,:) + integer, pointer :: d(:,:) + character(52) :: buffer + + b = foo(a) + !print *,b(:,1) + if (any(b(:,1) /= [11, 101])) STOP 1 + buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + write(buffer,*) b(:,1) + if (buffer /= ' 11 101') STOP 2 + + !print *,b(:,2) + if (any(b(:,2) /= [3, 8])) STOP 3 + buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + write(buffer,*) b(:,2) + if (buffer /= ' 3 8') STOP 4 + + !print *,b(:,3) + if (any(b(:,3) /= [13, 108])) STOP 5 + buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + write(buffer,*) b(:,3) + if (buffer /= ' 13 108') STOP 6 + + + allocate(c(1:2,-3:6)) + b = bar(c) + !print *,b(:,1) + if (any(b(:,1) /= [11, 97])) STOP 7 + buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + write(buffer,*) b(:,1) + if (buffer /= ' 11 97') STOP 8 + + !print *,b(:,2) + if (any(b(:,2) /= [12, 106])) STOP 9 + buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + write(buffer,*) b(:,2) + if (buffer /= ' 12 106') STOP 10 + + !print *,b(:,3) + if (any(b(:,3) /= [2, 10])) STOP 11 + buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + write(buffer,*) b(:,3) + if (buffer /= ' 2 10') STOP 12 + + + allocate(d(3:5,-1:10)) + b = baz(d) + !print *,b(:,1) + if (any(b(:,1) /= [3, -1])) STOP 13 + buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + write(buffer,*) b(:,1) + if (buffer /= ' 3 -1') STOP 14 + + !print *,b(:,2) + if (any(b(:,2) /= [15, 110])) STOP 15 + buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + write(buffer,*) b(:,2) + if (buffer /= ' 15 110') STOP 16 + + !print *,b(:,3) + if (any(b(:,3) /= [13, 112])) STOP 17 + buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz' + write(buffer,*) b(:,3) + if (buffer /= ' 13 112') STOP 18 + + +contains + function foo(arg) result(res) + integer :: arg(..) + integer, allocatable :: res(:,:) + + allocate(res(rank(arg), 3)) + + res(:,1) = lbound(arg) + (/ 10, 100 /) + res(:,2) = ubound(arg) + res(:,3) = (/ 10, 100 /) + shape(arg) + + end function foo + function bar(arg) result(res) + integer, allocatable :: arg(..) + integer, allocatable :: res(:,:) + + allocate(res(-1:rank(arg)-2, 3)) + + res(:,1) = lbound(arg) + (/ 10, 100 /) + res(:,2) = (/ 10, 100 /) + ubound(arg) + res(:,3) = shape(arg) + + end function bar + function baz(arg) result(res) + integer, pointer :: arg(..) + integer, allocatable :: res(:,:) + + allocate(res(2:rank(arg)+1, 3)) + + res(:,1) = lbound(arg) + res(:,2) = (/ 10, 100 /) + ubound(arg) + res(:,3) = shape(arg) + (/ 10, 100 /) + + end function baz +end program test + diff --git a/Fortran/gfortran/regression/assumed_rank_bounds_3.f90 b/Fortran/gfortran/regression/assumed_rank_bounds_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_rank_bounds_3.f90 @@ -0,0 +1,219 @@ +! { dg-do run } +! +! This test case is inserted as a check. PR89365 inially asserted that +! gfortran was getting the bounds wrong for allocatable and pointer +! actual arguments. However, the reporter accepted that it is OK and +! this is the corrected version of his testcase, which fills a gap in +! the testsuite. +! +! Contributed by Reinhold Bader +! +module mod_ass_rank_inquiry + use, intrinsic :: iso_c_binding + implicit none + logical, parameter :: debug = .true. + integer :: error_count = 0 +! +! using inquiry functions for assumed rank objects +! + contains + subroutine foo_1(this) + real(c_float) :: this(..) + select case(rank(this)) + case(0) + if (size(shape(this)) > 0 .or. size(lbound(this)) > 0 .or. & + size(ubound(this)) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL shape / lbound / ubound' + end if + if (size(this) /= 1) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL size' + end if + case(1) + if (sum(abs(shape(this) - [4])) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL shape' + end if + if (size(this) /= 4) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL size', size(this) + end if + if (lbound(this,1) /= 1) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL lbound',lbound(this,1) + end if + if (ubound(this,1) /= 4) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL ubound',ubound(this,1) + end if + case(3) + if (sum(abs(shape(this) - [ 2, 3, 4 ])) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL shape' + end if + if (size(this) /= 2*3*4) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL size' + end if + if (sum(abs(lbound(this) - [ 1, 1, 1 ])) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL lbound' + end if + if (sum(abs(ubound(this)) - [ 2, 3, 4]) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL ubound' + end if + case default + error_count = error_count + 1 + end select + end subroutine foo_1 + subroutine foo_2(this) + real(c_float), allocatable :: this(..) + if (.not. allocated(this)) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL allocated' + end if + select case(rank(this)) + case(0) + if (size(shape(this)) > 0 .or. size(lbound(this)) > 0 .or. & + size(ubound(this)) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL shape / lbound / ubound' + end if + if (size(this) /= 1) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL size' + end if + case(1) + if (sum(abs(shape(this) - [4])) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL shape' + end if + if (size(this) /= 4) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL size', size(this) + end if + if (lbound(this,1) /= 2) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL lbound',lbound(this,1) + end if + if (ubound(this,1) /= 5) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL ubound',ubound(this,1) + end if + case(3) + if (sum(abs(shape(this) - [ 2, 3, 4 ])) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL shape' + end if + if (size(this) /= 2*3*4) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL size' + end if + if (sum(abs(lbound(this) - [ 0, -1, 1 ])) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL lbound', lbound(this) + end if + if (sum(abs(ubound(this)) - [ 2, 3, 4]) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL ubound', ubound(this) + end if + case default + error_count = error_count + 1 + end select + end subroutine foo_2 + subroutine foo_3(this) + real(c_float), pointer :: this(..) + if (.not. associated(this)) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL associated' + end if + select case(rank(this)) + case(0) + if (size(shape(this)) > 0 .or. size(lbound(this)) > 0 .or. & + size(ubound(this)) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL shape / lbound / ubound' + end if + if (size(this) /= 1) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL size' + end if + case(1) + if (sum(abs(shape(this) - [4])) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL shape' + end if + if (size(this) /= 4) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL size', size(this) + end if + if (lbound(this,1) /= 2) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL lbound',lbound(this,1) + end if + if (ubound(this,1) /= 5) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL ubound',ubound(this,1) + end if + case(3) + if (sum(abs(shape(this) - [ 2, 3, 4 ])) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL shape' + end if + if (size(this) /= 2*3*4) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL size' + end if + if (sum(abs(lbound(this) - [ 0, -1, 1 ])) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL lbound', lbound(this) + end if + if (sum(abs(ubound(this)) - [ 2, 3, 4]) > 0) then + error_count = error_count + 1 + if (debug) write(*,*) 'FAIL ubound', ubound(this) + end if + case default + error_count = error_count + 1 + end select + end subroutine foo_3 +end module mod_ass_rank_inquiry +program ass_rank_inquiry + use mod_ass_rank_inquiry + implicit none + real, allocatable :: x, y(:), z(:,:,:) + real, pointer :: xp, yp(:), zp(:,:,:) + + allocate(x, y(2:5), z(0:1,-1:1,1:4)) + allocate(xp, yp(2:5), zp(0:1,-1:1,1:4)) + + + call foo_1(x) + if (error_count > 0) write(*,*) 'FAIL: after scalar ',error_count + call foo_1(y) + if (error_count > 0) write(*,*) 'FAIL: after rank-1 ',error_count + call foo_1(z) + if (error_count > 0) write(*,*) 'FAIL: after rank-3 ',error_count + call foo_2(x) + if (error_count > 0) write(*,*) 'FAIL: after allocscalar ',error_count + call foo_2(y) + if (error_count > 0) write(*,*) 'FAIL: after allocrank-1 ',error_count + call foo_2(z) + if (error_count > 0) write(*,*) 'FAIL: after allocrank-3 ',error_count + call foo_3(xp) + if (error_count > 0) write(*,*) 'FAIL: after ptrscalar ',error_count + call foo_3(yp) + if (error_count > 0) write(*,*) 'FAIL: after ptrrank-1 ',error_count + call foo_3(zp) + if (error_count > 0) write(*,*) 'FAIL: after ptrrank-3 ',error_count + + if (error_count == 0) then + write(*,*) 'OK' + else + stop 1 + end if + + deallocate(x, y, z) + deallocate(xp, yp, zp) +end program ass_rank_inquiry diff --git a/Fortran/gfortran/regression/assumed_shape_ranks_1.f90 b/Fortran/gfortran/regression/assumed_shape_ranks_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_shape_ranks_1.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! Tests fix for PR25070; was no error for actual and assumed shape +! dummy ranks not matching. +! Contributed by Joost VandeVondele + +module addon + interface extra + function foo (y) + integer :: foo (2), y (:) + end function foo + end interface extra +end module addon + + use addon + INTEGER :: I(2,2) + I=RESHAPE((/1,2,3,4/),(/2,2/)) + CALL TST(I) ! { dg-error "Rank mismatch in argument" } + i = foo (i) ! { dg-error "Rank mismatch|Incompatible ranks" } +CONTAINS + SUBROUTINE TST(I) + INTEGER :: I(:) + write(6,*) I + END SUBROUTINE TST +END diff --git a/Fortran/gfortran/regression/assumed_shape_ranks_2.f90 b/Fortran/gfortran/regression/assumed_shape_ranks_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_shape_ranks_2.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! Tests the fix for the regression PR26716. +! Test contributed by Martin Reinecke +! +module mod1 + implicit none + + interface foo + module procedure foo1, foo2 + end interface + +contains + + subroutine foo1(bar, i) + real bar + integer i + i = 1 + end subroutine + + subroutine foo2(bar, i) + real bar(3) + integer i + i = 2 + end subroutine + +end module mod1 + + use mod1 + implicit none + + real bar(3) + integer i + + i = 0 + call foo (1e0, i) + if (i .ne. 1) STOP 1 + + i = 0 + call foo (bar(1), i) + if (i .ne. 1) STOP 2 + + i = 0 + call foo (bar, i) + if (i .ne. 2) STOP 3 +end diff --git a/Fortran/gfortran/regression/assumed_size_1.f90 b/Fortran/gfortran/regression/assumed_size_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_size_1.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! +! PR 54189: ICE (segfault) with invalid assumed-size dummy +! +! Contributed by Tobias Burnus + + implicit none + procedure(g), pointer :: x ! { dg-error "must be a dummy argument" } + x => g + +contains + + function g() ! { dg-error "must be a dummy argument" } + integer :: g(*) + end function + +end diff --git a/Fortran/gfortran/regression/assumed_size_2.f90 b/Fortran/gfortran/regression/assumed_size_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_size_2.f90 @@ -0,0 +1,4 @@ +! { dg-do compile } +subroutine foo(a) + dimension a(*,*) ! { dg-error "Bad specification for assumed size array" } +end diff --git a/Fortran/gfortran/regression/assumed_size_dt_dummy.f90 b/Fortran/gfortran/regression/assumed_size_dt_dummy.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_size_dt_dummy.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! PR20853 - No array size information for initializer. +! PR24440 - patch for PR20853 caused a segfault at line 12. +! Contributed by Joost VandeVondele +MODULE TEST + TYPE init + INTEGER :: I=0 + END TYPE init +CONTAINS + SUBROUTINE try (A, B) ! { dg-error "cannot have a default initializer" } + TYPE(init), DIMENSION(*), INTENT(OUT) :: A + TYPE(init) , INTENT(OUT) :: B ! PR24440 => segfault + END SUBROUTINE try +END MODULE TEST + +end diff --git a/Fortran/gfortran/regression/assumed_size_refs_1.f90 b/Fortran/gfortran/regression/assumed_size_refs_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_size_refs_1.f90 @@ -0,0 +1,64 @@ +!==================assumed_size_refs_1.f90================== +! { dg-do compile } +! Test the fix for PR25029, PR21256 in which references to +! assumed size arrays without an upper bound to the last +! dimension were generating no error. The first version of +! the patch failed in DHSEQR, as pointed out by Toon Moene +! in http://gcc.gnu.org/ml/fortran/2005-12/msg00466.html +! +! Contributed by Paul Thomas +! +program assumed_size_test_1 + implicit none + real a(2, 4) + + a = 1.0 + call foo (a) + +contains + subroutine foo(m) + real, target :: m(1:2, *) + real x(2,2,2) + real, external :: bar + real, pointer :: p(:,:), q(:,:) + allocate (q(2,2)) + +! PR25029 + p => m ! { dg-error "upper bound in the last dimension" } + q = m ! { dg-error "upper bound in the last dimension" } + +! PR21256( and PR25060) + m = 1 ! { dg-error "upper bound in the last dimension" } + + m(1,1) = 2.0 + x = bar (m) + x = fcn (m) ! { dg-error "upper bound in the last dimension" } + m(:, 1:2) = fcn (q) + call sub (m, x) ! { dg-error "upper bound in the last dimension" } + call sub (m(1:2, 1:2), x) ! { dg-error "Incompatible ranks in elemental procedure" } + print *, p + + call DHSEQR(x) + + end subroutine foo + + elemental function fcn (a) result (b) + real, intent(in) :: a + real :: b + b = 2.0 * a + end function fcn + + elemental subroutine sub (a, b) + real, intent(inout) :: a, b + b = 2.0 * a + end subroutine sub + + SUBROUTINE DHSEQR( WORK ) + REAL WORK( * ) + EXTERNAL DLARFX + INTRINSIC MIN + WORK( 1 ) = 1.0 + CALL DLARFX( MIN( 1, 8 ), WORK ) + END SUBROUTINE DHSEQR + +end program assumed_size_test_1 diff --git a/Fortran/gfortran/regression/assumed_size_refs_2.f90 b/Fortran/gfortran/regression/assumed_size_refs_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_size_refs_2.f90 @@ -0,0 +1,44 @@ +!==================assumed_size_refs_1.f90================== +! { dg-do compile } +! Test the fix for PR20868 & PR20870 in which references to +! assumed size arrays without an upper bound to the last +! dimension were generating no error. +! +! Contributed by Paul Thomas +! +program assumed_size_test_2 + implicit none + real a(2, 4) + + a = 1.0 + call foo (a) + +contains + subroutine foo(m) + real, target :: m(1:2, *) + real x(2,2,2) + real, pointer :: q(:,:) + integer :: i + allocate (q(2,2)) + + q = cos (1.0 + abs(m)) ! { dg-error "upper bound in the last dimension" } + + x = reshape (m, (/2,2,2/)) ! { dg-error "upper bound in the last dimension" } + +! PR20868 + print *, ubound (m) ! { dg-error "upper bound in the last dimension" } + print *, lbound (m) + +! PR20870 + print *, size (m) ! { dg-error "upper bound in the last dimension" } + +! Check non-array valued intrinsics + print *, ubound (m, 1) + print *, ubound (m, 2) ! { dg-error "not a valid dimension index" } + + i = 2 + print *, size (m, i) + + end subroutine foo + +end program assumed_size_test_2 diff --git a/Fortran/gfortran/regression/assumed_size_refs_3.f90 b/Fortran/gfortran/regression/assumed_size_refs_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_size_refs_3.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! Tests the fix for PR25951, a regression caused by the assumed +! size patch. +! Test case provided by Mark Hesselink +PROGRAM loc_1 + integer i(10) + call f (i) +CONTAINS + SUBROUTINE f (x) + INTEGER, DIMENSION(*) :: x + INTEGER :: address +! The next line would cause: +! Error: The upper bound in the last dimension must appear in the +! reference to the assumed size array 'x' at (1) + address=LOC(x) + END SUBROUTINE f +END PROGRAM loc_1 \ No newline at end of file diff --git a/Fortran/gfortran/regression/assumed_size_refs_4.f90 b/Fortran/gfortran/regression/assumed_size_refs_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_size_refs_4.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! PR fortran/34759 +! gfortran was before rejecting passing an assumed-size array +! where the last dimension was specified. +! +! Test case provided by Dick Hendickson. +! + subroutine j_assumed_size(A,N) + dimension A(10,11,12,*), k(3), l(3), m(4) + m = shape(A(:,:,:,:N)) ! OK + l = shape(A(:,:,:,3)) ! OK + m = shape(A(:,:,:,:)) ! { dg-error "upper bound of assumed size array" } + m = shape(A) ! { dg-error "must not be an assumed size array" } + end diff --git a/Fortran/gfortran/regression/assumed_type_1.f90 b/Fortran/gfortran/regression/assumed_type_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_type_1.f90 @@ -0,0 +1,54 @@ +! { dg-do compile } +! +! PR fortran/48820 +! +! Test TYPE(*) +! +! Based on a contributed test case by Walter Spector +! +module mpi_interface + implicit none + + interface mpi_send + subroutine MPI_Send (buf, count, datatype, dest, tag, comm, ierr) + type(*), intent(in) :: buf(:) + integer, intent(in) :: count + integer, intent(in) :: datatype + integer, intent(in) :: dest + integer, intent(in) :: tag + integer, intent(in) :: comm + integer, intent(out):: ierr + end subroutine + end interface + + interface mpi_send2 + subroutine MPI_Send2 (buf, count, datatype, dest, tag, comm, ierr) + type(*), intent(in) :: buf(*) + integer, intent(in) :: count + integer, intent(in) :: datatype + integer, intent(in) :: dest + integer, intent(in) :: tag + integer, intent(in) :: comm + integer, intent(out):: ierr + end subroutine + end interface + +end module + +use mpi_interface + real :: a(3) + integer :: b(3) + call foo(a) + call foo(b) + call foo(a(1:2)) + call foo(b(1:2)) + call MPI_Send(a, 1, 1,1,1,j,i) + call MPI_Send(b, 1, 1,1,1,j,i) + call MPI_Send2(a, 1, 1,1,1,j,i) + call MPI_Send2(b, 1, 1,1,1,j,i) +contains + subroutine foo(x) + type(*):: x(*) + call MPI_Send2(x, 1, 1,1,1,j,i) + end +end diff --git a/Fortran/gfortran/regression/assumed_type_10.f90 b/Fortran/gfortran/regression/assumed_type_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_type_10.f90 @@ -0,0 +1,49 @@ +! { dg-do compile } +! { dg-options "-O0 -fdump-tree-original" } +! PR 61968 - this used to generate invalid assembler containing +! TYPE(*). + +module testmod + use iso_c_binding, only: c_size_t, c_int32_t, c_int64_t + implicit none + + interface test + procedure :: test_32 + procedure :: test_array + end interface test + + interface + subroutine test_lib (a, len) bind(C, name="xxx") + use iso_c_binding, only: c_size_t + type(*), dimension(*) :: a + integer(c_size_t), value :: len + end subroutine + end interface + +contains + + subroutine test_32 (a, len) + type(*), dimension(*) :: a + integer(c_int32_t), value :: len + call test_lib (a, int (len, kind=c_size_t)) + end subroutine + + subroutine test_array (a) + use iso_c_binding, only: c_size_t + class(*), dimension(..), target :: a + select rank (a) + rank (1) + call test_lib (a, int (sizeof (a), kind=c_size_t)) + end select + end subroutine + +end module + + subroutine test_32_ (a, len) + use iso_c_binding, only: c_int32_t + use testmod + type(*), dimension(*) :: a + integer(c_int32_t), value :: len + call test (a, len) + end subroutine +! { dg-final { scan-tree-dump-not "! __vtype_TYPE\\(*\\)" "original" } } diff --git a/Fortran/gfortran/regression/assumed_type_11.f90 b/Fortran/gfortran/regression/assumed_type_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_type_11.f90 @@ -0,0 +1,49 @@ +! { dg-do compile } +! { dg-options "-O3 -fdump-tree-original" } +! PR 61968 - this used to generate invalid assembler containing +! TYPE(*). + +module testmod + use iso_c_binding, only: c_size_t, c_int32_t, c_int64_t + implicit none + + interface test + procedure :: test_32 + procedure :: test_array + end interface test + + interface + subroutine test_lib (a, len) bind(C, name="xxx") + use iso_c_binding, only: c_size_t + type(*), dimension(*) :: a + integer(c_size_t), value :: len + end subroutine + end interface + +contains + + subroutine test_32 (a, len) + type(*), dimension(*) :: a + integer(c_int32_t), value :: len + call test_lib (a, int (len, kind=c_size_t)) + end subroutine + + subroutine test_array (a) + use iso_c_binding, only: c_size_t + class(*), dimension(..), target :: a + select rank (a) + rank (1) + call test_lib (a, int (sizeof (a), kind=c_size_t)) + end select + end subroutine + +end module + + subroutine test_32_ (a, len) + use iso_c_binding, only: c_int32_t + use testmod + type(*), dimension(*) :: a + integer(c_int32_t), value :: len + call test (a, len) + end subroutine +! { dg-final { scan-tree-dump-not "! __vtype_TYPE\\(*\\)" "original" } } diff --git a/Fortran/gfortran/regression/assumed_type_12.f90 b/Fortran/gfortran/regression/assumed_type_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_type_12.f90 @@ -0,0 +1,34 @@ +! PR fortran/102086 + +implicit none (type, external) +contains +subroutine as(a) + type(*) :: a(:,:) +end +subroutine ar(b) + type(*) :: b(..) +end +subroutine bar(x,y) + type(*) :: x + type(*) :: y(3,*) + call as(x) ! { dg-error "Rank mismatch in argument 'a' at .1. \\(rank-2 and scalar\\)" } + call ar(x) ! { dg-error "Assumed-type actual argument at .1. corresponding to assumed-rank dummy argument 'b' must be assumed-shape or assumed-rank" } + call ar(y) ! { dg-error "Assumed-type actual argument at .1. corresponding to assumed-rank dummy argument 'b' must be assumed-shape or assumed-rank" } + call as(y(1,3)) ! { dg-error "Assumed-type variable y at .1. shall not have a subobject reference" } + call ar(y(1,3)) ! { dg-error "Assumed-type variable y at .1. shall not have a subobject reference" } + call as(y(1:1,3:3)) ! { dg-error "Assumed-type variable y at .1. shall not have a subobject reference" } + call ar(y(1:1,3:3)) ! { dg-error "Assumed-type variable y at .1. shall not have a subobject reference" } +end + +subroutine okayish(x,y,z) + type(*) :: x(:) + type(*) :: y(:,:) + type(*) :: z(..) + call as(x) ! { dg-error "Rank mismatch in argument 'a' at .1. \\(rank-2 and rank-1\\)" } + call as(y) + call as(z) ! { dg-error "The assumed-rank array at .1. requires that the dummy argument 'a' has assumed-rank" } + call ar(x) + call ar(y) + call ar(z) +end +end diff --git a/Fortran/gfortran/regression/assumed_type_13.c b/Fortran/gfortran/regression/assumed_type_13.c --- /dev/null +++ b/Fortran/gfortran/regression/assumed_type_13.c @@ -0,0 +1,26 @@ +#include + +void +test_c (CFI_cdesc_t *x, size_t n, int num) +{ + if (!x->base_addr) + __builtin_abort (); + if (x->version != CFI_VERSION) + __builtin_abort (); + if (x->rank != 1) + __builtin_abort (); + if (x->attribute != CFI_attribute_other) + __builtin_abort (); + if (x->dim[0].lower_bound != 0) + __builtin_abort (); + if (x->dim[0].extent != 3) + __builtin_abort (); + + if (x->elem_len != n || x->dim[0].sm != n) + __builtin_abort (); + + if (num == 1 && x->type != CFI_type_int16_t) + __builtin_abort (); + if (num == 2 && x->type != CFI_type_double_Complex) + __builtin_abort (); +} diff --git a/Fortran/gfortran/regression/assumed_type_13.f90 b/Fortran/gfortran/regression/assumed_type_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_type_13.f90 @@ -0,0 +1,66 @@ +! { dg-do run } +! { dg-additional-sources assumed_type_13.c } + +use iso_c_binding, only: c_size_t, c_int +implicit none (type, external) + +interface + subroutine test_c (x, n, num) bind (C) + import :: c_size_t, c_int + integer(c_size_t), value :: n + integer(c_int), value :: num + type(*) :: x(:) + end subroutine test_c +end interface + +complex(8) :: b(3) + +call test_c ([1_2, 2_2, 3_2], sizeof(1_2), num=1) +call test_c (b, sizeof(b(1)), num=2) +call outer_bc ([1_2, 2_2, 3_2], sizeof(1_2), num=1) +call outer_bc (b, sizeof(b(1)), num=2) +call outer_f ([1_2, 2_2, 3_2], sizeof(1_2), num=1) +call outer_f (b, sizeof(b(1)), num=2) + +contains + +subroutine outer_bc (x, n, num) bind(C) + integer(c_size_t), value :: n + integer(c_int), value :: num + type(*) :: x(:) + ! print *,sizeof(x)/size(x), n + if (sizeof(x)/size(x) /= n) error stop 1 + call inner_bc (x, n, num) + call inner_f (x, n, num) + call test_c (x, n, num) +end + +subroutine outer_f (x, n, num) + integer(c_size_t), value :: n + integer(c_int), value :: num + type(*) :: x(:) + ! print *,sizeof(x)/size(x), n + if (sizeof(x)/size(x) /= n) error stop 1 + call inner_f (x, n, num) + call inner_bc (x, n, num) + call test_c (x, n, num) +end + +subroutine inner_bc(x, n, num) bind(C) + integer(c_size_t), value :: n + integer(c_int), value :: num + type(*) :: x(:) + ! print *,sizeof(x)/size(x), n + if (sizeof(x)/size(x) /= n) error stop 2 + call test_c (x, n, num) +end + +subroutine inner_f(x, n, num) + integer(c_size_t), value :: n + integer(c_int), value :: num + type(*) :: x(:) + ! print *,sizeof(x)/size(x), n + if (sizeof(x)/size(x) /= n) error stop 3 + call test_c (x, n, num) +end +end diff --git a/Fortran/gfortran/regression/assumed_type_14.f90 b/Fortran/gfortran/regression/assumed_type_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_type_14.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! PR fortran/104573 - ICE in resolve_structure_cons +! Contributed by G.Steinmetz +! Contributed by M.Morin + +program p + type t + end type + type(*), parameter :: x = t() ! { dg-error "Assumed type of variable" } + print *, x +end + +subroutine s + type t + integer :: a + end type + character(3), parameter :: x = t(2) ! { dg-error "Cannot convert" } + character(3), parameter :: y = x ! { dg-error "Unclassifiable statement" } + print *, y +end + +! { dg-prune-output "Cannot convert" } diff --git a/Fortran/gfortran/regression/assumed_type_16.f90 b/Fortran/gfortran/regression/assumed_type_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_type_16.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-additional-options "-std=f2008" } +! +! PR fortran/104143 +! + interface + subroutine foo(x) + type(*) :: x(*) ! { dg-error "Fortran 2018: Assumed type" } + end + end interface + integer :: a + call foo(a) ! { dg-error "Type mismatch in argument" } + call foo((a)) ! { dg-error "Type mismatch in argument" } +end diff --git a/Fortran/gfortran/regression/assumed_type_17.f90 b/Fortran/gfortran/regression/assumed_type_17.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_type_17.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-additional-options "-std=f2018 -fdump-tree-original" } +! +! PR fortran/104143 +! + interface + subroutine foo(x) + type(*) :: x(*) + end + end interface + integer :: a + call foo(a) + call foo((a)) +end + +! { dg-final { scan-tree-dump-times "foo \\(&a\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = a;" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&D.\[0-9\]+\\);" 1 "original" } } diff --git a/Fortran/gfortran/regression/assumed_type_2.f90 b/Fortran/gfortran/regression/assumed_type_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_type_2.f90 @@ -0,0 +1,177 @@ +! { dg-do compile } +! { dg-options "-O0 -fdump-tree-original" } +! +! PR fortran/48820 +! +! Test TYPE(*) +! + +module mod + use iso_c_binding, only: c_loc, c_ptr, c_bool + implicit none + interface my_c_loc + function my_c_loc1(x) bind(C) + import c_ptr + type(*) :: x + type(c_ptr) :: my_c_loc1 + end function + function my_c_loc2(x) bind(C) + import c_ptr + type(*) :: x(*) + type(c_ptr) :: my_c_loc2 + end function + end interface my_c_loc +contains + subroutine sub_scalar (arg1, presnt) + type(*), target, optional :: arg1 + logical :: presnt + type(c_ptr) :: cpt + if (presnt .neqv. present (arg1)) STOP 1 + cpt = c_loc (arg1) + end subroutine sub_scalar + + subroutine sub_array_shape (arg2, lbounds, ubounds) + type(*), target :: arg2(:,:) + type(c_ptr) :: cpt + integer :: lbounds(2), ubounds(2) + if (any (lbound(arg2) /= lbounds)) STOP 2 + if (any (ubound(arg2) /= ubounds)) STOP 3 + if (any (shape(arg2) /= ubounds-lbounds+1)) STOP 4 + if (size(arg2) /= product (ubounds-lbounds+1)) STOP 5 + if (rank (arg2) /= 2) STOP 6 +! if (.not. is_continuous (arg2)) STOP 7 !<< Not yet implemented +! cpt = c_loc (arg2) ! << FIXME: Valid since TS29113 + call sub_array_assumed (arg2) + end subroutine sub_array_shape + + subroutine sub_array_assumed (arg3) + type(*), target :: arg3(*) + type(c_ptr) :: cpt + cpt = c_loc (arg3) + end subroutine sub_array_assumed +end module + +use mod +use iso_c_binding, only: c_int, c_null_ptr +implicit none +type t1 + integer :: a +end type t1 +type :: t2 + sequence + integer :: b +end type t2 +type, bind(C) :: t3 + integer(c_int) :: c +end type t3 + +integer :: scalar_int +real, allocatable :: scalar_real_alloc +character, pointer :: scalar_char_ptr + +integer :: array_int(3) +real, allocatable :: array_real_alloc(:,:) +character, pointer :: array_char_ptr(:,:) + +type(t1) :: scalar_t1 +type(t2), allocatable :: scalar_t2_alloc +type(t3), pointer :: scalar_t3_ptr + +type(t1) :: array_t1(4) +type(t2), allocatable :: array_t2_alloc(:,:) +type(t3), pointer :: array_t3_ptr(:,:) + +class(t1), allocatable :: scalar_class_t1_alloc +class(t1), pointer :: scalar_class_t1_ptr + +class(t1), allocatable :: array_class_t1_alloc(:,:) +class(t1), pointer :: array_class_t1_ptr(:,:) + +scalar_char_ptr => null() +scalar_t3_ptr => null() + +call sub_scalar (presnt=.false.) +call sub_scalar (scalar_real_alloc, .false.) +call sub_scalar (scalar_char_ptr, .false.) +call sub_scalar (null (), .false.) +call sub_scalar (scalar_t2_alloc, .false.) +call sub_scalar (scalar_t3_ptr, .false.) + +allocate (scalar_real_alloc, scalar_char_ptr, scalar_t3_ptr) +allocate (scalar_class_t1_alloc, scalar_class_t1_ptr, scalar_t2_alloc) +allocate (array_real_alloc(3:5,2:4), array_char_ptr(-2:2,2)) +allocate (array_t2_alloc(3:5,2:4), array_t3_ptr(-2:2,2)) +allocate (array_class_t1_alloc(3,3), array_class_t1_ptr(4,4)) + +call sub_scalar (scalar_int, .true.) +call sub_scalar (scalar_real_alloc, .true.) +call sub_scalar (scalar_char_ptr, .true.) +call sub_scalar (array_int(2), .true.) +call sub_scalar (array_real_alloc(3,2), .true.) +call sub_scalar (array_char_ptr(0,1), .true.) +call sub_scalar (scalar_t1, .true.) +call sub_scalar (scalar_t2_alloc, .true.) +call sub_scalar (scalar_t3_ptr, .true.) +call sub_scalar (array_t1(2), .true.) +call sub_scalar (array_t2_alloc(3,2), .true.) +call sub_scalar (array_t3_ptr(0,1), .true.) +call sub_scalar (array_class_t1_alloc(2,1), .true.) +call sub_scalar (array_class_t1_ptr(3,3), .true.) + +call sub_array_assumed (array_int) +call sub_array_assumed (array_real_alloc) +call sub_array_assumed (array_char_ptr) +call sub_array_assumed (array_t1) +call sub_array_assumed (array_t2_alloc) +call sub_array_assumed (array_t3_ptr) +call sub_array_assumed (array_class_t1_alloc) +call sub_array_assumed (array_class_t1_ptr) + +call sub_array_shape (array_real_alloc, [1,1], shape(array_real_alloc)) +call sub_array_shape (array_char_ptr, [1,1], shape(array_char_ptr)) +call sub_array_shape (array_t2_alloc, [1,1], shape(array_t2_alloc)) +call sub_array_shape (array_t3_ptr, [1,1], shape(array_t3_ptr)) +call sub_array_shape (array_class_t1_alloc, [1,1], shape(array_class_t1_alloc)) +call sub_array_shape (array_class_t1_ptr, [1,1], shape(array_class_t1_ptr)) + +deallocate (scalar_char_ptr, scalar_class_t1_ptr, array_char_ptr) +deallocate (array_class_t1_ptr, array_t3_ptr) + +end + +! { dg-final { scan-tree-dump-times "sub_scalar .0B," 2 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .scalar_real_alloc," 2 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .scalar_char_ptr," 2 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .scalar_t2_alloc," 2 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .scalar_t3_ptr" 2 "original" } } + +! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_int," 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_t1," 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .&array_int.1.," 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .&scalar_t1," 1 "original" } } + +! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(real.kind=4..0:. . restrict\\) array_real_alloc.data" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .\\(character.kind=1..1:1. .\\) .array_char_ptr.data" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .&\\(.\\(struct t2.0:. . restrict\\) array_t2_alloc.data" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t3 .\\) .array_t3_ptr.data" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) array_class_t1_alloc._data.data" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_scalar .\\(struct t1 .\\) \\(array_class_t1_ptr._data.dat" 1 "original" } } + +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(D" 4 "original" } } +! { dg-final { scan-tree-dump-times " = _gfortran_internal_pack \\(&parm" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(&array_int\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(real\\(kind=4\\).0:. . restrict\\) array_real_alloc.data" 1 "original" } } +! { dg-final { scan-tree-dump-times " = _gfortran_internal_pack \\(&array_char_ptr\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "\\.data = \\(void .\\) &array_t1.0.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. .\\) parm" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t2.0:. . restrict\\) array_t2_alloc.data\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. . restrict\\) array_class_t1_alloc._data.data\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_assumed \\(\\(struct t1.0:. .\\) array_class_t1_ptr._data.data\\);" 0 "original" } } + +! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_real_alloc," 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_char_ptr," 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_t2_alloc," 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_t3_ptr," 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_class_t1_alloc._data," 1 "original" } } +! { dg-final { scan-tree-dump-times "sub_array_shape \\(&array_class_t1_ptr._data," 1 "original" } } + diff --git a/Fortran/gfortran/regression/assumed_type_2a.f90 b/Fortran/gfortran/regression/assumed_type_2a.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_type_2a.f90 @@ -0,0 +1,139 @@ +! { dg-do run } +! +! PR fortran/48820 +! +! Test TYPE(*) +! + +module mod + use iso_c_binding, only: c_loc, c_ptr, c_bool + implicit none + interface my_c_loc + function my_c_loc1(x) bind(C) + import c_ptr + type(*) :: x + type(c_ptr) :: my_c_loc1 + end function + function my_c_loc2(x) bind(C) + import c_ptr + type(*) :: x(*) + type(c_ptr) :: my_c_loc2 + end function + end interface my_c_loc +contains + subroutine sub_scalar (arg1, presnt) + type(*), target, optional :: arg1 + logical :: presnt + type(c_ptr) :: cpt + if (presnt .neqv. present (arg1)) STOP 1 + cpt = c_loc (arg1) + end subroutine sub_scalar + + subroutine sub_array_shape (arg2, lbounds, ubounds) + type(*), target :: arg2(:,:) + type(c_ptr) :: cpt + integer :: lbounds(2), ubounds(2) + if (any (lbound(arg2) /= lbounds)) STOP 2 + if (any (ubound(arg2) /= ubounds)) STOP 3 + if (any (shape(arg2) /= ubounds-lbounds+1)) STOP 4 + if (size(arg2) /= product (ubounds-lbounds+1)) STOP 5 + if (rank (arg2) /= 2) STOP 6 +! if (.not. is_continuous (arg2)) STOP 7 !<< Not yet implemented +! cpt = c_loc (arg2) ! << FIXME: Valid since TS29113 + call sub_array_assumed (arg2) + end subroutine sub_array_shape + + subroutine sub_array_assumed (arg3) + type(*), target :: arg3(*) + type(c_ptr) :: cpt + cpt = c_loc (arg3) + end subroutine sub_array_assumed +end module + +use mod +use iso_c_binding, only: c_int, c_null_ptr +implicit none +type t1 + integer :: a +end type t1 +type :: t2 + sequence + integer :: b +end type t2 +type, bind(C) :: t3 + integer(c_int) :: c +end type t3 + +integer :: scalar_int +real, allocatable :: scalar_real_alloc +character, pointer :: scalar_char_ptr + +integer :: array_int(3) +real, allocatable :: array_real_alloc(:,:) +character, pointer :: array_char_ptr(:,:) + +type(t1) :: scalar_t1 +type(t2), allocatable :: scalar_t2_alloc +type(t3), pointer :: scalar_t3_ptr + +type(t1) :: array_t1(4) +type(t2), allocatable :: array_t2_alloc(:,:) +type(t3), pointer :: array_t3_ptr(:,:) + +class(t1), allocatable :: scalar_class_t1_alloc +class(t1), pointer :: scalar_class_t1_ptr + +class(t1), allocatable :: array_class_t1_alloc(:,:) +class(t1), pointer :: array_class_t1_ptr(:,:) + +scalar_char_ptr => null() +scalar_t3_ptr => null() + +call sub_scalar (presnt=.false.) +call sub_scalar (scalar_real_alloc, .false.) +call sub_scalar (scalar_char_ptr, .false.) +call sub_scalar (null (), .false.) +call sub_scalar (scalar_t2_alloc, .false.) +call sub_scalar (scalar_t3_ptr, .false.) + +allocate (scalar_real_alloc, scalar_char_ptr, scalar_t3_ptr) +allocate (scalar_class_t1_alloc, scalar_class_t1_ptr, scalar_t2_alloc) +allocate (array_real_alloc(3:5,2:4), array_char_ptr(-2:2,2)) +allocate (array_t2_alloc(3:5,2:4), array_t3_ptr(-2:2,2)) +allocate (array_class_t1_alloc(3,3), array_class_t1_ptr(4,4)) + +call sub_scalar (scalar_int, .true.) +call sub_scalar (scalar_real_alloc, .true.) +call sub_scalar (scalar_char_ptr, .true.) +call sub_scalar (array_int(2), .true.) +call sub_scalar (array_real_alloc(3,2), .true.) +call sub_scalar (array_char_ptr(0,1), .true.) +call sub_scalar (scalar_t1, .true.) +call sub_scalar (scalar_t2_alloc, .true.) +call sub_scalar (scalar_t3_ptr, .true.) +call sub_scalar (array_t1(2), .true.) +call sub_scalar (array_t2_alloc(3,2), .true.) +call sub_scalar (array_t3_ptr(0,1), .true.) +call sub_scalar (array_class_t1_alloc(2,1), .true.) +call sub_scalar (array_class_t1_ptr(3,3), .true.) + +call sub_array_assumed (array_int) +call sub_array_assumed (array_real_alloc) +call sub_array_assumed (array_char_ptr) +call sub_array_assumed (array_t1) +call sub_array_assumed (array_t2_alloc) +call sub_array_assumed (array_t3_ptr) +call sub_array_assumed (array_class_t1_alloc) +call sub_array_assumed (array_class_t1_ptr) + +call sub_array_shape (array_real_alloc, [1,1], shape(array_real_alloc)) +call sub_array_shape (array_char_ptr, [1,1], shape(array_char_ptr)) +call sub_array_shape (array_t2_alloc, [1,1], shape(array_t2_alloc)) +call sub_array_shape (array_t3_ptr, [1,1], shape(array_t3_ptr)) +call sub_array_shape (array_class_t1_alloc, [1,1], shape(array_class_t1_alloc)) +call sub_array_shape (array_class_t1_ptr, [1,1], shape(array_class_t1_ptr)) + +deallocate (scalar_char_ptr, scalar_class_t1_ptr, array_char_ptr) +deallocate (array_class_t1_ptr, array_t3_ptr) + +end diff --git a/Fortran/gfortran/regression/assumed_type_3.f90 b/Fortran/gfortran/regression/assumed_type_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_type_3.f90 @@ -0,0 +1,119 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/48820 +! +! Test TYPE(*) + +subroutine one(a) ! { dg-error "may not have the ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute" } + type(*), value :: a +end subroutine one + +subroutine two(a) ! { dg-error "may not have the ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute" } + type(*), pointer :: a +end subroutine two + +subroutine three(a) ! { dg-error "may not have the ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute" } + type(*), allocatable :: a +end subroutine three + +subroutine four(a) ! { dg-error "may not have the ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute" } + type(*) :: a[*] +end subroutine four + +subroutine five(a) ! { dg-error "shall not be an explicit-shape array" } + type(*) :: a(3) +end subroutine five + +subroutine six() + type(*) :: nodum ! { dg-error "is only permitted for dummy variables" } +end subroutine six + +subroutine seven(y) + type(*) :: y(:) + call a7(y(3:5)) ! { dg-error "Assumed-type variable y at .1. shall not have a subobject reference" } +contains + subroutine a7(x) + type(*) :: x(*) + end subroutine a7 +end subroutine seven + +subroutine eight() + type t + type(*) :: x ! { dg-error "is not allowed for components" } + end type t +end subroutine eight + +subroutine nine() + interface one + subroutine okay(x) + type(*) :: x + end subroutine okay + subroutine okay2(x) + type(*) :: x(*) + end subroutine okay2 + subroutine okay3(x,y) + integer :: x + type(*) :: y + end subroutine okay3 + end interface + interface two + subroutine okok1(x) + type(*) :: x + end subroutine okok1 + subroutine okok2(x) + integer :: x(*) + end subroutine okok2 + end interface + interface three + subroutine ambig1(x) ! { dg-error "Ambiguous interfaces" } + type(*) :: x + end subroutine ambig1 + subroutine ambig2(x) ! { dg-error "Ambiguous interfaces" } + integer :: x + end subroutine ambig2 + end interface +end subroutine nine + +subroutine ten() + interface + subroutine bar() + end subroutine + end interface + type t + contains + procedure, nopass :: proc => bar + end type + type(t) :: xx + call sub(xx) ! { dg-error "is of derived type with type-bound or FINAL procedures" } +contains + subroutine sub(a) + type(*) :: a + end subroutine sub +end subroutine ten + +subroutine eleven(x) + external bar + type(*) :: x + call bar(x) ! { dg-error "Assumed-type argument x at .1. requires an explicit interface" } +end subroutine eleven + +subroutine twelf(x) + type(*) :: x + call bar(x) ! { dg-error "Type mismatch in argument" } +contains + subroutine bar(x) + integer :: x + end subroutine bar +end subroutine twelf + +subroutine thirteen(x, y) + type(*) :: x + integer :: y(:) + print *, ubound(y, dim=x) ! { dg-error "Assumed-type argument at .1. is only permitted as first actual argument to the intrinsic ubound" } +end subroutine thirteen + +subroutine fourteen(x) + type(*) :: x + x = x ! { dg-error "Assumed-type variable x at .1. may only be used as actual argument" } +end subroutine fourteen diff --git a/Fortran/gfortran/regression/assumed_type_4.f90 b/Fortran/gfortran/regression/assumed_type_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_type_4.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +! PR fortran/48820 +! +! Test TYPE(*) + +subroutine one(a) + type(*) :: a ! { dg-error "Fortran 2018: Assumed type" } +end subroutine one diff --git a/Fortran/gfortran/regression/assumed_type_5.f90 b/Fortran/gfortran/regression/assumed_type_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_type_5.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! +! PR fortran/57035 +! +! + +subroutine assumed_rank (a) + use iso_c_binding + integer, intent(in), target :: a(..) + integer :: c(1:4) + type(c_ptr) :: xx + c = ubound(c,a) ! { dg-error "Assumed-rank argument at .1. is only permitted as first actual argument to the intrinsic inquiry function ubound" } + c = transfer(a,1) ! { dg-error "Assumed-rank argument at .1. is only permitted as actual argument to intrinsic inquiry functions" } + xx = c_loc(a) +end subroutine + +subroutine assumed_type (a) + use iso_c_binding + type(*), intent(in), target :: a + integer :: c(1:4) + type(c_ptr) :: xx + c = ubound(c,a) ! { dg-error "Assumed-type argument at .1. is only permitted as first actual argument to the intrinsic ubound" } + c = transfer(a,1) ! { dg-error "Assumed-type argument at .1. is not permitted as actual argument to the intrinsic transfer" } + xx = c_loc(a) +end subroutine + +subroutine no_arg_check (a) + use iso_c_binding + integer, intent(in), target :: a + !gcc$ attributes no_arg_check :: a + integer :: c(1:4) + type(c_ptr) :: xx + c = ubound(c,a) ! { dg-error "Variable with NO_ARG_CHECK attribute at .1. is only permitted as argument to the intrinsic functions C_LOC and PRESENT" } + c = transfer(a,1) ! { dg-error "Variable with NO_ARG_CHECK attribute at .1. is only permitted as argument to the intrinsic functions C_LOC and PRESENT" } + xx = c_loc(a) +end subroutine diff --git a/Fortran/gfortran/regression/assumed_type_6.f90 b/Fortran/gfortran/regression/assumed_type_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_type_6.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! +! PR fortran/ +! +! Contributed by Vladimír Fuka +! +function avg(a) + integer :: avg + integer,intent(in) :: a(..) + + avg = sum(a)/size(a) ! { dg-error "Assumed-rank argument at .1. is only permitted as actual argument to intrinsic inquiry functions" } +end function diff --git a/Fortran/gfortran/regression/assumed_type_7.f90 b/Fortran/gfortran/regression/assumed_type_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_type_7.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! PR 54190: TYPE(*)/assumed-rank: Type/rank check too relaxed for dummy procedure +! +! Contributed by Tobias Burnus + +implicit none +call sub(f) ! { dg-error "Type mismatch in argument" } +contains + + subroutine f(x) + type(*) :: x + end subroutine + + subroutine sub(g) + interface + subroutine g(x) + integer :: x + end subroutine + end interface + end subroutine + +end diff --git a/Fortran/gfortran/regression/assumed_type_8.f90 b/Fortran/gfortran/regression/assumed_type_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_type_8.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! Issue came up during the review of PR fortran/58793 +! +! Test for TS29113:2012's C407b. +! +program test + use iso_c_binding + integer,target ::aa + call up(c_loc(aa)) +contains + subroutine up(x) + class(*) :: x + end subroutine + subroutine bar(x) + type(*) :: x + call up(x) ! { dg-error "Assumed-type actual argument at .1. requires that dummy argument 'x' is of assumed type" } + end subroutine bar +end program test diff --git a/Fortran/gfortran/regression/assumed_type_9.f90 b/Fortran/gfortran/regression/assumed_type_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/assumed_type_9.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! +! Test the fix for PR85742 in which the descriptors, passed to alsize, +! for 'a' and 'b' had the wrong element length. +! +! Contributed by Cesar Philippidis +! +program main + implicit none + integer, allocatable :: a + real, pointer :: b + integer, allocatable :: am(:,:) + real, pointer :: bm(:,:) + + allocate (a) + allocate (b) + allocate (am(3,3)) + allocate (bm(4,4)) + + if (sizeof (a) /= alsize (a)) stop 1 + if (sizeof (b) /= alsize (b)) stop 2 + if (sizeof (am) /= alsize (am)) stop 3 + if (sizeof (bm) /= alsize (bm)) stop 4 + + deallocate (b) + deallocate (bm) +contains + function alsize (a) + integer alsize + type (*), dimension (..), contiguous :: a + alsize = sizeof(a) + end function +end program main + diff --git a/Fortran/gfortran/regression/asynchronous_1.f90 b/Fortran/gfortran/regression/asynchronous_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/asynchronous_1.f90 @@ -0,0 +1,42 @@ +! { dg-do compile } +! +! PR/fortran 25829 +! +! Check parsing and checking of ASYNCHRONOUS +! +type(t) function func0() + asynchronous :: a + integer, asynchronous:: b + allocatable :: c + volatile :: d + type t + sequence + integer :: i = 5 + end type t +end function func0 + +integer function func() + asynchronous :: func + integer, asynchronous:: b + allocatable :: c + volatile :: func + type t + sequence + integer :: i = 5 + end type t +end function func + +function func2() result(res) + volatile res + asynchronous res +end function func2 + +subroutine sub() + asynchronous sub ! { dg-error "SUBROUTINE attribute conflicts with ASYNCHRONOUS" } + volatile sub ! { dg-error "SUBROUTINE attribute conflicts with VOLATILE" } +end subroutine sub + +program main + asynchronous main ! { dg-error "PROGRAM attribute conflicts with ASYNCHRONOUS" } + volatile main ! { dg-error "PROGRAM attribute conflicts with VOLATILE" } +end program main diff --git a/Fortran/gfortran/regression/asynchronous_2.f90 b/Fortran/gfortran/regression/asynchronous_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/asynchronous_2.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! PR/fortran 25829 +! +! Check parsing ASYNCHRONOUS +! +function func2() result(res) + asynchronous res ! { dg-error "Fortran 2003: ASYNCHRONOUS" } +end function func2 diff --git a/Fortran/gfortran/regression/asynchronous_3.f03 b/Fortran/gfortran/regression/asynchronous_3.f03 --- /dev/null +++ b/Fortran/gfortran/regression/asynchronous_3.f03 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! PR fortran/44457 - no array-subscript actual argument +! for an asynchronous dummy +! + + integer :: a(10), sect(3) + sect = [1,2,3] + call f(a(sect)) ! { dg-error "incompatible" } + call f(a(::2)) +contains + subroutine f(x) + integer, asynchronous :: x(:) + end subroutine f +end diff --git a/Fortran/gfortran/regression/asynchronous_4.f90 b/Fortran/gfortran/regression/asynchronous_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/asynchronous_4.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +! PR 59228: ICE with assumed type and ASYNCHRONOUS +! +! Contributed by Valery Weber + + IMPLICIT NONE + + interface + subroutine test(base) + TYPE(*), ASYNCHRONOUS :: base + end subroutine + end interface + +CONTAINS + + SUBROUTINE foo ( data ) + REAL, DIMENSION( : ), ASYNCHRONOUS :: data + CALL test ( data ) ! { dg-error "Rank mismatch in argument" } + END SUBROUTINE + +END diff --git a/Fortran/gfortran/regression/asynchronous_5.f03 b/Fortran/gfortran/regression/asynchronous_5.f03 --- /dev/null +++ b/Fortran/gfortran/regression/asynchronous_5.f03 @@ -0,0 +1,41 @@ +! { dg-do compile } +! { dg-options "-std=f2003 -fdump-tree-original" } +! +! Covers code introduced by the fix to PR fortran/87923. +! The idea is that the variables in a namelist or I/O list used for +! asynchronous I/O will be marked with the asynchronous attribute. +! +! At this time, "asynchronous" is treated as "volatile" (see trans-decl.c). +! Thus, every variable referenced in an "asynchronous=yes" I/O list +! should obtain the "volatile" specifier in its declaration. +! + +implicit none + +type t + character(4) :: comp_async +end type + +type(t) :: dvar_async +integer :: ivar_async +real :: rvar_async +logical :: lvar_async +integer :: ivar_noasync + +namelist /names/ ivar_async, rvar_async, lvar_async + +open(1, asynchronous="yes") +write(1, asynchronous="yes") dvar_async +write(1, asynchronous="yes") dvar_async%comp_async +read(1, asynchronous="yes", nml=names) + +open(2, asynchronous="no") +read(2, asynchronous="no") ivar_noasync + +end + +! { dg-final { scan-tree-dump "volatile +struct +\[^ \]+ +dvar_async" "original" } } +! { dg-final { scan-tree-dump "volatile +\[^ \]+ +ivar_async" "original" } } +! { dg-final { scan-tree-dump "volatile +\[^ \]+ +rvar_async" "original" } } +! { dg-final { scan-tree-dump "volatile +\[^ \]+ +lvar_async" "original" } } +! { dg-final { scan-tree-dump-not "volatile +\[^ \]+ +ivar_noasync" "original" } } diff --git a/Fortran/gfortran/regression/atan2_1.f90 b/Fortran/gfortran/regression/atan2_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/atan2_1.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! { dg-options "-ffloat-store" } +! +! PR fortran/33197 +! +! Check for Fortran 2008's ATAN(Y,X) - which is equivalent +! to Fortran 77's ATAN2(Y,X). +! +integer :: i +real, parameter :: pi4 = 2*acos(0.0) +real, parameter :: pi8 = 2*acos(0.0d0) +do i = 1, 10 + if(atan(1.0, i/10.0) -atan2(1.0, i/10.) /= 0.0) STOP 1 + if(atan(1.0d0,i/10.0d0)-atan2(1.0d0,i/10.0d0) /= 0.0d0) STOP 2 +end do + +! Atan(1,1) = Pi/4 +if (abs(atan(1.0,1.0) -pi4/4.0) > epsilon(pi4)) STOP 3 +if (abs(atan(1.0d0,1.0d0)-pi8/4.0d0) > epsilon(pi8)) STOP 4 + +! Atan(-1,1) = -Pi/4 +if (abs(atan(-1.0,1.0) +pi4/4.0) > epsilon(pi4)) STOP 5 +if (abs(atan(-1.0d0,1.0d0)+pi8/4.0d0) > epsilon(pi8)) STOP 6 + +! Atan(1,-1) = 3/4*Pi +if (abs(atan(1.0,-1.0) -3.0*pi4/4.0) > epsilon(pi4)) STOP 7 +if (abs(atan(1.0d0,-1.0d0)-3.0d0*pi8/4.0d0) > epsilon(pi8)) STOP 8 + +! Atan(-1,-1) = -3/4*Pi +if (abs(atan(-1.0,-1.0) +3.0*pi4/4.0) > epsilon(pi4)) STOP 9 +if (abs(atan(-1.0d0,-1.0d0)+3.0d0*pi8/4.0d0) > epsilon(pi8)) STOP 10 + +! Atan(3,-5) = 2.60117315331920908301906501867... = Pi - 3/2 atan(3/5) +if (abs(atan(3.0,-5.0) -2.60117315331920908301906501867) > epsilon(pi4)) STOP 11 +if (abs(atan(3.0d0,-5.0d0)-2.60117315331920908301906501867d0) > epsilon(pi8)) STOP 12 + +end diff --git a/Fortran/gfortran/regression/atan2_2.f90 b/Fortran/gfortran/regression/atan2_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/atan2_2.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/33197 +! +! Check for Fortran 2008's ATAN(Y,X) - which is equivalent +! to Fortran 77's ATAN2(Y,X). +! +real(4) :: r4 +real(8) :: r8 +complex(4) :: c4 +complex(8) :: c8 + +r4 = atan2(r4,r4) +r8 = atan2(r8,r8) + +r4 = atan(r4,r4) ! { dg-error "Too many arguments in call to 'atan'" } +r8 = atan(r8,r8) ! { dg-error "Too many arguments in call to 'atan'" } + +r4 = atan2(r4,r8) ! { dg-error "same type and kind" } +r4 = atan2(r8,r4) ! { dg-error "same type and kind" } + +r4 = atan2(c4,r8) ! { dg-error "must be REAL" } +r4 = atan2(c8,r4) ! { dg-error "must be REAL" } +r4 = atan2(r4,c8) ! { dg-error "same type and kind" } +r4 = atan2(r8,c4) ! { dg-error "same type and kind" } + +r4 = atan2(c4,c8) ! { dg-error "must be REAL" } +r4 = atan2(c8,c4) ! { dg-error "must be REAL" } +end diff --git a/Fortran/gfortran/regression/attr_deprecated-2.f90 b/Fortran/gfortran/regression/attr_deprecated-2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/attr_deprecated-2.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-additional-options "-Wall" } +! +! Ensure that only those parameters are warned for which are actually used +! +module m + implicit none + integer, parameter :: parm = 4 ! unused + integer, parameter :: parm2 = 4 ! used in the main program + integer, parameter :: parm3 = 4 ! used in "f()" - { dg-warning "Using parameter 'parm3' declared at .1. is deprecated" } + integer, save :: var, var2 +!GCC$ ATTRIBUTES DEPRECATED :: parm, parm2, parm3, var, var2 +contains + subroutine f() + print *, parm3 ! warning shown above + end +end module m + +use m ! { dg-warning "Using parameter 'parm2' declared at .1. is deprecated" } +implicit none +print *, var2, parm2 ! { dg-warning "Using variable 'var2' at .1. is deprecated" } +end diff --git a/Fortran/gfortran/regression/attr_deprecated.f90 b/Fortran/gfortran/regression/attr_deprecated.f90 --- /dev/null +++ b/Fortran/gfortran/regression/attr_deprecated.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } + +module m + implicit none + integer :: A + integer, parameter :: PARM = 5 ! { dg-warning "Using parameter 'parm' declared at .1. is deprecated" } +!GCC$ ATTRIBUTES DEPRECATED :: A, foo, func, parm +contains +subroutine foo +end +integer function func() + func = 42 +end +subroutine bar + integer :: i + call foo ! { dg-warning "Using subroutine 'foo' at .1. is deprecated" } + print *, A ! { dg-warning "Using variable 'a' at .1. is deprecated" } + i = func() ! { dg-warning "Using function 'func' at .1. is deprecated" } + print *, PARM +end + +end module m + +use m ! { dg-warning "Using parameter 'parm' declared at .1. is deprecated" } + integer :: i + call foo ! { dg-warning "Using subroutine 'foo' at .1. is deprecated" } + print *, A ! { dg-warning "Using variable 'a' at .1. is deprecated" } + i = func() ! { dg-warning "Using function 'func' at .1. is deprecated" } + print *, PARM +end diff --git a/Fortran/gfortran/regression/auto_array_1.f90 b/Fortran/gfortran/regression/auto_array_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/auto_array_1.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! PR fortran/17077. +! Automatic arrays are allocated on the heap. When used as an actual argument +! we were passing the address of the pointer, not the pointer itself. + +program p + implicit none + integer:: n,m + + n = 3 + call foo(n) +contains + + subroutine foo(m) + integer:: m,i + integer:: z(m,m) + + z = 0 + + call foo1(m,z) + + ! Check it worked. + if (any (z .ne. reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)))) & + STOP 1 + end subroutine foo + + subroutine foo1(n,x) + integer:: n,i,j + integer:: x(n,n) + + ! Assign values to x. + do i=1,n + do j=1,n + x(j,i)=j+(i-1)*n + enddo + enddo + end subroutine foo1 +end program diff --git a/Fortran/gfortran/regression/auto_char_dummy_array_1.f90 b/Fortran/gfortran/regression/auto_char_dummy_array_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/auto_char_dummy_array_1.f90 @@ -0,0 +1,57 @@ +! { dg-do run } +! This tests the fix for pr15809 in which automatic character length, +! dummy, pointer arrays were broken. +! +! contributed by Paul Thomas +! +module global + character(12), dimension(2), target :: t +end module global + +program oh_no_not_pr15908_again + character(12), dimension(:), pointer :: ptr + + nullify(ptr) + + call a (ptr, 12) + if (.not.associated (ptr) ) STOP 1 + if (any (ptr.ne."abc")) STOP 2 + + ptr => null () ! ptr points to 't' here. + allocate (ptr(3)) + ptr = "xyz" + call a (ptr, 12) + + if (.not.associated (ptr)) STOP 3 + if (any (ptr.ne."lmn")) STOP 4 + + call a (ptr, 0) + + if (associated (ptr)) STOP 5 + +contains + + subroutine a (p, l) + use global + character(l), dimension(:), pointer :: p + character(l), dimension(3) :: s + + s = "lmn" + + if (l.ne.12) then + deallocate (p) ! ptr was allocated in main. + p => null () + return + end if + + if (.not.associated (p)) then + t = "abc" + p => t + else + if (size (p,1).ne.3) STOP 6 + if (any (p.ne."xyz")) STOP 7 + p = s + end if + end subroutine a + +end program oh_no_not_pr15908_again diff --git a/Fortran/gfortran/regression/auto_char_dummy_array_2.f90 b/Fortran/gfortran/regression/auto_char_dummy_array_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/auto_char_dummy_array_2.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! Test fix for pr24789 - would segfault on the assignment +! because the array descriptor size was not set. +! +! This is the example submitted by Martin Reineke + +subroutine foo(vals) + character(len = *), pointer :: vals(:) + vals = '' +end subroutine + diff --git a/Fortran/gfortran/regression/auto_char_dummy_array_3.f90 b/Fortran/gfortran/regression/auto_char_dummy_array_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/auto_char_dummy_array_3.f90 @@ -0,0 +1,25 @@ +! { dg-do run } + +! PR fortran/49885 +! Check that character arrays with non-constant char-length are handled +! correctly. + +! Contributed by Daniel Kraft , +! based on original test case and variant by Tobias Burnus in comment 2. + +PROGRAM main + IMPLICIT NONE + + CALL s (10) + +CONTAINS + + SUBROUTINE s (nb) + INTEGER :: nb + CHARACTER(MAX (80, nb)) :: bad_rec(1) + + bad_rec(1)(1:2) = 'abc' + IF (bad_rec(1)(1:2) /= 'ab') STOP 1 + END SUBROUTINE s + +END PROGRAM main diff --git a/Fortran/gfortran/regression/auto_char_len_1.f90 b/Fortran/gfortran/regression/auto_char_len_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/auto_char_len_1.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "" } +! [option to disable -pedantic as assumed character length +! functions are obsolescent] +! +! PR fortran/41235 +! + +character(len=*) function func() + func = 'ABC' +end function func + +subroutine test(i) + integer :: i + character(len=i), external :: func + print *, func() +end subroutine test + +subroutine test2(i) + integer :: i + character(len=i) :: func + print *, func() +end subroutine test2 + +call test(2) +call test2(2) +end diff --git a/Fortran/gfortran/regression/auto_char_len_2.f90 b/Fortran/gfortran/regression/auto_char_len_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/auto_char_len_2.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "" } +! +! PR fortran/41235 +! + +character(len=*) function func() + func = 'ABC' +end function func + +subroutine test(i) + integer :: i + character(len=i), external :: func + print *, func() +end subroutine test + +subroutine test2(i) + integer :: i + character(len=i) :: func + print *, func() +end subroutine test2 + +call test(2) +call test2(2) +end diff --git a/Fortran/gfortran/regression/auto_char_len_3.f90 b/Fortran/gfortran/regression/auto_char_len_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/auto_char_len_3.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! Test the fix for PR26257, in which the implicit reference to +! chararray in the main program call of chararray2string would +! cause a segfault in gfc_build_addr_expr. +! +! Based on the reduced testcase in the PR. +module chtest +contains + function chararray2string(chararray) result(text) + character(len=1), dimension(:) :: chararray ! input + character(len=size(chararray, 1)) :: text ! output + do i = 1,size(chararray,1) + text(i:i) = chararray (i) + end do + end function chararray2string +end module chtest +program TestStringTools + use chtest + character(len=52) :: txt + character(len=1), dimension(52) :: chararr = & + (/(char(i+64),char(i+96), i = 1,26)/) + txt = chararray2string(chararr) + if (txt .ne. "AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUuVvWwXxYyZz") & + STOP 1 +end program TestStringTools diff --git a/Fortran/gfortran/regression/auto_char_len_4.f90 b/Fortran/gfortran/regression/auto_char_len_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/auto_char_len_4.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! +! Tests the fix for PR25087, in which the following invalid code +! was not detected. +! +! Contributed by Joost VandeVondele +! +! Modified by Tobias Burnus to fix PR fortran/41235. +! +FUNCTION a() + CHARACTER(len=10) :: a + a = '' +END FUNCTION a + +SUBROUTINE s(n) + CHARACTER(LEN=n), EXTERNAL :: a ! { dg-error "Character length mismatch" } + CHARACTER(LEN=n), EXTERNAL :: d ! { dg-error "Character length mismatch" } + interface + function b (m) ! This is OK + CHARACTER(LEN=m) :: b + integer :: m + end function b + end interface + write(6,*) a() + write(6,*) b(n) + write(6,*) c() + write(6,*) d() +contains + function c () ! This is OK + CHARACTER(LEN=n):: c + c = "" + end function c +END SUBROUTINE s + +FUNCTION d() + CHARACTER(len=99) :: d + d = '' +END FUNCTION d diff --git a/Fortran/gfortran/regression/auto_char_pointer_array_result_1.f90 b/Fortran/gfortran/regression/auto_char_pointer_array_result_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/auto_char_pointer_array_result_1.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! Tests the fixes for PR25597 and PR27096. +! +! This test combines the PR testcases. +! + character(10), dimension (2) :: implicit_result + character(10), dimension (2) :: explicit_result + character(10), dimension (2) :: source + source = "abcdefghij" + explicit_result = join_1(source) + if (any (explicit_result .ne. source)) STOP 1 + + implicit_result = reallocate_hnv (source, size(source, 1), LEN (source)) + if (any (implicit_result .ne. source)) STOP 2 + +contains + +! This function would cause an ICE in gfc_trans_deferred_array. + function join_1(self) result(res) + character(len=*), dimension(:) :: self + character(len=len(self)), dimension(:), pointer :: res + allocate (res(2)) + res = self + end function + +! This function originally ICEd and latterly caused a runtime error. + FUNCTION reallocate_hnv(p, n, LEN) + CHARACTER(LEN=LEN), DIMENSION(:), POINTER :: reallocate_hnv + character(*), dimension(:) :: p + ALLOCATE (reallocate_hnv(n)) + reallocate_hnv = p + END FUNCTION reallocate_hnv + +end + + diff --git a/Fortran/gfortran/regression/auto_dealloc_1.f90 b/Fortran/gfortran/regression/auto_dealloc_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/auto_dealloc_1.f90 @@ -0,0 +1,56 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR 41586: Allocatable _scalars_ are never auto-deallocated +! +! Contributed by Tobias Burnus + +module automatic_deallocation + + type t0 + integer :: i + end type + + type t1 + real :: pi = 3.14 + integer, allocatable :: j + end type + + type t2 + class(t0), allocatable :: k + end type t2 + +contains + + ! (1) simple allocatable scalars + subroutine a + integer, allocatable :: m + allocate (m) + m = 42 + end subroutine + + ! (2) allocatable scalar CLASS variables + subroutine b + class(t0), allocatable :: m + allocate (t0 :: m) + m%i = 43 + end subroutine + + ! (3) allocatable scalar components + subroutine c + type(t1) :: m + allocate (m%j) + m%j = 44 + end subroutine + + ! (4) allocatable scalar CLASS components + subroutine d + type(t2) :: m + allocate (t0 :: m%k) + m%k%i = 45 + end subroutine + +end module + + +! { dg-final { scan-tree-dump-times "__builtin_free" 10 "original" } } diff --git a/Fortran/gfortran/regression/auto_dealloc_2.f90 b/Fortran/gfortran/regression/auto_dealloc_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/auto_dealloc_2.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR 47637: [OOP] Memory leak involving INTENT(OUT) CLASS argument w/ allocatable components +! +! Contributed by Rich Townsend + +program test + +type :: t + integer, allocatable :: i(:) +end type + +block ! New block as the main program implies SAVE +type(t) :: a + +call init(a) +call init(a) +end block +contains + + subroutine init(x) + class(t), intent(out) :: x + allocate(x%i(1000)) + end subroutine + +end program + +! { dg-final { scan-tree-dump-times "__builtin_free" 4 "original" } } +! { dg-final { scan-tree-dump-times "x->_vptr->_final \\(" 1 "original" } } diff --git a/Fortran/gfortran/regression/auto_in_equiv_1.f90 b/Fortran/gfortran/regression/auto_in_equiv_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/auto_in_equiv_1.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! { dg-options "-fdec-static -frecursive" } + +! Contributed by Mark Eggleston +! +! Check automatic variables can be used in equivalence statements. +! Any other variables that do not explicitly have the automatic +! attribute will be given the automatic attribute. +! +! Check that variables are on the stack by incorporating the +! equivalence in a recursive function. +! +program test + integer :: f + + f = factorial(5) + if (f.ne.120) stop 2 + +contains + function factorial(n) result(f) + integer :: f + integer, intent(in) :: n + integer, automatic :: a + integer :: b + equivalence (a,b) + + if (loc(a).ne.loc(b)) stop 1 + b = n + if (a.eq.1) then + f = 1 + else + f = a * factorial(b-1) + end if + end function +end program test diff --git a/Fortran/gfortran/regression/auto_in_equiv_2.f90 b/Fortran/gfortran/regression/auto_in_equiv_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/auto_in_equiv_2.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! { dg-options "-fdec-static -frecursive -fno-automatic" } + +! Contributed by Mark Eggleston +! +! Check that -fno-automatic does not break recursion. The recursive +! function is not marked with the resursive key word consequently +! local variables can be made static when -fno-automatic is used. The +! recursive function contains an equivalence that has a variable with +! the automatic attribute and one without. +! +include "auto_in_equiv_1.f90" + +! { dg-warning "Flag '-fno-automatic' overwrites '-frecursive'" "warning" { target *-*-* } 0 } diff --git a/Fortran/gfortran/regression/auto_in_equiv_3.f90 b/Fortran/gfortran/regression/auto_in_equiv_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/auto_in_equiv_3.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-fdec-static -fdump-tree-original" } +! + +subroutine foo + integer, automatic :: a + integer :: b + equivalence (a, b) + a = 5 + if (b.ne.5) stop 1 +end subroutine + +! { dg-final { scan-tree-dump "union" "original" } } +! { dg-final { scan-tree-dump-not "static union" "original" } } +! { dg-final { scan-tree-dump "integer\\(kind=4\\) a" "original" } } +! { dg-final { scan-tree-dump-not "static integer\\(kind=4\\) a" "original" } } +! { dg-final { scan-tree-dump "integer\\(kind=4\\) b" "original" } } +! { dg-final { scan-tree-dump-not "static integer\\(kind=4\\) b" "original" } } + diff --git a/Fortran/gfortran/regression/auto_in_equiv_4.f90 b/Fortran/gfortran/regression/auto_in_equiv_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/auto_in_equiv_4.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-fdec-static -fno-automatic -fdump-tree-original" } +! +! Neither of the local variable have the automatic attribute so they +! not be allocated on the stack. + +subroutine foo + integer :: a + integer :: b + equivalence (a, b) + a = 5 + if (b.ne.5) stop 1 +end subroutine + +! { dg-final { scan-tree-dump "static union" "original" } } +! { dg-final { scan-tree-dump "static integer\\(kind=4\\) a" "original" } } +! { dg-final { scan-tree-dump "static integer\\(kind=4\\) b" "original" } } + diff --git a/Fortran/gfortran/regression/auto_in_equiv_5.f90 b/Fortran/gfortran/regression/auto_in_equiv_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/auto_in_equiv_5.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Neither of the local variable have the automatic attribute so they +! not be allocated on the stack. + +subroutine foo + integer, save :: a + integer :: b + equivalence (a, b) + a = 5 + if (b.ne.5) stop 1 +end subroutine + +! { dg-final { scan-tree-dump "static union" "original" } } +! { dg-final { scan-tree-dump "static integer\\(kind=4\\) a" "original" } } +! { dg-final { scan-tree-dump "static integer\\(kind=4\\) b" "original" } } + diff --git a/Fortran/gfortran/regression/auto_in_equiv_6.f90 b/Fortran/gfortran/regression/auto_in_equiv_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/auto_in_equiv_6.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-fdec-static -fdump-tree-original" } +! +! Neither of the local variable have the automatic attribute so they +! not be allocated on the stack. + +subroutine foo + integer, static :: a + integer :: b + equivalence (a, b) + a = 5 + if (b.ne.5) stop 1 +end subroutine + +! { dg-final { scan-tree-dump "static union" "original" } } +! { dg-final { scan-tree-dump "static integer\\(kind=4\\) a" "original" } } +! { dg-final { scan-tree-dump "static integer\\(kind=4\\) b" "original" } } + diff --git a/Fortran/gfortran/regression/auto_in_equiv_7.f90 b/Fortran/gfortran/regression/auto_in_equiv_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/auto_in_equiv_7.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-fdec-static -fdump-tree-original" } +! + +subroutine foo + integer :: a + integer, automatic :: b + equivalence (a, b) + a = 5 + if (b.ne.5) stop 1 +end subroutine + +! { dg-final { scan-tree-dump "union" "original" } } +! { dg-final { scan-tree-dump-not "static union" "original" } } +! { dg-final { scan-tree-dump "integer\\(kind=4\\) a" "original" } } +! { dg-final { scan-tree-dump-not "static integer\\(kind=4\\) a" "original" } } +! { dg-final { scan-tree-dump "integer\\(kind=4\\) b" "original" } } +! { dg-final { scan-tree-dump-not "static integer\\(kind=4\\) b" "original" } } + diff --git a/Fortran/gfortran/regression/auto_internal_assumed.f90 b/Fortran/gfortran/regression/auto_internal_assumed.f90 --- /dev/null +++ b/Fortran/gfortran/regression/auto_internal_assumed.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! Test fix of PR24705 - ICE on assumed character length +! internal function. +! +character (6) :: c + c = f1 () + if (c .ne. 'abcdef') STOP 1 +contains + function f1 () ! { dg-error "must not be assumed length" } + character (*) :: f1 + f1 = 'abcdef' + end function f1 +end \ No newline at end of file diff --git a/Fortran/gfortran/regression/auto_pointer_array_result_1.f90 b/Fortran/gfortran/regression/auto_pointer_array_result_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/auto_pointer_array_result_1.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! Tests the fixes for PR25597 and PR27096. +! +! This test combines the PR testcases. +! + character(10), dimension (2) :: implicit_result + character(10), dimension (2) :: explicit_result + character(10), dimension (2) :: source + source = "abcdefghij" + explicit_result = join_1(source) + if (any (explicit_result .ne. source)) STOP 1 + + implicit_result = reallocate_hnv (source, size(source, 1), LEN (source)) + if (any (implicit_result .ne. source)) STOP 2 + +contains + +! This function would cause an ICE in gfc_trans_deferred_array. + function join_1(self) result(res) + character(len=*), dimension(:) :: self + character(len=len(self)), dimension(:), pointer :: res + allocate (res(2)) + res = self + end function + +! This function originally ICEd and latterly caused a runtime error. + FUNCTION reallocate_hnv(p, n, LEN) + CHARACTER(LEN=LEN), DIMENSION(:), POINTER :: reallocate_hnv + character(*), dimension(:) :: p + ALLOCATE (reallocate_hnv(n)) + reallocate_hnv = p + END FUNCTION reallocate_hnv + +end + + diff --git a/Fortran/gfortran/regression/auto_save_1.f90 b/Fortran/gfortran/regression/auto_save_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/auto_save_1.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! Check that automatic objects work properly in the presence of a save +! statement. +! PR21034 +subroutine test(n) + implicit none + integer n + real dte(n) + character(len=n) :: s + save + dte = 0 + s = "" +end + +program prog + call test(4) + call test(10) +end program diff --git a/Fortran/gfortran/regression/auto_save_2.f90 b/Fortran/gfortran/regression/auto_save_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/auto_save_2.f90 @@ -0,0 +1,83 @@ +! { dg-do run } +! { dg-options "-fno-automatic -finit-local-zero -fdump-tree-original" } +! +! PR fortran/62309 +! +! Make sure variables are saved with -fno-automatic except in +! functions marked RECURSIVE, and that they are still initialized with +! -finit-local-zero. +! + +function f (x) +implicit none + integer f, x + integer a ! should be SAVEd + a = a + x ! should increment by y every time + f = a + return +endfunction + +function f2 (x) +implicit none + integer f2, x + block + named: block + block + integer a ! should be SAVEd + a = a + x ! should increment by y every time + f2 = a + end block + end block named + end block + return +endfunction + +recursive function g (x) +implicit none + integer g, x + integer b ! should be automatic + b = b + x ! should be set to y every time + g = b + return +endfunction + +recursive function g2 (x) +implicit none + integer g2, x + block + named: block + block + integer b ! should be automatic + b = b + x ! should be set to y every time + g2 = b + end block + end block named + end block + return +endfunction + +implicit none +integer f, f2, g, g2 + +! Should return static value of a; accumulates y +if ( f(3) .ne. 3 ) STOP 1 +if ( f(4) .ne. 7 ) STOP 2 +if ( f(2) .ne. 9 ) STOP 3 + +if ( f2(3) .ne. 3 ) STOP 4 +if ( f2(4) .ne. 7 ) STOP 5 +if ( f2(2) .ne. 9 ) STOP 6 + +! Should return automatic value of a; equal to y each time +if ( g(3) .ne. 3 ) STOP 7 +if ( g(4) .ne. 4 ) STOP 8 +if ( g(2) .ne. 2 ) STOP 9 + +if ( g2(3) .ne. 3 ) STOP 10 +if ( g2(4) .ne. 4 ) STOP 11 +if ( g2(2) .ne. 2 ) STOP 12 + +end + +! { dg-final { scan-tree-dump-times " static integer\\\(kind=4\\\) a = 0;" 2 "original" } } +! { dg-final { scan-tree-dump-times " b = 0;" 2 "original" } } diff --git a/Fortran/gfortran/regression/automatic_1.f90 b/Fortran/gfortran/regression/automatic_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/automatic_1.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! { dg-options "-O2 -fdec-static -fno-automatic" } + subroutine foo (b) + logical b + integer i, j + character*24 s + automatic i + if (b) then + i = 26 + j = 131 + s = 'This is a test string' + else + if (i .eq. 26 .or. j .ne. 131) call abort + if (s .ne. 'This is a test string') call abort + end if + end subroutine foo + subroutine bar (s) + character*42 s + if (s .ne. '0123456789012345678901234567890123456') call abort + call foo (.false.) + end subroutine bar + subroutine baz + character*42 s + ! Just clobber stack a little bit. + s = '0123456789012345678901234567890123456' + call bar (s) + end subroutine baz + call foo (.true.) + call baz + call foo (.false.) + end diff --git a/Fortran/gfortran/regression/automatic_char_len_1.f90 b/Fortran/gfortran/regression/automatic_char_len_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/automatic_char_len_1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR18082 - Compiler would get stuck in loop, whilst treating +! the assignments. +! Test is one of PR cases. +subroutine snafu (i) +character*(i) :: c1, c2 +c1 = "" +c2 = "" +end subroutine snafu + + diff --git a/Fortran/gfortran/regression/automatic_char_len_2.f90 b/Fortran/gfortran/regression/automatic_char_len_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/automatic_char_len_2.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-O0" } +! +! Tests fix for PR21459 - This is the original example. +! +program format_string + implicit none + character(len=*), parameter :: rform='(F15.5)', & + cform="(' (', F15.5, ',' F15.5, ') ')" + call print_a_number(cform) +contains +subroutine print_a_number(style) + character(len=*) :: style + write(*, style) cmplx(42.0, 99.0) ! { dg-output "99.00000" } +end subroutine print_a_number +end program format_string diff --git a/Fortran/gfortran/regression/automatic_default_init_1.f90 b/Fortran/gfortran/regression/automatic_default_init_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/automatic_default_init_1.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-options "-O" } +! Test the fix for PR29394 in which automatic arrays did not +! get default initialization. +! Contributed by Francois-Xavier Coudert +! +MODULE M1 + TYPE T1 + INTEGER :: I=7 + END TYPE T1 +CONTAINS + SUBROUTINE S1(I) + INTEGER, INTENT(IN) :: I + TYPE(T1) :: D(1:I) + IF (any (D(:)%I.NE.7)) STOP 1 + END SUBROUTINE S1 +END MODULE M1 + USE M1 + CALL S1(2) +END diff --git a/Fortran/gfortran/regression/automatic_module_variable.f90 b/Fortran/gfortran/regression/automatic_module_variable.f90 --- /dev/null +++ b/Fortran/gfortran/regression/automatic_module_variable.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! Tests fix for PR15976 +! +! Error message update with patch for PR fortran/83633 +! +module sd + integer, parameter :: n = 20 + integer :: i(n) + integer :: j(m) ! { dg-error "array with nonconstant bounds" } + integer, pointer :: p(:) + integer, allocatable :: q(:) +contains + function init (x, l) + integer :: x(l) + integer :: init(l) + init = x + end function init +end module sd diff --git a/Fortran/gfortran/regression/automatic_repeat.f90 b/Fortran/gfortran/regression/automatic_repeat.f90 --- /dev/null +++ b/Fortran/gfortran/regression/automatic_repeat.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "-fdec-static" } +! An AUTOMATIC statement cannot duplicated +FUNCTION X() +REAL, AUTOMATIC, AUTOMATIC :: Y ! { dg-error "Duplicate AUTOMATIC attribute" } +y = 1 +END FUNCTION X +END diff --git a/Fortran/gfortran/regression/automatic_save.f90 b/Fortran/gfortran/regression/automatic_save.f90 --- /dev/null +++ b/Fortran/gfortran/regression/automatic_save.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "-fdec-static" } +! An AUTOMATIC statement cannot be used with SAVE +FUNCTION X() +REAL, SAVE, AUTOMATIC :: Y ! { dg-error "AUTOMATIC attribute conflicts with SAVE attribute" } +y = 1 +END FUNCTION X +END diff --git a/Fortran/gfortran/regression/backslash_1.f90 b/Fortran/gfortran/regression/backslash_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/backslash_1.f90 @@ -0,0 +1,8 @@ +! { dg-do run } + character(len=4) a + open (10, status='scratch') + write (10,'(A)') '1\n2' + rewind (10) + read (10,'(A)') a + if (a /= '1\n2') STOP 1 + end diff --git a/Fortran/gfortran/regression/backslash_2.f90 b/Fortran/gfortran/regression/backslash_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/backslash_2.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! { dg-options "-fbackslash" } + integer :: i, e + open (10, status='scratch') + write (10,'(A)') '1\n2' + rewind (10) + read (10,*,iostat=e) i + if (e /= 0 .or. i /= 1) STOP 1 + read (10,*,iostat=e) i + if (e /= 0 .or. i /= 2) STOP 2 + end diff --git a/Fortran/gfortran/regression/backslash_3.f b/Fortran/gfortran/regression/backslash_3.f --- /dev/null +++ b/Fortran/gfortran/regression/backslash_3.f @@ -0,0 +1,26 @@ +C { dg-do run { target fd_truncate } } +C { dg-options "-fbackslash" } +C PR fortran/30278 + program a + character(len=1), parameter :: c1 = char(8), c2 = char(92) + character(len=35) str1, str2 + character(len=37) :: str4, str3 + + open(10, status='scratch') + write(10, 100) + rewind(10) + read(10,'(A34)') str1 + str2 = 'Does ' // c1 // 'ackslash result in ' // c1 // 'ackslash' + if (str1 .ne. str2) STOP 1 + + rewind(10) + write (10, 200) + rewind(10) + read(10,'(A37)') str3 + str4 = 'Does ' //c2// 'backslash result in ' //c2// 'backslash' + if (str3 .ne. str4) STOP 2 + + stop + 100 format ('Does \backslash result in \backslash') + 200 format ('Does \\backslash result in \\backslash') + end diff --git a/Fortran/gfortran/regression/backspace_1.f b/Fortran/gfortran/regression/backspace_1.f --- /dev/null +++ b/Fortran/gfortran/regression/backspace_1.f @@ -0,0 +1,82 @@ +! This file is all about BACKSPACE +! { dg-do run { target fd_truncate } } + + integer i, n, nr + real x(10), y(10) + +! PR libfortran/20068 + open (20, status='scratch') + write (20,*) 1 + write (20,*) 2 + write (20,*) 3 + rewind (20) + read (20,*) i + if (i .ne. 1) STOP 1 + write (*,*) ' ' + backspace (20) + read (20,*) i + if (i .ne. 1) STOP 2 + close (20) + +! PR libfortran/20125 + open (20, status='scratch') + write (20,*) 7 + backspace (20) + read (20,*) i + if (i .ne. 7) STOP 3 + close (20) + + open (20, status='scratch', form='unformatted') + write (20) 8 + backspace (20) + read (20) i + if (i .ne. 8) STOP 4 + close (20) + +! PR libfortran/20471 + do n = 1, 10 + x(n) = sqrt(real(n)) + end do + open (3, form='unformatted', status='scratch') + write (3) (x(n),n=1,10) + backspace (3) + rewind (3) + read (3) (y(n),n=1,10) + + do n = 1, 10 + if (abs(x(n)-y(n)) > 0.00001) STOP 5 + end do + close (3) + +! PR libfortran/20156 + open (3, form='unformatted', status='scratch') + do i = 1, 5 + x(1) = i + write (3) n, (x(n),n=1,10) + end do + nr = 0 + rewind (3) + 20 continue + read (3,end=30,err=90) n, (x(n),n=1,10) + nr = nr + 1 + goto 20 + 30 continue + if (nr .ne. 5) STOP 6 + + do i = 1, nr+1 + backspace (3) + end do + + do i = 1, nr + read(3,end=70,err=90) n, (x(n),n=1,10) + if (abs(x(1) - i) .gt. 0.001) STOP 7 + end do + close (3) + stop + + 70 continue + STOP 8 + 90 continue + STOP 9 + + end diff --git a/Fortran/gfortran/regression/backspace_10.f90 b/Fortran/gfortran/regression/backspace_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/backspace_10.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! PR33307 I/O read/positioning problem - in BACKSPACE +! Test case devloped from test in PR by Jerry DeLisle +program gfcbug69b + ! Modified example program + implicit none + integer, parameter :: iunit = 63 + integer :: istat, k, ios + character(len=20) :: line, message + + open (iunit) + write (iunit, '(a)') "! ***Remove this line***" + write (iunit, '(a)') "&FOO file='foo' /" + write (iunit, '(a)', advance="no") "&BAR file='bar' /" + close (iunit) +! Note: Failure occurred only when ACTION="read" was specified + open (iunit, action="read", status="old") + + read (iunit,'(a)',iostat=ios) line + if (ios /= 0) STOP 1 + read (iunit,'(a)',iostat=ios) line + if (ios /= 0) STOP 2 + read (iunit,'(a)',iostat=ios) line + if (ios /= 0) STOP 3 + read (iunit,'(a)',iostat=ios) line + if (ios /= 0) backspace (iunit) + rewind (iunit) + read (iunit,'(a)',iostat=ios) line + if (ios /= 0) STOP 4 + read (iunit,'(a)',iostat=ios) line + if (ios /= 0) STOP 5 + read (iunit,'(a)',iostat=ios) line + if (ios /= 0) STOP 6 + read (iunit,'(a)',iostat=ios) line + if (ios /= -1) STOP 7 + close (iunit, status="delete") +end program gfcbug69b diff --git a/Fortran/gfortran/regression/backspace_11.f90 b/Fortran/gfortran/regression/backspace_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/backspace_11.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! PR 40334 backspace regression +program backspace_11 + implicit none + character(len=5) :: str + open(10, access='sequential', status='scratch') + write(10,'(A)')'HELLO' + rewind(10) + + do + read(10,'(A)',end=1) str + enddo +1 backspace 10 + !the file pointer is now at EOF + + read(10,*,end=2) str + STOP 1 +2 backspace 10 + !the file pointer is now at EOF + + read(10,'(A)',end=3) str + STOP 2 +3 continue +end program backspace_11 diff --git a/Fortran/gfortran/regression/backspace_2.f b/Fortran/gfortran/regression/backspace_2.f --- /dev/null +++ b/Fortran/gfortran/regression/backspace_2.f @@ -0,0 +1,22 @@ +! { dg-do run { target fd_truncate } } +! PR25139 Repeated backspaces and reads. +! Derived from example given in PR by Dale Ranta and FX Coudert +! Contributed by Jerry DeLisle + integer dat(5) + dat = (/ 0, 0, 0, 0, 1 /) + write(11) dat,dat,dat,dat + rewind 11 + write(11) dat + read(11,end=1008) dat + STOP 1 + 1008 continue + backspace 11 + write(11) dat + read(11,end=1011) dat + STOP 2 + 1011 continue + backspace 11 + backspace 11 + close(11, status='delete') + end + diff --git a/Fortran/gfortran/regression/backspace_3.f b/Fortran/gfortran/regression/backspace_3.f --- /dev/null +++ b/Fortran/gfortran/regression/backspace_3.f @@ -0,0 +1,20 @@ +! { dg-do run } +! PR25598 Error on repeated backspaces. +! Derived from example given in PR by Dale Ranta +! Contributed by Jerry DeLisle + integer data + data=-1 + open(unit=11,status='scratch',form='unformatted') + write(11)data + read(11,end= 1000 )data + STOP 1 + 1000 continue + backspace 11 + backspace 11 + backspace 11 + read(11,end= 1001 )data + 1001 continue + if (data.ne.-1) STOP 1 + close(11) + end + diff --git a/Fortran/gfortran/regression/backspace_4.f b/Fortran/gfortran/regression/backspace_4.f --- /dev/null +++ b/Fortran/gfortran/regression/backspace_4.f @@ -0,0 +1,18 @@ +! { dg-do run } +! PR25598 Error on repeated backspaces. +! Derived from example given in PR by Dale Ranta +! Contributed by Jerry DeLisle + integer data + data=-1 + open(unit=11,status='scratch',form='unformatted') + write(11)data + read(11,end= 1000 )data + STOP 1 + 1000 continue + backspace 11 + backspace 11 + read(11,end= 1001 )data + 1001 continue + if (data.ne.-1) STOP 1 + close(11) + end diff --git a/Fortran/gfortran/regression/backspace_5.f b/Fortran/gfortran/regression/backspace_5.f --- /dev/null +++ b/Fortran/gfortran/regression/backspace_5.f @@ -0,0 +1,35 @@ +!{ dg-do run } +! PR26464 File I/O error related to buffering and BACKSPACE +! Test case derived from case by Dale Ranta. +! Submitted by Jerry DeLisle + program test + integer,parameter :: datasize = 1000 + dimension idata(datasize) + idata = -42 + open (11, status="scratch", form="unformatted") + idata(1) = -1 + idata( datasize) = -2 + write(11)idata + idata(1) = -2 + idata( datasize) = -3 + write(11)idata + idata(1) = -3 + idata( datasize) = -4 + write(11)idata + idata(1) = -4 + idata( datasize) = -5 + write(11)idata + read(11,end= 1000 )idata + STOP 1 + 1000 continue + backspace 11 + backspace 11 + backspace 11 + read(11,end= 1001 )idata + if(idata(1).ne.-3 .or. idata(datasize).ne.-4) STOP 2 + stop + 1001 continue + STOP 3 + 1010 stop + end + diff --git a/Fortran/gfortran/regression/backspace_6.f b/Fortran/gfortran/regression/backspace_6.f --- /dev/null +++ b/Fortran/gfortran/regression/backspace_6.f @@ -0,0 +1,34 @@ +!{ dg-do run { target fd_truncate } } +! PR26464 File I/O error related to buffering and BACKSPACE +! Test case derived from case by Dale Ranta. +! Submitted by Jerry DeLisle + program test + integer,parameter :: datasize = 5000 + dimension idata(datasize) + idata = -42 + open (11, status="scratch", form="unformatted") + idata(1) = -1 + idata(datasize) = -2 + write(11)idata + idata(1) = -2 + idata(datasize) = -3 + write(11)idata + idata(1) = -3 + idata(datasize) = -4 + write(11)idata + backspace 11 + backspace 11 + idata(1) = -2 + idata(datasize) = -3 + write(11)idata + read(11,end= 1003 )idata + STOP 1 + 1003 continue + backspace 11 + backspace 11 + read(11,end= 1004 )idata + if(idata(1).ne.-2 .or.idata(datasize).ne.-3) STOP 2 + stop + 1004 continue + end + diff --git a/Fortran/gfortran/regression/backspace_7.f90 b/Fortran/gfortran/regression/backspace_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/backspace_7.f90 @@ -0,0 +1,11 @@ +! { dg-do run { target fd_truncate } } +!pr18284 BACKSPACE broken + open(unit=10,access='SEQUENTIAL',status='SCRATCH') + do I = 1,200 + write(10,*)I + end do + backspace(10) + backspace(10) + read(10,*)I + if (I.NE.199) STOP 1 + end diff --git a/Fortran/gfortran/regression/backspace_8.f b/Fortran/gfortran/regression/backspace_8.f --- /dev/null +++ b/Fortran/gfortran/regression/backspace_8.f @@ -0,0 +1,20 @@ +C { dg-do run } +C { dg-options "-std=legacy" } +C +C PR libfortran/31618 - backspace after an error didn't work. + program main + character*78 msg + open (21, file="backspace_7.dat", form="unformatted") + write (21) 42, 43 + write (21) 4711, 4712 + write (21) -1, -4 + rewind (21) + read (21) i,j + read (21,err=100,end=100) i,j,k + STOP 1 + 100 continue + backspace 21 + read (21) i,j + if (i .ne. 4711 .or. j .ne. 4712) STOP 2 + close (21,status="delete") + end diff --git a/Fortran/gfortran/regression/backspace_9.f b/Fortran/gfortran/regression/backspace_9.f --- /dev/null +++ b/Fortran/gfortran/regression/backspace_9.f @@ -0,0 +1,57 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR32235 incorrectly position text file after backspace +! Test case from PR, prepared by Jerry DeLisle + program main + character*10 a + ncards=2 + input=10 + write(10,"(a)") "One" + write(10,"(a)") "Two" + write(10,"(a)") "Three" + rewind(10) + read(input,1000)a + read(input,1000)a + + call inlist(ncards) + + read(input,1000)a + if (a.ne."Three") STOP 1 + close(10,status="delete") + stop + 1000 format(a10) + 2000 format('read =',a10) + end + + subroutine inlist(ncards) + character*4 data(20) + input=10 +c + if (ncards.eq.0) go to 20 + do 15 i=1,ncards + backspace input + 15 continue +c + 20 continue + kard = 0 + 30 read(input,1000,end=60) data + 40 kard=kard + 1 + 50 continue + if ((kard .eq. 1) .and. (DATA(1) .ne. "One")) STOP 2 + if ((kard .eq. 2) .and. (DATA(1) .ne. "Two")) STOP 3 + if ((kard .eq. 3) .and. (DATA(1) .ne. "Thre")) STOP 4 + + go to 30 + 60 continue + kard=kard - ncards + 1 + do 70 i=1,kard + backspace input + 70 continue +c + return +c + 1000 format (20a4) + 2020 format (8x,i15,8x,20a4) +c + end diff --git a/Fortran/gfortran/regression/backtrace_1.f90 b/Fortran/gfortran/regression/backtrace_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/backtrace_1.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! +! Check that BACKTRACE is available on all targets. We cannot actually +! check its output, but we should at least be able to call it, then exit +! normally. +! +program test + call backtrace + stop +end program test diff --git a/Fortran/gfortran/regression/bad_automatic_objects_1.f90 b/Fortran/gfortran/regression/bad_automatic_objects_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bad_automatic_objects_1.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! Tests the fix for 25103, in which the presence of automatic objects +! in the main program and the specification part of a module was not +! detected. +! +! Contributed by Joost VandeVondele +! +! Error message update with patch for PR fortran/83633 +! +module foo + integer :: i +end module foo +module bar + use foo + integer, dimension (i) :: j ! { dg-error "array with nonconstant bounds" } + character (len = i) :: c1 ! { dg-error "must have constant character length" } +end module bar +program foobar + use foo + integer, dimension (i) :: k ! { dg-error "array with nonconstant bounds" } + character (len = i) :: c2 ! { dg-error "must have constant character length" } +end program foobar diff --git a/Fortran/gfortran/regression/bad_operands.f90 b/Fortran/gfortran/regression/bad_operands.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bad_operands.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! Test case contributed by Mark Eggleston + +program test + integer(4) :: x + + x = x // "rubbish" ! { dg-error "INTEGER\\(4\\)/CHARACTER\\(7\\)" } + x = 4_"more rubbish" + 6 ! { dg-error "CHARACTER\\(12,4\\)/INTEGER\\(4\\)" } +end program diff --git a/Fortran/gfortran/regression/badline.f b/Fortran/gfortran/regression/badline.f --- /dev/null +++ b/Fortran/gfortran/regression/badline.f @@ -0,0 +1,8 @@ + subroutine foo +# illegal +# 18 "src/badline.F" 2 +# illegal + end +! { dg-warning "Illegal" "" { target *-*-* } 2 } +! { dg-warning "left but not entered" "" { target *-*-* } 3 } +! { dg-warning "Illegal" "" { target *-*-* } 4 } diff --git a/Fortran/gfortran/regression/bessel_1.f90 b/Fortran/gfortran/regression/bessel_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bessel_1.f90 @@ -0,0 +1,37 @@ +! { dg-do run } + +program test + implicit none + + interface check + procedure check_r4 + procedure check_r8 + end interface check + + real(kind=4) :: x4 + real(kind=8) :: x8 + + x8 = 1.9_8 ; x4 = 1.9_4 + call check(bessel_j0 (x8), bessel_j0 (1.9_8)) + call check(bessel_j0 (x4), bessel_j0 (1.9_4)) + call check(bessel_j1 (x8), bessel_j1 (1.9_8)) + call check(bessel_j1 (x4), bessel_j1 (1.9_4)) + call check(bessel_jn (3,x8), bessel_jn (3,1.9_8)) + call check(bessel_jn (3,x4), bessel_jn (3,1.9_4)) + call check(bessel_y0 (x8), bessel_y0 (1.9_8)) + call check(bessel_y0 (x4), bessel_y0 (1.9_4)) + call check(bessel_y1 (x8), bessel_y1 (1.9_8)) + call check(bessel_y1 (x4), bessel_y1 (1.9_4)) + call check(bessel_yn (3,x8), bessel_yn (3,1.9_8)) + call check(bessel_yn (3,x4), bessel_yn (3,1.9_4)) + +contains + subroutine check_r4 (a, b) + real(kind=4), intent(in) :: a, b + if (abs(a - b) > 1.e-5 * abs(b)) STOP 1 + end subroutine + subroutine check_r8 (a, b) + real(kind=8), intent(in) :: a, b + if (abs(a - b) > 1.e-7 * abs(b)) STOP 2 + end subroutine +end program test diff --git a/Fortran/gfortran/regression/bessel_2.f90 b/Fortran/gfortran/regression/bessel_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bessel_2.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! PR fortran/36117 +! +! This program will fail for MPFR < 2.3.0 +! +! Based on a test by James Van Buskirk. +! +program bug3 + implicit none + real, parameter :: Qarg1 = 1.7 + integer, parameter :: k2 = kind(BESJ0(Qarg1)) + integer, parameter :: is_int = 1-1/(2+0*BESJ0(Qarg1))*2 + integer, parameter :: kind_if_real = & + (1-is_int)*k2+is_int*kind(1.0) + complex :: z = cmplx(0,1,kind_if_real) ! FAILS + if (kind_if_real /= kind(Qarg1)) STOP 1 +end program bug3 diff --git a/Fortran/gfortran/regression/bessel_3.f90 b/Fortran/gfortran/regression/bessel_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bessel_3.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-std=f2003 -Wimplicit-procedure" } +! +! PR fortran/36158 - Transformational BESSEL_JN/YN +! PR fortran/33197 - F2008 math functions +! +IMPLICIT NONE +print *, SIN (1.0) +print *, BESSEL_J0(1.0) ! { dg-error "has no IMPLICIT type" }) +print *, BESSEL_J1(1.0) ! { dg-error "has no IMPLICIT type" } +print *, BESSEL_JN(1,1.0) ! { dg-error "has no IMPLICIT type|Type mismatch" } +print *, BESSEL_JN(1,2,1.0) ! { dg-error "has no IMPLICIT type|Type mismatch|More actual than formal" } + +print *, BESSEL_Y0(1.0) ! { dg-error "has no IMPLICIT type" } +print *, BESSEL_Y1(1.0) ! { dg-error "has no IMPLICIT type" } +print *, BESSEL_YN(1,1.0) ! { dg-error "has no IMPLICIT type|Type mismatch" } +print *, BESSEL_YN(1,2,1.0) ! { dg-error "has no IMPLICIT type|Type mismatch|More actual than formal" } +end diff --git a/Fortran/gfortran/regression/bessel_4.f90 b/Fortran/gfortran/regression/bessel_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bessel_4.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +! PR fortran/36158 - Transformational BESSEL_JN/YN +! PR fortran/33197 - F2008 math functions +! +implicit none +! OK, elemental function: + print *, bessel_yn(1, [1.0, 2.0]) + print *, bessel_yn([1, 2], 2.0) + +! Wrong, transformational function: +! Does not pass check.c -- thus regarded as wrong generic function +! and thus rejected with a slightly misleading error message + print *, bessel_yn(1, 2, [2.0, 3.0]) ! { dg-error "Too many arguments" } + +! Wrong in F2008: Negative argument, ok as GNU extension + print *, bessel_yn(-1, 3.0) ! { dg-error "Extension: Negative argument N " } + +! Wrong in F2008: Negative argument -- and no need for a GNU extension +! Does not pass check.c -- thus regarded as wrong generic function +! and thus rejected with a slightly misleading error message + print *, bessel_yn(-1, 2, 3.0) ! { dg-error "Too many arguments" } +end diff --git a/Fortran/gfortran/regression/bessel_5.f90 b/Fortran/gfortran/regression/bessel_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bessel_5.f90 @@ -0,0 +1,86 @@ +! { dg-do run } +! { dg-options "-Wall -fno-range-check" } +! +! PR fortran/36158 - Transformational BESSEL_JN/YN +! PR fortran/33197 - F2008 math functions +! +! This is a dg-do run test as the middle end cannot simplify the +! the scalarization of the elemental function (cf. PR 45305). +! +! -Wall has been specified to disabled -pedantic, which warns about the +! negative order (GNU extension) to the order of the Bessel functions of +! first and second kind. +! + +implicit none +integer :: i + + +! Difference to mpfr_jn <= 1 epsilon + +if (any (abs (BESSEL_JN(2, 5, 2.457) - [(BESSEL_JN(i, 2.457), i = 2, 5)]) & + > epsilon(0.0))) then + print *, 'FAIL 1' + STOP 1 +end if + + +! Difference to mpfr_yn <= 4 epsilon + +if (any (abs (BESSEL_YN(2, 5, 2.457) - [(BESSEL_YN(i, 2.457), i = 2, 5)]) & + > epsilon(0.0)*4)) then + STOP 2 +end if + + +! Difference to mpfr_jn <= 1 epsilon + +if (any (abs (BESSEL_JN(0, 10, 4.457) & + - [ (BESSEL_JN(i, 4.457), i = 0, 10) ]) & + > epsilon(0.0))) then + STOP 3 +end if + + +! Difference to mpfr_yn <= 192 epsilon + +if (any (abs (BESSEL_YN(0, 10, 4.457) & + - [ (BESSEL_YN(i, 4.457), i = 0, 10) ]) & + > epsilon(0.0)*192)) then + STOP 4 +end if + + +! Difference to mpfr_jn: None. (Special case: X = 0.0) + +if (any (BESSEL_JN(0, 10, 0.0) /= [ (BESSEL_JN(i, 0.0), i = 0, 10) ])) & +then + STOP 5 +end if + + +! Difference to mpfr_yn: None. (Special case: X = 0.0) + +if (any (BESSEL_YN(0, 10, 0.0) /= [ (BESSEL_YN(i, 0.0), i = 0, 10) ])) & +then + STOP 6 +end if + + +! Difference to mpfr_jn <= 1 epsilon + +if (any (abs (BESSEL_JN(0, 10, 1.0) & + - [ (BESSEL_JN(i, 1.0), i = 0, 10) ]) & + > epsilon(0.0)*1)) then + STOP 7 +end if + +! Difference to mpfr_yn <= 32 epsilon + +if (any (abs (BESSEL_YN(0, 10, 1.0) & + - [ (BESSEL_YN(i, 1.0), i = 0, 10) ]) & + > epsilon(0.0)*32)) then + STOP 8 +end if + +end diff --git a/Fortran/gfortran/regression/bessel_5_redux.f90 b/Fortran/gfortran/regression/bessel_5_redux.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bessel_5_redux.f90 @@ -0,0 +1,85 @@ +! { dg-do compile } +! { dg-options "-Wall" } +! +! Check fix for PR94246 in which the errors in line 63 caused a segfault +! because the cleanup was not done correctly without the -fno-range-check option. +! +! This is a copy of bessel_5.f90 with the error messages added. +! +! -Wall has been specified to disabled -pedantic, which warns about the +! negative order (GNU extension) to the order of the Bessel functions of +! first and second kind. +! + +implicit none +integer :: i + + +! Difference to mpfr_jn <= 1 epsilon + +if (any (abs (BESSEL_JN(2, 5, 2.457) - [(BESSEL_JN(i, 2.457), i = 2, 5)]) & + > epsilon(0.0))) then + print *, 'FAIL 1' + STOP 1 +end if + + +! Difference to mpfr_yn <= 4 epsilon + +if (any (abs (BESSEL_YN(2, 5, 2.457) - [(BESSEL_YN(i, 2.457), i = 2, 5)]) & + > epsilon(0.0)*4)) then + STOP 2 +end if + + +! Difference to mpfr_jn <= 1 epsilon + +if (any (abs (BESSEL_JN(0, 10, 4.457) & + - [ (BESSEL_JN(i, 4.457), i = 0, 10) ]) & + > epsilon(0.0))) then + STOP 3 +end if + + +! Difference to mpfr_yn <= 192 epsilon + +if (any (abs (BESSEL_YN(0, 10, 4.457) & + - [ (BESSEL_YN(i, 4.457), i = 0, 10) ]) & + > epsilon(0.0)*192)) then + STOP 4 +end if + + +! Difference to mpfr_jn: None. (Special case: X = 0.0) + +if (any (BESSEL_JN(0, 10, 0.0) /= [ (BESSEL_JN(i, 0.0), i = 0, 10) ])) & +then + STOP 5 +end if + + +! Difference to mpfr_yn: None. (Special case: X = 0.0) + +if (any (BESSEL_YN(0, 10, 0.0) /= [ (BESSEL_YN(i, 0.0), i = 0, 10) ])) & ! { dg-error "overflows|-INF" } +then + STOP 6 +end if + + +! Difference to mpfr_jn <= 1 epsilon + +if (any (abs (BESSEL_JN(0, 10, 1.0) & + - [ (BESSEL_JN(i, 1.0), i = 0, 10) ]) & + > epsilon(0.0)*1)) then + STOP 7 +end if + +! Difference to mpfr_yn <= 32 epsilon + +if (any (abs (BESSEL_YN(0, 10, 1.0) & + - [ (BESSEL_YN(i, 1.0), i = 0, 10) ]) & + > epsilon(0.0)*32)) then + STOP 8 +end if + +end diff --git a/Fortran/gfortran/regression/bessel_6.f90 b/Fortran/gfortran/regression/bessel_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bessel_6.f90 @@ -0,0 +1,46 @@ +! { dg-add-options ieee } +! +! PR fortran/36158 +! PR fortran/33197 +! +! Run-time tests for transformations BESSEL_JN +! +implicit none +real,parameter :: values(*) = [0.0, 0.5, 1.0, 0.9, 1.8,2.0,3.0,4.0,4.25,8.0,34.53, 475.78] +real,parameter :: myeps(size(values)) = epsilon(0.0) & + * [2, 7, 5, 6, 9, 12, 12, 7, 7, 8, 98, 15 ] +! The following is sufficient for me - the values above are a bit +! more tolerant +! * [0, 5, 3, 4, 6, 7, 7, 5, 5, 6, 66, 4 ] +integer,parameter :: mymax(size(values)) = & + [100, 17, 23, 21, 27, 28, 32, 35, 31, 41, 47, 37 ] +integer, parameter :: Nmax = 100 +real :: rec(0:Nmax), lib(0:Nmax) +integer :: i + +do i = 1, ubound(values,dim=1) + call compare(mymax(i), values(i), myeps(i)) +end do + +contains + +subroutine compare(mymax, X, myeps) + +integer :: i, nit, mymax +real X, myeps, myeps2 + +rec(0:mymax) = BESSEL_JN(0, mymax, X) +lib(0:mymax) = [ (BESSEL_JN(i, X), i=0,mymax) ] + +!print *, 'YN for X = ', X, ' -- Epsilon = ',epsilon(x) +do i = 0, mymax +! print '(i2,2e17.9,e12.2,f18.10,2l3)', i, rec(i), lib(i), & +! rec(i)-lib(i), ((rec(i)-lib(i))/rec(i))/epsilon(x), & +! rec(i) == lib(i), abs((rec(i)-lib(i))/rec(i)) < myeps +if (rec(i) == lib(i)) CYCLE +if (abs((rec(i)-lib(i))/rec(i)) > myeps) & + STOP 1 +end do + +end +end diff --git a/Fortran/gfortran/regression/bessel_7.f90 b/Fortran/gfortran/regression/bessel_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bessel_7.f90 @@ -0,0 +1,55 @@ +! { dg-do run { xfail *-*-mingw* } } +! { dg-add-options ieee } +! +! PR fortran/36158 +! PR fortran/33197 +! +! For mingw targets this test is disabled as the MS implementation +! of BESSEL_YN(n,x) has different results. It returns NAN rather than +! -INF for "x=0.0" and all "n". +! +! Run-time tests for transformations BESSEL_YN +! +implicit none +real,parameter :: values(*) = [0.0, 0.5, 1.0, 0.9, 1.8,2.0,3.0,4.0,4.25,8.0,34.53, 475.78] +real,parameter :: myeps(size(values)) = epsilon(0.0) & + * [2, 3, 4, 5, 8, 2, 13, 6, 7, 6, 36, 168 ] +! The following is sufficient for me - the values above are a bit +! more tolerant +! * [0, 0, 0, 3, 3, 0, 9, 0, 2, 1, 22, 130 ] +integer,parameter :: nit(size(values)) = & + [100, 100, 100, 25, 15, 100, 10, 31, 7, 100, 7, 25 ] +integer, parameter :: Nmax = 100 +real :: rec(0:Nmax), lib(0:Nmax) +integer :: i + +do i = 1, ubound(values,dim=1) + call compare(values(i), myeps(i), nit(i), 6*epsilon(0.0)) +end do + +contains + +subroutine compare(X, myeps, nit, myeps2) + +integer :: i, nit +real X, myeps, myeps2 + +rec = BESSEL_YN(0, Nmax, X) +lib = [ (BESSEL_YN(i, X), i=0,Nmax) ] + +!print *, 'YN for X = ', X, ' -- Epsilon = ',epsilon(x) +do i = 0, Nmax +! print '(i2,2e17.9,e12.2,f14.10,2l3)', i, rec(i), lib(i), & +! rec(i)-lib(i), ((rec(i)-lib(i))/rec(i))/epsilon(x), & +! i > nit .or. rec(i) == lib(i) & +! .or. abs((rec(i)-lib(i))/rec(i)) < myeps2, & +! rec(i) == lib(i) .or. abs((rec(i)-lib(i))/rec(i)) < myeps +if (.not. (i > nit .or. rec(i) == lib(i) & + .or. abs((rec(i)-lib(i))/rec(i)) < myeps2)) & + STOP 1 +if (.not. (rec(i) == lib(i) .or. abs((rec(i)-lib(i))/rec(i)) < myeps)) & + STOP 2 +end do + +end +end diff --git a/Fortran/gfortran/regression/besxy.f90 b/Fortran/gfortran/regression/besxy.f90 --- /dev/null +++ b/Fortran/gfortran/regression/besxy.f90 @@ -0,0 +1,41 @@ +! { dg-do compile } +! +! Check whether BESXY functions take scalars and +! arrays as arguments (PR31760). +! +PROGRAM test_erf + REAL :: r = 0.0, ra(2) = (/ 0.0, 1.0 /) + + r = BESJ0(r) + r = BESJ1(r) + r = BESJN(0, r) + + r = BESY0(r) + r = BESY1(r) + r = BESYN(0, r) + + ra = BESJ0(ra) + ra = BESJ1(ra) + ra = BESJN(0, ra) + + ra = BESY0(ra) + ra = BESY1(ra) + ra = BESYN(0, ra) + + r = BESSEL_J0(r) + r = BESSEL_J1(r) + r = BESSEL_JN(0, r) + + r = BESSEL_Y0(r) + r = BESSEL_Y1(r) + r = BESSEL_YN(0, r) + + ra = BESSEL_J0(ra) + ra = BESSEL_J1(ra) + ra = BESSEL_JN(0, ra) + + ra = BESSEL_Y0(ra) + ra = BESSEL_Y1(ra) + ra = BESSEL_YN(0, ra) + +END PROGRAM diff --git a/Fortran/gfortran/regression/bind-c-char-descr.f90 b/Fortran/gfortran/regression/bind-c-char-descr.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind-c-char-descr.f90 @@ -0,0 +1,123 @@ +! PR fortran/92482 +! +! Contributed by José Rui Faustino de Sousa +! + +program strp_p + + use, intrinsic :: iso_c_binding, only: & + c_char + + implicit none + + integer, parameter :: l = 3 + + character(len=l, kind=c_char), target :: str + character(len=:, kind=c_char), pointer :: strp_1 + character(len=l, kind=c_char), pointer :: strp_2 + + str = "abc" + nullify(strp_1, strp_2) + strp_1 => str + strp_2 => str + if (len(str) /= 3 .or. str /= "abc") stop 1 + if (len(strp_1) /= 3 .or. strp_1 /= "abc") stop 2 + if (len(strp_2) /= 3 .or. strp_2 /= "abc") stop 3 + call strg_print_0("abc") + call strg_print_0(str) + call strg_print_0(strp_1) + call strg_print_0(strp_2) + call strg_print_0_c("abc") + call strg_print_0_c(str) + call strg_print_0_c(strp_1) + call strg_print_0_c(strp_2) + call strg_print_1(strp_1) + call strg_print_1_c(strp_1) + + call strg_print_2("abc") + call strg_print_2(str) + call strg_print_2(strp_1) + call strg_print_2(strp_2) + + call strg_print_2_c("abc") + call strg_print_2_c(str) + call strg_print_2_c(strp_1) + call strg_print_2_c(strp_2) + +contains + + subroutine strg_print_0 (this) + character(len=*, kind=c_char), target, intent(in) :: this + + if (len (this) /= 3) stop 10 + if (this /= "abc") stop 11 + end subroutine strg_print_0 + + subroutine strg_print_0_c (this) bind(c) + character(len=*, kind=c_char), target, intent(in) :: this + + if (len (this) /= 3) stop 10 + if (this /= "abc") stop 11 + end subroutine strg_print_0_c + + subroutine strg_print_1 (this) bind(c) + character(len=:, kind=c_char), pointer, intent(in) :: this + character(len=:), pointer :: strn + + if (.not. associated (this)) stop 20 + if (len (this) /= 3) stop 21 + if (this /= "abc") stop 22 + strn => this + if (.not. associated (strn)) stop 23 + if(associated(strn))then + if (len (this) /= 3) stop 24 + if (this /= "abc") stop 25 + end if + end subroutine strg_print_1 + + subroutine strg_print_1_c (this) bind(c) + character(len=:, kind=c_char), pointer, intent(in) :: this + character(len=:), pointer :: strn + + if (.not. associated (this)) stop 20 + if (len (this) /= 3) stop 21 + if (this /= "abc") stop 22 + strn => this + if (.not. associated (strn)) stop 23 + if(associated(strn))then + if (len (this) /= 3) stop 24 + if (this /= "abc") stop 25 + end if + end subroutine strg_print_1_c + + subroutine strg_print_2(this) + use, intrinsic :: iso_c_binding, only: & + c_loc, c_f_pointer + + type(*), target, intent(in) :: this(..) + character(len=l), pointer :: strn + + call c_f_pointer(c_loc(this), strn) + if (.not. associated (strn)) stop 30 + if (associated(strn)) then + if (len (strn) /= 3) stop 31 + if (strn /= "abc") stop 32 + end if + end subroutine strg_print_2 + + subroutine strg_print_2_c(this) bind(c) + use, intrinsic :: iso_c_binding, only: & + c_loc, c_f_pointer + + type(*), target, intent(in) :: this(..) + character(len=l), pointer :: strn + + call c_f_pointer(c_loc(this), strn) + if (.not. associated (strn)) stop 40 + if(associated(strn))then + if (len (strn) /= 3) stop 41 + if (strn /= "abc") stop 42 + end if + end subroutine strg_print_2_c + +end program strp_p diff --git a/Fortran/gfortran/regression/bind-c-contiguous-1.c b/Fortran/gfortran/regression/bind-c-contiguous-1.c --- /dev/null +++ b/Fortran/gfortran/regression/bind-c-contiguous-1.c @@ -0,0 +1,345 @@ +#include +#include +#include + +struct loc_t { + intptr_t x, y, z; +}; + +typedef struct loc_t (*ftn_fn) (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_size_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_size_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_expl_size_f (CFI_cdesc_t *,CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_expl_size_in_f (CFI_cdesc_t *,CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_rank_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_rank_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_rank_cont_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_rank_cont_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_shape_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_shape_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_shape_cont_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_shape_cont_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); + +static void +basic_check(CFI_cdesc_t *x, bool is_cont) +{ + if (!x->base_addr) + __builtin_abort (); + if (x->elem_len != 3*sizeof(char)) + __builtin_abort (); + if (x->version != CFI_VERSION) + __builtin_abort (); + if (x->rank != 1) + __builtin_abort (); + if (x->attribute != CFI_attribute_other) + __builtin_abort (); + if (x->type != CFI_type_char) + __builtin_abort (); + if (x->dim[0].lower_bound != 0) + __builtin_abort (); + if (x->dim[0].extent != 3) + __builtin_abort (); + if (CFI_is_contiguous (x) != (x->elem_len == x->dim[0].sm)) + __builtin_abort (); + if (is_cont != CFI_is_contiguous (x)) + __builtin_abort (); +} + +static void +print_str (void *p, size_t len) +{ + __builtin_printf ("DEBUG: >"); + for (size_t i = 0; i < len; ++i) + __builtin_printf ("%c", ((const char*) p)[i]); + __builtin_printf ("<\n"); +} + +static void +check_str (CFI_cdesc_t *x, const char *str, const CFI_index_t subscripts[]) +{ + /* Avoid checking for '\0'. */ + if (strncmp ((const char*) CFI_address (x, subscripts), str, strlen(str)) != 0) + __builtin_abort (); +} + +static void +set_str (CFI_cdesc_t *x, const char *str, const CFI_index_t subscripts[]) +{ + char *p = CFI_address (x, subscripts); + size_t len = strlen (str); + if (x->elem_len != len) + __builtin_abort (); + for (size_t i = 0; i < len; ++i) + p[i] = str[i]; +} + +static struct loc_t +do_call (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num, bool intent_in, ftn_fn fn, bool is_cont, bool fort_cont) +{ + const CFI_index_t zero[1] = { 0 }; + const CFI_index_t one[1] = { 1 }; + const CFI_index_t two[1] = { 2 }; + struct loc_t addr1, addr2; + if (k != 3) + __builtin_abort (); + basic_check (x, is_cont || num == 2); + basic_check (y, is_cont || num == 2); + basic_check (z, is_cont || num == 2); + if (!is_cont && num == 1) + { + check_str (x, "abc", zero); + check_str (x, "ghi", one); + check_str (x, "nop", two); + check_str (y, "abc", zero); + check_str (y, "ghi", one); + check_str (y, "nop", two); + check_str (z, "abc", zero); + check_str (z, "ghi", one); + check_str (z, "nop", two); + } + else if (num == 1) + { + if (strncmp ((const char*) x->base_addr, "abcghinop", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) y->base_addr, "abcghinop", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) z->base_addr, "abcghinop", 9) != 0) + __builtin_abort (); + } + else if (num == 2) + { + if (strncmp ((const char*) x->base_addr, "defghijlm", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) y->base_addr, "defghijlm", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) z->base_addr, "defghijlm", 9) != 0) + __builtin_abort (); + } + else + __builtin_abort (); + addr1.x = (intptr_t) x->base_addr; + addr1.y = (intptr_t) y->base_addr; + addr1.z = (intptr_t) z->base_addr; + addr2 = fn (x, y, z, 3, num); + if (!CFI_is_contiguous (x) && fort_cont) + { + /* Check for callee copy in/copy out. */ + if (addr1.x == addr2.x || addr1.x != (intptr_t) x->base_addr) + __builtin_abort (); + if (addr1.y == addr2.y || addr1.y != (intptr_t) y->base_addr) + __builtin_abort (); + if (addr1.z == addr2.z || addr1.z != (intptr_t) z->base_addr) + __builtin_abort (); + } + else + { + if (addr1.x != addr2.x || addr1.x != (intptr_t) x->base_addr) + __builtin_abort (); + if (addr1.y != addr2.y || addr1.y != (intptr_t) y->base_addr) + __builtin_abort (); + if (addr1.z != addr2.z || addr1.z != (intptr_t) z->base_addr) + __builtin_abort (); + } + // intent_in + if (intent_in && !is_cont && num == 1) + { + check_str (x, "abc", zero); + check_str (x, "ghi", one); + check_str (x, "nop", two); + check_str (y, "abc", zero); + check_str (y, "ghi", one); + check_str (y, "nop", two); + check_str (z, "abc", zero); + check_str (z, "ghi", one); + check_str (z, "nop", two); + } + else if (intent_in && num == 1) + { + if (strncmp ((const char*) x->base_addr, "abcghinop", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) y->base_addr, "abcghinop", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) z->base_addr, "abcghinop", 9) != 0) + __builtin_abort (); + } + else if (intent_in && num == 2) + { + if (strncmp ((const char*) x->base_addr, "defghijlm", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) y->base_addr, "defghijlm", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) z->base_addr, "defghijlm", 9) != 0) + __builtin_abort (); + } + else if (intent_in) + __builtin_abort (); + if (intent_in) + { + if (is_cont && num == 1) + { + /* Copy in - set the value to check that no copy out is done. */ + memcpy ((char*) x->base_addr, "123456789", 9); + memcpy ((char*) y->base_addr, "123456789", 9); + memcpy ((char*) z->base_addr, "123456789", 9); + } + return addr1; + } + // !intent_in + if (!is_cont && num == 1) + { + check_str (x, "ABC", zero); + check_str (x, "DEF", one); + check_str (x, "GHI", two); + check_str (y, "ABC", zero); + check_str (y, "DEF", one); + check_str (y, "GHI", two); + check_str (z, "ABC", zero); + check_str (z, "DEF", one); + check_str (z, "GHI", two); + } + else + { + if (strncmp ((const char*) x->base_addr, "ABCDEFGHI", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) y->base_addr, "ABCDEFGHI", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) z->base_addr, "ABCDEFGHI", 9) != 0) + __builtin_abort (); + } + return addr1; +} + +struct loc_t +char_assumed_size_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_assumed_size_f, true, false); +} + +struct loc_t +char_assumed_size_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_size_in_f, true, false); +} + +struct loc_t +char_expl_size_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_expl_size_f, true, false); +} + +struct loc_t +char_expl_size_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_expl_size_in_f, true, false); +} + +struct loc_t +char_assumed_rank_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_assumed_rank_f, false, false); +} + +struct loc_t +char_assumed_rank_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_rank_in_f, false, false); +} + +struct loc_t +char_assumed_rank_cont_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_assumed_rank_cont_f, true, false); +} + +struct loc_t +char_assumed_rank_cont_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_rank_cont_in_f, true, false); +} + +static void +reset_var (CFI_cdesc_t *x, int num) +{ + const CFI_index_t zero[1] = { 0 }; + const CFI_index_t one[1] = { 1 }; + const CFI_index_t two[1] = { 2 }; + + if (num == 1) + { + set_str (x, "abc", zero); + set_str (x, "ghi", one); + set_str (x, "nop", two); + } + else if (num == 2) + { + set_str (x, "def", zero); + set_str (x, "ghi", one); + set_str (x, "jlm", two); + } + else + __builtin_abort (); +} + +static void +reset_vars (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, int num) +{ + reset_var (x, num); + reset_var (y, num); + reset_var (z, num); +} + +struct loc_t +char_assumed_shape_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + /* Make use of having a noncontiguous argument to check that the callee + handles noncontiguous variables. */ + do_call (x, y, z, k, num, false, char_assumed_size_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, true, char_assumed_size_in_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, false, char_expl_size_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, true, char_expl_size_in_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, false, char_assumed_rank_cont_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, true, char_assumed_rank_cont_in_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, false, char_assumed_shape_cont_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, true, char_assumed_shape_cont_in_f, false, true); + /* Actual func call. */ + reset_vars (x, y, z, num); + return do_call (x, y, z, k, num, false, char_assumed_shape_f, false, false); +} + +struct loc_t +char_assumed_shape_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_shape_in_f, false, false); +} + +struct loc_t +char_assumed_shape_cont_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_assumed_shape_cont_f, true, false); +} + +struct loc_t +char_assumed_shape_cont_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_shape_cont_in_f, true, false); +} diff --git a/Fortran/gfortran/regression/bind-c-contiguous-1.f90 b/Fortran/gfortran/regression/bind-c-contiguous-1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind-c-contiguous-1.f90 @@ -0,0 +1,1574 @@ +! { dg-do run } +! { dg-additional-sources bind-c-contiguous-1.c } +! { dg-additional-options "-fcheck=all" } +! { dg-additional-options -Wno-complain-wrong-lang } + +! Fortran demands that with bind(C), the callee ensure that for +! * 'contiguous' +! * len=* with explicit/assumed-size arrays +! noncontiguous actual arguments are handled. +! (in without bind(C) in gfortran, caller handles the copy in/out + +! Additionally, for a bind(C) callee, a Fortran-written caller +! has to ensure the same (for contiguous + len=* to explicit-/assumed-size arrays) + +module m + use iso_c_binding, only: c_intptr_t, c_bool, c_loc, c_int + implicit none (type, external) + + type, bind(C) :: loc_t + integer(c_intptr_t) :: x, y, z + end type loc_t + +interface + type(loc_t) function char_assumed_size_c (xx, yy, zz, n, num) bind(C) + import :: loc_t, c_bool, c_int + integer(c_int), value :: n, num + character(len=*) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*) + end function + + type(loc_t) function char_assumed_size_in_c (xx, yy, zz, n, num) bind(C) + import :: loc_t, c_bool, c_int + integer(c_int), value :: n, num + character(len=*), intent(in) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*) + end function + + type(loc_t) function char_expl_size_c (xx, yy, zz, n, num) bind(c) + import :: loc_t, c_bool, c_int + integer(c_int), value :: n, num + character(len=*) :: xx(n), yy(n:n+3), zz(6:6, 3:n, 3:n+3) + end function + + type(loc_t) function char_expl_size_in_c (xx, yy, zz, n, num) bind(c) + import :: loc_t, c_bool, c_int + integer(c_int), value :: n, num + character(len=*), intent(in) :: xx(n), yy(n:n+3), zz(6:6, 3:n, 3:n+3) + end function + + type(loc_t) function char_assumed_rank_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*) :: xx(..) + character(len=3) :: yy(..) + character(len=k) :: zz(..) + end function + + type(loc_t) function char_assumed_rank_in_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*), intent(in) :: xx(..) + character(len=3), intent(in) :: yy(..) + character(len=k), intent(in) :: zz(..) + end function + + type(loc_t) function char_assumed_rank_cont_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*), contiguous :: xx(..) + character(len=3), contiguous :: yy(..) + character(len=k), contiguous :: zz(..) + end function + + type(loc_t) function char_assumed_rank_cont_in_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*), contiguous, intent(in) :: xx(..) + character(len=3), contiguous, intent(in) :: yy(..) + character(len=k), contiguous, intent(in) :: zz(..) + end function + + type(loc_t) function char_assumed_shape_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*) :: xx(:) + character(len=3) :: yy(5:) + character(len=k) :: zz(-k:) + end function + + type(loc_t) function char_assumed_shape_in_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*), intent(in) :: xx(:) + character(len=3), intent(in) :: yy(5:) + character(len=k), intent(in) :: zz(-k:) + end function + + type(loc_t) function char_assumed_shape_cont_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*), contiguous :: xx(:) + character(len=3), contiguous :: yy(5:) + character(len=k), contiguous :: zz(-k:) + end function + + type(loc_t) function char_assumed_shape_cont_in_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*), contiguous, intent(in) :: xx(:) + character(len=3), contiguous, intent(in) :: yy(5:) + character(len=k), contiguous, intent(in) :: zz(-k:) + end function +end interface + +contains + +type(loc_t) function char_assumed_size_f (xx, yy, zz, n, num) bind(c) result(res) + integer, value :: num, n + character(len=*) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*) + print *, xx(1:3) + if (3 /= len(xx)) error stop 1 + if (3 /= len(yy)) error stop 1 + if (3 /= len(zz)) error stop 1 + if (1 /= lbound(xx,dim=1)) error stop 1 + if (3 /= lbound(yy,dim=1)) error stop 1 + if (6 /= lbound(zz,dim=1)) error stop 1 + if (3 /= lbound(zz,dim=2)) error stop 1 + if (3 /= lbound(zz,dim=3)) error stop 1 + if (1 /= size(zz,dim=1)) error stop 1 + if (1 /= size(zz,dim=2)) error stop 1 + if (6 /= ubound(zz,dim=1)) error stop 1 + if (3 /= ubound(zz,dim=2)) error stop 1 + if (num == 1) then + if (xx(1) /= "abc") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "nop") error stop 4 + if (yy(3) /= "abc") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "nop") error stop 4 + if (zz(6,n,3) /= "abc") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "nop") error stop 4 + else if (num == 2) then + if (xx(1) /= "def") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "jlm") error stop 4 + if (yy(3) /= "def") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "jlm") error stop 4 + if (zz(6,n,3) /= "def") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "jlm") error stop 4 + else + error stop 8 + endif + xx(1) = "ABC" + xx(2) = "DEF" + xx(3) = "GHI" + yy(3) = "ABC" + yy(4) = "DEF" + yy(5) = "GHI" + zz(6,n,3) = "ABC" + zz(6,n,4) = "DEF" + zz(6,n,5) = "GHI" + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + +type(loc_t) function char_assumed_size_in_f (xx, yy, zz, n, num) bind(c) result(res) + integer, value :: num, n + character(len=*) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*) + intent(in) :: xx, yy, zz + print *, xx(1:3) + if (3 /= len(xx)) error stop 1 + if (3 /= len(yy)) error stop 1 + if (3 /= len(zz)) error stop 1 + if (1 /= lbound(xx,dim=1)) error stop 1 + if (3 /= lbound(yy,dim=1)) error stop 1 + if (6 /= lbound(zz,dim=1)) error stop 1 + if (3 /= lbound(zz,dim=2)) error stop 1 + if (3 /= lbound(zz,dim=3)) error stop 1 + if (1 /= size(zz,dim=1)) error stop 1 + if (1 /= size(zz,dim=2)) error stop 1 + if (6 /= ubound(zz,dim=1)) error stop 1 + if (3 /= ubound(zz,dim=2)) error stop 1 + if (num == 1) then + if (xx(1) /= "abc") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "nop") error stop 4 + if (yy(3) /= "abc") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "nop") error stop 4 + if (zz(6,n,3) /= "abc") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "nop") error stop 4 + else if (num == 2) then + if (xx(1) /= "def") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "jlm") error stop 4 + if (yy(3) /= "def") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "jlm") error stop 4 + if (zz(6,n,3) /= "def") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "jlm") error stop 4 + else + error stop 8 + endif + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } if (num == 1) then +end + +type(loc_t) function char_expl_size_f (xx, yy, zz, n, num) bind(c) result(res) + integer, value :: num, n + character(len=*) :: xx(n), yy(n:n+2), zz(6:6, 3:n, 3:n+2) + print *, xx(1:3) + if (3 /= len(xx)) error stop 1 + if (3 /= len(yy)) error stop 1 + if (3 /= len(zz)) error stop 1 + if (1 /= lbound(xx,dim=1)) error stop 1 + if (3 /= lbound(yy,dim=1)) error stop 1 + if (6 /= lbound(zz,dim=1)) error stop 1 + if (3 /= lbound(zz,dim=2)) error stop 1 + if (3 /= lbound(zz,dim=3)) error stop 1 + if (3 /= size(xx,dim=1)) error stop 1 + if (3 /= size(yy,dim=1)) error stop 1 + if (1 /= size(zz,dim=1)) error stop 1 + if (1 /= size(zz,dim=2)) error stop 1 + if (3 /= size(zz,dim=3)) error stop 1 + if (3 /= ubound(xx,dim=1)) error stop 1 + if (5 /= ubound(yy,dim=1)) error stop 1 + if (6 /= ubound(zz,dim=1)) error stop 1 + if (3 /= ubound(zz,dim=2)) error stop 1 + if (5 /= ubound(zz,dim=3)) error stop 1 + if (num == 1) then + if (xx(1) /= "abc") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "nop") error stop 4 + if (yy(3) /= "abc") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "nop") error stop 4 + if (zz(6,n,3) /= "abc") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "nop") error stop 4 + else if (num == 2) then + if (xx(1) /= "def") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "jlm") error stop 4 + if (yy(3) /= "def") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "jlm") error stop 4 + if (zz(6,n,3) /= "def") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "jlm") error stop 4 + else + error stop 8 + endif + xx(1) = "ABC" + xx(2) = "DEF" + xx(3) = "GHI" + yy(3) = "ABC" + yy(4) = "DEF" + yy(5) = "GHI" + zz(6,n,3) = "ABC" + zz(6,n,4) = "DEF" + zz(6,n,5) = "GHI" + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + +type(loc_t) function char_expl_size_in_f (xx, yy, zz, n, num) bind(c) result(res) + integer, value :: num, n + character(len=*) :: xx(n), yy(n:n+2), zz(6:6, 3:n, 3:n+2) + intent(in) :: xx, yy, zz + print *, xx(1:3) + if (3 /= len(xx)) error stop 1 + if (3 /= len(yy)) error stop 1 + if (3 /= len(zz)) error stop 1 + if (1 /= lbound(xx,dim=1)) error stop 1 + if (3 /= lbound(yy,dim=1)) error stop 1 + if (6 /= lbound(zz,dim=1)) error stop 1 + if (3 /= lbound(zz,dim=2)) error stop 1 + if (3 /= lbound(zz,dim=3)) error stop 1 + if (3 /= size(xx,dim=1)) error stop 1 + if (3 /= size(yy,dim=1)) error stop 1 + if (1 /= size(zz,dim=1)) error stop 1 + if (1 /= size(zz,dim=2)) error stop 1 + if (3 /= size(zz,dim=3)) error stop 1 + if (3 /= ubound(xx,dim=1)) error stop 1 + if (5 /= ubound(yy,dim=1)) error stop 1 + if (6 /= ubound(zz,dim=1)) error stop 1 + if (3 /= ubound(zz,dim=2)) error stop 1 + if (5 /= ubound(zz,dim=3)) error stop 1 + if (num == 1) then + if (xx(1) /= "abc") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "nop") error stop 4 + if (yy(3) /= "abc") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "nop") error stop 4 + if (zz(6,n,3) /= "abc") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "nop") error stop 4 + else if (num == 2) then + if (xx(1) /= "def") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "jlm") error stop 4 + if (yy(3) /= "def") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "jlm") error stop 4 + if (zz(6,n,3) /= "def") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "jlm") error stop 4 + else + error stop 8 + endif + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + + +type(loc_t) function char_assumed_rank_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*) :: xx(..) + character(len=3) :: yy(..) + character(len=k) :: zz(..) + if (3 /= len(xx)) error stop 40 + if (3 /= len(yy)) error stop 40 + if (3 /= len(zz)) error stop 40 + if (3 /= size(xx)) error stop 41 + if (3 /= size(yy)) error stop 41 + if (3 /= size(zz)) error stop 41 + if (1 /= rank(xx)) error stop 49 + if (1 /= rank(yy)) error stop 49 + if (1 /= rank(zz)) error stop 49 + if (1 /= lbound(xx, dim=1)) stop 49 + if (1 /= lbound(yy, dim=1)) stop 49 + if (1 /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (3 /= ubound(yy, dim=1)) stop 49 + if (3 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (is_contiguous (xx)) error stop 49 + if (is_contiguous (yy)) error stop 49 + if (is_contiguous (zz)) error stop 49 + else if (num == 2) then + if (.not. is_contiguous (xx)) error stop 49 + if (.not. is_contiguous (yy)) error stop 49 + if (.not. is_contiguous (zz)) error stop 49 + else + error stop 48 + end if + select rank (xx) + rank (1) + print *, xx(1:3) + if (num == 1) then + if (xx(1) /= "abc") error stop 42 + if (xx(2) /= "ghi") error stop 43 + if (xx(3) /= "nop") error stop 44 + else if (num == 2) then + if (xx(1) /= "def") error stop 45 + if (xx(2) /= "ghi") error stop 46 + if (xx(3) /= "jlm") error stop 47 + else + error stop 48 + endif + xx(1) = "ABC" + xx(2) = "DEF" + xx(3) = "GHI" + res%x = get_loc (xx) + rank default + error stop 99 + end select + select rank (yy) + rank (1) + print *, yy(1:3) + if (num == 1) then + if (yy(1) /= "abc") error stop 42 + if (yy(2) /= "ghi") error stop 43 + if (yy(3) /= "nop") error stop 44 + else if (num == 2) then + if (yy(1) /= "def") error stop 45 + if (yy(2) /= "ghi") error stop 46 + if (yy(3) /= "jlm") error stop 47 + else + error stop 48 + endif + yy(1) = "ABC" + yy(2) = "DEF" + yy(3) = "GHI" + res%y = get_loc (yy) + rank default + error stop 99 + end select + select rank (zz) + rank (1) + print *, zz(1:3) + if (num == 1) then + if (zz(1) /= "abc") error stop 42 + if (zz(2) /= "ghi") error stop 43 + if (zz(3) /= "nop") error stop 44 + else if (num == 2) then + if (zz(1) /= "def") error stop 45 + if (zz(2) /= "ghi") error stop 46 + if (zz(3) /= "jlm") error stop 47 + else + error stop 48 + endif + zz(1) = "ABC" + zz(2) = "DEF" + zz(3) = "GHI" + res%z = get_loc (zz) + rank default + error stop 99 + end select +contains + integer (c_intptr_t) function get_loc (arg) + character(len=*), target :: arg(:) + ! %loc does copy in/out if not simply contiguous + ! extra func needed because of 'target' attribute + get_loc = transfer (c_loc(arg), res%x) + end +end + +type(loc_t) function char_assumed_rank_in_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*) :: xx(..) + character(len=3) :: yy(..) + character(len=k) :: zz(..) + intent(in) :: xx, yy, zz + if (3 /= size(yy)) error stop 50 + if (3 /= len(yy)) error stop 51 + if (1 /= rank(yy)) error stop 59 + if (1 /= lbound(xx, dim=1)) stop 49 + if (1 /= lbound(yy, dim=1)) stop 49 + if (1 /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (3 /= ubound(yy, dim=1)) stop 49 + if (3 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (is_contiguous (xx)) error stop 59 + if (is_contiguous (yy)) error stop 59 + if (is_contiguous (zz)) error stop 59 + else if (num == 2) then + if (.not. is_contiguous (xx)) error stop 59 + if (.not. is_contiguous (yy)) error stop 59 + if (.not. is_contiguous (zz)) error stop 59 + else + error stop 48 + end if + select rank (xx) + rank (1) + print *, xx(1:3) + if (num == 1) then + if (xx(1) /= "abc") error stop 52 + if (xx(2) /= "ghi") error stop 53 + if (xx(3) /= "nop") error stop 54 + else if (num == 2) then + if (xx(1) /= "def") error stop 55 + if (xx(2) /= "ghi") error stop 56 + if (xx(3) /= "jlm") error stop 57 + else + error stop 58 + endif + res%x = get_loc(xx) + rank default + error stop 99 + end select + select rank (yy) + rank (1) + print *, yy(1:3) + if (num == 1) then + if (yy(1) /= "abc") error stop 52 + if (yy(2) /= "ghi") error stop 53 + if (yy(3) /= "nop") error stop 54 + else if (num == 2) then + if (yy(1) /= "def") error stop 55 + if (yy(2) /= "ghi") error stop 56 + if (yy(3) /= "jlm") error stop 57 + else + error stop 58 + endif + res%y = get_loc(yy) + rank default + error stop 99 + end select + select rank (zz) + rank (1) + print *, zz(1:3) + if (num == 1) then + if (zz(1) /= "abc") error stop 52 + if (zz(2) /= "ghi") error stop 53 + if (zz(3) /= "nop") error stop 54 + else if (num == 2) then + if (zz(1) /= "def") error stop 55 + if (zz(2) /= "ghi") error stop 56 + if (zz(3) /= "jlm") error stop 57 + else + error stop 58 + endif + res%z = get_loc(zz) + rank default + error stop 99 + end select +contains + integer (c_intptr_t) function get_loc (arg) + character(len=*), target :: arg(:) + ! %loc does copy in/out if not simply contiguous + ! extra func needed because of 'target' attribute + get_loc = transfer (c_loc(arg), res%x) + end +end + + + +type(loc_t) function char_assumed_rank_cont_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*) :: xx(..) + character(len=3) :: yy(..) + character(len=k) :: zz(..) + contiguous :: xx, yy, zz + if (3 /= len(xx)) error stop 60 + if (3 /= len(yy)) error stop 60 + if (3 /= len(zz)) error stop 60 + if (3 /= size(xx)) error stop 61 + if (3 /= size(yy)) error stop 61 + if (3 /= size(zz)) error stop 61 + if (1 /= rank(xx)) error stop 69 + if (1 /= rank(yy)) error stop 69 + if (1 /= rank(zz)) error stop 69 + if (1 /= lbound(xx, dim=1)) stop 49 + if (1 /= lbound(yy, dim=1)) stop 49 + if (1 /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (3 /= ubound(yy, dim=1)) stop 49 + if (3 /= ubound(zz, dim=1)) stop 49 + select rank (xx) + rank (1) + print *, xx(1:3) + if (num == 1) then + if (xx(1) /= "abc") error stop 62 + if (xx(2) /= "ghi") error stop 63 + if (xx(3) /= "nop") error stop 64 + else if (num == 2) then + if (xx(1) /= "def") error stop 65 + if (xx(2) /= "ghi") error stop 66 + if (xx(3) /= "jlm") error stop 67 + else + error stop 68 + endif + xx(1) = "ABC" + xx(2) = "DEF" + xx(3) = "GHI" + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select + select rank (yy) + rank (1) + print *, yy(1:3) + if (num == 1) then + if (yy(1) /= "abc") error stop 62 + if (yy(2) /= "ghi") error stop 63 + if (yy(3) /= "nop") error stop 64 + else if (num == 2) then + if (yy(1) /= "def") error stop 65 + if (yy(2) /= "ghi") error stop 66 + if (yy(3) /= "jlm") error stop 67 + else + error stop 68 + endif + yy(1) = "ABC" + yy(2) = "DEF" + yy(3) = "GHI" + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select + select rank (zz) + rank (1) + print *, zz(1:3) + if (num == 1) then + if (zz(1) /= "abc") error stop 62 + if (zz(2) /= "ghi") error stop 63 + if (zz(3) /= "nop") error stop 64 + else if (num == 2) then + if (zz(1) /= "def") error stop 65 + if (zz(2) /= "ghi") error stop 66 + if (zz(3) /= "jlm") error stop 67 + else + error stop 68 + endif + zz(1) = "ABC" + zz(2) = "DEF" + zz(3) = "GHI" + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select +end + +type(loc_t) function char_assumed_rank_cont_in_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*) :: xx(..) + character(len=3) :: yy(..) + character(len=k) :: zz(..) + intent(in) :: xx, yy, zz + contiguous :: xx, yy, zz + if (3 /= size(xx)) error stop 30 + if (3 /= size(yy)) error stop 30 + if (3 /= size(zz)) error stop 30 + if (3 /= len(xx)) error stop 31 + if (3 /= len(yy)) error stop 31 + if (3 /= len(zz)) error stop 31 + if (1 /= rank(xx)) error stop 69 + if (1 /= rank(yy)) error stop 69 + if (1 /= rank(zz)) error stop 69 + if (1 /= lbound(xx, dim=1)) stop 49 + if (1 /= lbound(yy, dim=1)) stop 49 + if (1 /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (3 /= ubound(yy, dim=1)) stop 49 + if (3 /= ubound(zz, dim=1)) stop 49 + select rank (xx) + rank (1) + print *, xx(1:3) + if (num == 1) then + if (xx(1) /= "abc") error stop 62 + if (xx(2) /= "ghi") error stop 63 + if (xx(3) /= "nop") error stop 64 + else if (num == 2) then + if (xx(1) /= "def") error stop 65 + if (xx(2) /= "ghi") error stop 66 + if (xx(3) /= "jlm") error stop 67 + else + error stop 68 + endif + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select + select rank (yy) + rank (1) + print *, yy(1:3) + if (num == 1) then + if (yy(1) /= "abc") error stop 62 + if (yy(2) /= "ghi") error stop 63 + if (yy(3) /= "nop") error stop 64 + else if (num == 2) then + if (yy(1) /= "def") error stop 65 + if (yy(2) /= "ghi") error stop 66 + if (yy(3) /= "jlm") error stop 67 + else + error stop 68 + endif + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select + select rank (zz) + rank (1) + print *, zz(1:3) + if (num == 1) then + if (zz(1) /= "abc") error stop 62 + if (zz(2) /= "ghi") error stop 63 + if (zz(3) /= "nop") error stop 64 + else if (num == 2) then + if (zz(1) /= "def") error stop 65 + if (zz(2) /= "ghi") error stop 66 + if (zz(3) /= "jlm") error stop 67 + else + error stop 68 + endif + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select +end + +type(loc_t) function char_assumed_shape_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*) :: xx(:) + character(len=3) :: yy(5:) + character(len=k) :: zz(-k:) + print *, xx(1:3) + if (3 /= len(xx)) error stop 70 + if (3 /= len(yy)) error stop 70 + if (3 /= len(zz)) error stop 70 + if (3 /= size(xx)) error stop 71 + if (3 /= size(yy)) error stop 71 + if (3 /= size(zz)) error stop 71 + if (1 /= lbound(xx, dim=1)) stop 49 + if (5 /= lbound(yy, dim=1)) stop 49 + if (-k /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (7 /= ubound(yy, dim=1)) stop 49 + if (-k+2 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (is_contiguous (xx)) error stop 79 + if (is_contiguous (yy)) error stop 79 + if (is_contiguous (zz)) error stop 79 + if (xx(1) /= "abc") error stop 72 + if (xx(2) /= "ghi") error stop 73 + if (xx(3) /= "nop") error stop 74 + if (yy(5) /= "abc") error stop 72 + if (yy(6) /= "ghi") error stop 73 + if (yy(7) /= "nop") error stop 74 + if (zz(-k) /= "abc") error stop 72 + if (zz(-k+1) /= "ghi") error stop 73 + if (zz(-k+2) /= "nop") error stop 74 + else if (num == 2) then + if (.not.is_contiguous (xx)) error stop 79 + if (.not.is_contiguous (yy)) error stop 79 + if (.not.is_contiguous (zz)) error stop 79 + if (xx(1) /= "def") error stop 72 + if (xx(2) /= "ghi") error stop 73 + if (xx(3) /= "jlm") error stop 74 + if (yy(5) /= "def") error stop 72 + if (yy(6) /= "ghi") error stop 73 + if (yy(7) /= "jlm") error stop 74 + if (zz(-k) /= "def") error stop 72 + if (zz(-k+1) /= "ghi") error stop 73 + if (zz(-k+2) /= "jlm") error stop 74 + else + error stop 78 + endif + xx(1) = "ABC" + xx(2) = "DEF" + xx(3) = "GHI" + yy(5) = "ABC" + yy(6) = "DEF" + yy(7) = "GHI" + zz(-k) = "ABC" + zz(-k+1) = "DEF" + zz(-k+2) = "GHI" + res%x = get_loc(xx) + res%y = get_loc(yy) + res%z = get_loc(zz) +contains + integer (c_intptr_t) function get_loc (arg) + character(len=*), target :: arg(:) + ! %loc does copy in/out if not simply contiguous + ! extra func needed because of 'target' attribute + get_loc = transfer (c_loc(arg), res%x) + end +end + +type(loc_t) function char_assumed_shape_in_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*) :: xx(:) + character(len=3) :: yy(5:) + character(len=k) :: zz(-k:) + intent(in) :: xx, yy, zz + print *, xx(1:3) + if (3 /= size(xx)) error stop 80 + if (3 /= size(yy)) error stop 80 + if (3 /= size(zz)) error stop 80 + if (3 /= len(xx)) error stop 81 + if (3 /= len(yy)) error stop 81 + if (3 /= len(zz)) error stop 81 + if (1 /= lbound(xx, dim=1)) stop 49 + if (5 /= lbound(yy, dim=1)) stop 49 + if (-k /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (7 /= ubound(yy, dim=1)) stop 49 + if (-k+2 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (is_contiguous (xx)) error stop 89 + if (is_contiguous (yy)) error stop 89 + if (is_contiguous (zz)) error stop 89 + if (xx(1) /= "abc") error stop 82 + if (xx(2) /= "ghi") error stop 83 + if (xx(3) /= "nop") error stop 84 + if (yy(5) /= "abc") error stop 82 + if (yy(6) /= "ghi") error stop 83 + if (yy(7) /= "nop") error stop 84 + if (zz(-k) /= "abc") error stop 82 + if (zz(-k+1) /= "ghi") error stop 83 + if (zz(-k+2) /= "nop") error stop 84 + else if (num == 2) then + if (.not.is_contiguous (xx)) error stop 89 + if (.not.is_contiguous (yy)) error stop 89 + if (.not.is_contiguous (zz)) error stop 89 + if (xx(1) /= "def") error stop 85 + if (xx(2) /= "ghi") error stop 86 + if (xx(3) /= "jlm") error stop 87 + if (yy(5) /= "def") error stop 85 + if (yy(6) /= "ghi") error stop 86 + if (yy(7) /= "jlm") error stop 87 + if (zz(-k) /= "def") error stop 85 + if (zz(-k+1) /= "ghi") error stop 86 + if (zz(-k+2) /= "jlm") error stop 87 + else + error stop 88 + endif + res%x = get_loc(xx) + res%y = get_loc(yy) + res%z = get_loc(zz) +contains + integer (c_intptr_t) function get_loc (arg) + character(len=*), target :: arg(:) + ! %loc does copy in/out if not simply contiguous + ! extra func needed because of 'target' attribute + get_loc = transfer (c_loc(arg), res%x) + end +end + + + +type(loc_t) function char_assumed_shape_cont_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*) :: xx(:) + character(len=3) :: yy(5:) + character(len=k) :: zz(-k:) + contiguous :: xx, yy, zz + print *, xx(1:3) + if (3 /= len(xx)) error stop 90 + if (3 /= len(yy)) error stop 90 + if (3 /= len(zz)) error stop 90 + if (3 /= size(xx)) error stop 91 + if (3 /= size(yy)) error stop 91 + if (3 /= size(zz)) error stop 91 + if (1 /= lbound(xx, dim=1)) stop 49 + if (5 /= lbound(yy, dim=1)) stop 49 + if (-k /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (7 /= ubound(yy, dim=1)) stop 49 + if (-k+2 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (xx(1) /= "abc") error stop 92 + if (xx(2) /= "ghi") error stop 93 + if (xx(3) /= "nop") error stop 94 + if (yy(5) /= "abc") error stop 92 + if (yy(6) /= "ghi") error stop 93 + if (yy(7) /= "nop") error stop 94 + if (zz(-k) /= "abc") error stop 92 + if (zz(-k+1) /= "ghi") error stop 93 + if (zz(-k+2) /= "nop") error stop 94 + else if (num == 2) then + if (xx(1) /= "def") error stop 92 + if (xx(2) /= "ghi") error stop 93 + if (xx(3) /= "jlm") error stop 94 + if (yy(5) /= "def") error stop 92 + if (yy(6) /= "ghi") error stop 93 + if (yy(7) /= "jlm") error stop 94 + if (zz(-k) /= "def") error stop 92 + if (zz(-k+1) /= "ghi") error stop 93 + if (zz(-k+2) /= "jlm") error stop 94 + else + error stop 98 + endif + xx(1) = "ABC" + xx(2) = "DEF" + xx(3) = "GHI" + yy(5) = "ABC" + yy(6) = "DEF" + yy(7) = "GHI" + zz(-k) = "ABC" + zz(-k+1) = "DEF" + zz(-k+2) = "GHI" + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + +type(loc_t) function char_assumed_shape_cont_in_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*) :: xx(:) + character(len=3) :: yy(5:) + character(len=k) :: zz(-k:) + intent(in) :: xx, yy, zz + contiguous :: xx, yy, zz + print *, xx(1:3) + if (3 /= size(xx)) error stop 100 + if (3 /= size(yy)) error stop 100 + if (3 /= size(zz)) error stop 100 + if (3 /= len(xx)) error stop 101 + if (3 /= len(yy)) error stop 101 + if (3 /= len(zz)) error stop 101 + if (1 /= lbound(xx, dim=1)) stop 49 + if (5 /= lbound(yy, dim=1)) stop 49 + if (-k /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (7 /= ubound(yy, dim=1)) stop 49 + if (-k+2 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (xx(1) /= "abc") error stop 102 + if (xx(2) /= "ghi") error stop 103 + if (xx(3) /= "nop") error stop 104 + if (yy(5) /= "abc") error stop 102 + if (yy(6) /= "ghi") error stop 103 + if (yy(7) /= "nop") error stop 104 + if (zz(-k) /= "abc") error stop 102 + if (zz(-k+1) /= "ghi") error stop 103 + if (zz(-k+2) /= "nop") error stop 104 + else if (num == 2) then + if (xx(1) /= "def") error stop 105 + if (xx(2) /= "ghi") error stop 106 + if (xx(3) /= "jlm") error stop 107 + if (yy(5) /= "def") error stop 105 + if (yy(6) /= "ghi") error stop 106 + if (yy(7) /= "jlm") error stop 107 + if (zz(-k) /= "def") error stop 105 + if (zz(-k+1) /= "ghi") error stop 106 + if (zz(-k+2) /= "jlm") error stop 107 + else + error stop 108 + endif + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + +end module + + +use m +implicit none (type, external) +character(len=3) :: a(6), a2(6), a3(6), a_init(6) +type(loc_t) :: loc3 + +a_init = ['abc', 'def', 'ghi', 'jlm', 'nop', 'qrs'] + +! -- Fortran: assumed size +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_f (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_in_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_in_f (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- Fortran: explicit shape +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_f (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_in_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_in_f (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- Fortran: assumed rank +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_f (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- Fortran: assumed rank contiguous +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- Fortran: assumed shape +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_f (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- Fortran: assumed shape contiguous +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + + +! --- character - call C directly -- + +! -- C: assumed size +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_c (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_in_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_in_c (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- C: explicit shape +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_c (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_in_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_in_c (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- C: assumed rank +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_c (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- C: assumed rank contiguous +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- C: assumed shape +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_c (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- C: assumed shape contiguous +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 +end + + +! { dg-output "At line 928 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_f'(\r*\n+)" }" +! { dg-output "At line 928 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_f'(\r*\n+)" }" +! { dg-output "At line 928 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_f'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 946 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_in_f'(\r*\n+)" }" +! { dg-output "At line 946 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_in_f'(\r*\n+)" }" +! { dg-output "At line 946 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_in_f'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 965 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_f'(\r*\n+)" }" +! { dg-output "At line 965 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_f'(\r*\n+)" }" +! { dg-output "At line 965 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_f'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 983 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_in_f'(\r*\n+)" }" +! { dg-output "At line 983 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_in_f'(\r*\n+)" }" +! { dg-output "At line 983 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_in_f'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1039 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_f'(\r*\n+)" }" +! { dg-output "At line 1039 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_f'(\r*\n+)" }" +! { dg-output "At line 1039 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_f'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1057 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_in_f'(\r*\n+)" }" +! { dg-output "At line 1057 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_in_f'(\r*\n+)" }" +! { dg-output "At line 1057 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_in_f'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1113 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_f'(\r*\n+)" }" +! { dg-output "At line 1113 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_f'(\r*\n+)" }" +! { dg-output "At line 1113 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_f'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1131 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_in_f'(\r*\n+)" }" +! { dg-output "At line 1131 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_in_f'(\r*\n+)" }" +! { dg-output "At line 1131 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_in_f'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1153 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_c'(\r*\n+)" }" +! { dg-output "At line 1153 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_c'(\r*\n+)" }" +! { dg-output "At line 1153 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_c'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1171 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_in_c'(\r*\n+)" }" +! { dg-output "At line 1171 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_in_c'(\r*\n+)" }" +! { dg-output "At line 1171 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_in_c'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1190 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_c'(\r*\n+)" }" +! { dg-output "At line 1190 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_c'(\r*\n+)" }" +! { dg-output "At line 1190 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_c'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1208 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_in_c'(\r*\n+)" }" +! { dg-output "At line 1208 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_in_c'(\r*\n+)" }" +! { dg-output "At line 1208 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_in_c'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1264 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_c'(\r*\n+)" }" +! { dg-output "At line 1264 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_c'(\r*\n+)" }" +! { dg-output "At line 1264 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_c'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1282 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_in_c'(\r*\n+)" }" +! { dg-output "At line 1282 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_in_c'(\r*\n+)" }" +! { dg-output "At line 1282 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_in_c'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1338 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_c'(\r*\n+)" }" +! { dg-output "At line 1338 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_c'(\r*\n+)" }" +! { dg-output "At line 1338 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_c'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1356 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_in_c'(\r*\n+)" }" +! { dg-output "At line 1356 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_in_c'(\r*\n+)" }" +! { dg-output "At line 1356 of file .*bind-c-contiguous-1.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_in_c'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" diff --git a/Fortran/gfortran/regression/bind-c-contiguous-2.f90 b/Fortran/gfortran/regression/bind-c-contiguous-2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind-c-contiguous-2.f90 @@ -0,0 +1,82 @@ +! { dg-additional-options "-fdump-tree-original" } + +integer function f(xx) bind(c) result(ii) + implicit none + integer, contiguous :: xx(..) + ii = rank(xx) +end + +integer function h(yy) bind(c) result(jj) + implicit none + character(len=*), contiguous :: yy(:) + jj = rank(yy) +end + +integer function g(zz) bind(c) result(kk) + implicit none + character(len=*) :: zz(*) + kk = rank(zz) +end + + + +integer function f2(aa) bind(c) result(ii) + implicit none + integer, contiguous :: aa(..) + intent(in) :: aa + ii = rank(aa) +end + +integer function h2(bb) bind(c) result(jj) + implicit none + character(len=*), contiguous :: bb(:) + intent(in) :: bb + jj = rank(bb) +end + +integer function g2(cc) bind(c) result(kk) + implicit none + character(len=*) :: cc(*) + intent(in) :: cc + kk = rank(cc) +end + +! +! Copy-in/out variable: +! +! { dg-final { scan-tree-dump-times "xx->data =\[^;\]+ __builtin_malloc \\(_xx->elem_len \\* size.\[0-9\]+\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "yy->data =\[^;\]+ __builtin_malloc \\(_yy->elem_len \\* size.\[0-9\]+\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "zz =\[^;\]+ __builtin_malloc \\(_zz->elem_len \\* size.\[0-9\]+\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "aa->data =\[^;\]+ __builtin_malloc \\(_aa->elem_len \\* size.\[0-9\]+\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "bb->data =\[^;\]+ __builtin_malloc \\(_bb->elem_len \\* size.\[0-9\]+\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "cc =\[^;\]+ __builtin_malloc \\(_cc->elem_len \\* size.\[0-9\]+\\);" 1 "original" } } + +! { dg-final { scan-tree-dump-times "__builtin_free \\(\[^;\]+ xx->data\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free \\(\[^;\]+ yy->data\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free \\(zz\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free \\(\[^;\]+ aa->data\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free \\(\[^;\]+ bb->data\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free \\(cc\\);" 1 "original" } } + +! Copy in + out + +! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void \\*\\) xx->data \\+ xx->dtype.elem_len \\* arrayidx.\[0-9\]+, _xx->base_addr \\+ shift.\[0-9\]+, xx->dtype.elem_len\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "xx->data = \\(void \\* restrict\\) _xx->base_addr;" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void \\*\\) xx->data \\+ xx->dtype.elem_len \\* arrayidx.\[0-9\]+, _xx->base_addr \\+ shift.\[0-9\]+, xx->dtype.elem_len\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void \\*\\) yy->data \\+ yy->dtype.elem_len \\* arrayidx.\[0-9\]+, _yy->base_addr \\+ shift.\[0-9\]+, yy->dtype.elem_len\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "yy->data = \\(void \\* restrict\\) _yy->base_addr;" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(_yy->base_addr \\+ shift.\[0-9\]+, \\(void \\*\\) yy->data \\+ yy->dtype.elem_len \\* arrayidx.\[0-9\]+, yy->dtype.elem_len\\);" 1 "original" } } + +! { dg-final { scan-tree-dump-times "zz = \\(character\\(kind=1\\)\\\[0:\\\]\\\[1:zz.\[0-9\]+\\\] \\* restrict\\) _zz->base_addr;" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void \\*\\) zz \\+ _zz->elem_len \\* arrayidx.\[0-9\]+, _zz->base_addr \\+ shift.\[0-9\]+, _zz->elem_len\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(_zz->base_addr \\+ shift.\[0-9\]+, \\(void \\*\\) zz \\+ _zz->elem_len \\* arrayidx.\[0-9\]+, _zz->elem_len\\);" 1 "original" } } + +! Copy in only + +! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void \\*\\) aa->data \\+ aa->dtype.elem_len \\* arrayidx.\[0-9\]+, _aa->base_addr \\+ shift.\[0-9\]+, aa->dtype.elem_len\\);" 1 "original" } } + +! { dg-final { scan-tree-dump-times "aa->data = \\(void \\* restrict\\) _aa->base_addr;" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void \\*\\) bb->data \\+ bb->dtype.elem_len \\* arrayidx.\[0-9\]+, _bb->base_addr \\+ shift.\[0-9\]+, bb->dtype.elem_len\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "bb->data = \\(void \\* restrict\\) _bb->base_addr;" 1 "original" } } +! { dg-final { scan-tree-dump-times "cc = \\(character\\(kind=1\\)\\\[0:\\\]\\\[1:cc.\[0-9\]+\\\] \\* restrict\\) _cc->base_addr;" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void \\*\\) cc \\+ _cc->elem_len \\* arrayidx.\[0-9\]+, _cc->base_addr \\+ shift.\[0-9\]+, _cc->elem_len\\);" 1 "original" } } diff --git a/Fortran/gfortran/regression/bind-c-contiguous-3.c b/Fortran/gfortran/regression/bind-c-contiguous-3.c --- /dev/null +++ b/Fortran/gfortran/regression/bind-c-contiguous-3.c @@ -0,0 +1,180 @@ +#include + +intptr_t assumed_rank_alloc_f (CFI_cdesc_t *); +intptr_t assumed_rank_pointer_f (CFI_cdesc_t *); +intptr_t assumed_rank_f (CFI_cdesc_t *); +intptr_t assumed_rank_cont_f (CFI_cdesc_t *); +intptr_t assumed_shape_f (CFI_cdesc_t *); +intptr_t assumed_shape_cont_f (CFI_cdesc_t *); +intptr_t deferred_shape_alloc_f (CFI_cdesc_t *); +intptr_t deferred_shape_pointer_f (CFI_cdesc_t *); + + +static void +basic_check(CFI_cdesc_t *x) +{ + if (!x->base_addr) + __builtin_abort (); + if (x->elem_len != sizeof(int32_t)) + __builtin_abort (); + if (x->version != CFI_VERSION) + __builtin_abort (); + if (x->rank != 4) + __builtin_abort (); + if (x->type != CFI_type_int32_t) + __builtin_abort (); + if (x->attribute == CFI_attribute_other) + { + if (x->dim[0].lower_bound != 0) + __builtin_abort (); + if (x->dim[1].lower_bound != 0) + __builtin_abort (); + if (x->dim[2].lower_bound != 0) + __builtin_abort (); + if (x->dim[3].lower_bound != 0) + __builtin_abort (); + } +} + +intptr_t +assumed_rank_alloc_c (CFI_cdesc_t *x) +{ + basic_check (x); + if (!CFI_is_contiguous (x)) + __builtin_abort (); + if (x->attribute != CFI_attribute_allocatable) + __builtin_abort (); + intptr_t addr = (intptr_t) x->base_addr; + intptr_t addr2 = assumed_rank_alloc_f (x); + if (addr != addr2 || addr != (intptr_t) x->base_addr) + __builtin_abort (); + return addr; +} + +intptr_t +assumed_rank_pointer_c (CFI_cdesc_t *x) +{ + basic_check (x); + if (x->attribute != CFI_attribute_pointer) + __builtin_abort (); + intptr_t addr = (intptr_t) x->base_addr; + intptr_t addr2 = assumed_rank_pointer_f (x); + if (addr != addr2 || addr != (intptr_t) x->base_addr) + __builtin_abort (); + return addr; +} + + +intptr_t +assumed_rank_c (CFI_cdesc_t *x) +{ + basic_check (x); + if (x->attribute != CFI_attribute_other) + __builtin_abort (); + intptr_t addr = (intptr_t) x->base_addr; + intptr_t addr2 = assumed_rank_f (x); + if (addr != addr2 || addr != (intptr_t) x->base_addr) + __builtin_abort (); + return addr; +} + +intptr_t +assumed_rank_cont_c (CFI_cdesc_t *x) +{ + basic_check (x); + if (!CFI_is_contiguous (x)) + __builtin_abort (); + if (x->attribute != CFI_attribute_other) + __builtin_abort (); + intptr_t addr = (intptr_t) x->base_addr; + intptr_t addr2 = assumed_rank_cont_f (x); + if (addr != addr2 || addr != (intptr_t) x->base_addr) + __builtin_abort (); + return addr; +} + +intptr_t +assumed_shape_c (CFI_cdesc_t *x, int num) +{ + basic_check (x); + if (x->attribute != CFI_attribute_other) + __builtin_abort (); + intptr_t addr = (intptr_t) x->base_addr; + intptr_t addr2; + if (num == 1 || num == 2 || num == 3) + { + if (!CFI_is_contiguous (x)) + __builtin_abort (); + } + else + { + if (CFI_is_contiguous (x)) + __builtin_abort (); + } + + if (num == 1 || num == 4) + addr2 = assumed_shape_f (x); + else if (num == 2 || num == 5) + addr2 = assumed_shape_cont_f (x); + else if (num == 3 || num == 6) + addr2 = assumed_rank_cont_f (x); + else + __builtin_abort (); + + if (num == 1 || num == 2 || num == 3) + { + if (addr != addr2) + __builtin_abort (); + } + else + { + if (CFI_is_contiguous (x)) + __builtin_abort (); + } + if (addr != (intptr_t) x->base_addr) + __builtin_abort (); + return addr2; +} + +intptr_t +assumed_shape_cont_c (CFI_cdesc_t *x) +{ + basic_check (x); + if (!CFI_is_contiguous (x)) + __builtin_abort (); + if (x->attribute != CFI_attribute_other) + __builtin_abort (); + intptr_t addr = (intptr_t) x->base_addr; + intptr_t addr2 = assumed_shape_cont_f (x); + if (addr != addr2 || addr != (intptr_t) x->base_addr) + __builtin_abort (); + return addr; +} + +intptr_t +deferred_shape_alloc_c (CFI_cdesc_t *x) +{ + basic_check (x); + if (!CFI_is_contiguous (x)) + __builtin_abort (); + if (x->attribute != CFI_attribute_allocatable) + __builtin_abort (); + intptr_t addr = (intptr_t) x->base_addr; + intptr_t addr2 = deferred_shape_alloc_f (x); + if (addr != addr2 || addr != (intptr_t) x->base_addr) + __builtin_abort (); + return addr; +} + +intptr_t +deferred_shape_pointer_c (CFI_cdesc_t *x) +{ + basic_check (x); + if (x->attribute != CFI_attribute_pointer) + __builtin_abort (); + intptr_t addr = (intptr_t) x->base_addr; + intptr_t addr2 = deferred_shape_pointer_f (x); + if (addr != addr2 || addr != (intptr_t) x->base_addr) + __builtin_abort (); + return addr; +} diff --git a/Fortran/gfortran/regression/bind-c-contiguous-3.f90 b/Fortran/gfortran/regression/bind-c-contiguous-3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind-c-contiguous-3.f90 @@ -0,0 +1,656 @@ +! { dg-do run } +! { dg-additional-sources bind-c-contiguous-3.c } + +! Test that multi-dim contiguous is properly handled. + +module m + use iso_c_binding, only: c_intptr_t, c_int + implicit none (type, external) + +interface + integer(c_intptr_t) function assumed_rank_alloc_c (xx) bind(c) + import :: c_intptr_t + integer, allocatable :: xx(..) + end function + integer(c_intptr_t) function assumed_rank_pointer_c (xx) bind(c) + import :: c_intptr_t + integer, pointer :: xx(..) + end function + integer(c_intptr_t) function assumed_rank_c (xx) bind(c) + import :: c_intptr_t + integer :: xx(..) + end function + integer(c_intptr_t) function assumed_rank_cont_c (xx) bind(c) + import :: c_intptr_t + integer, contiguous :: xx(..) + end function + integer(c_intptr_t) function assumed_shape_c (xx, num) bind(c) + import :: c_intptr_t, c_int + integer :: xx(:,:,:,:) + integer(c_int), value :: num + end function + integer(c_intptr_t) function assumed_shape_cont_c (xx) bind(c) + import :: c_intptr_t + integer, contiguous :: xx(:,:,:,:) + end function + integer(c_intptr_t) function deferred_shape_alloc_c (xx) bind(c) + import :: c_intptr_t + integer, allocatable :: xx(:,:,:,:) + end function + integer(c_intptr_t) function deferred_shape_pointer_c (xx) bind(c) + import :: c_intptr_t + integer, pointer :: xx(:,:,:,:) + end function + +end interface + +contains + +integer function get_n (idx, lbound, extent) result(res) + integer, contiguous :: idx(:), lbound(:), extent(:) + integer :: i + if (size(idx) /= size(lbound) .or. size(idx) /= size(extent)) & + error stop 20 + res = idx(1) - lbound(1) + 1 + do i = 2, size(idx) + res = res + product(extent(:i-1)) * (idx(i)-lbound(i)) + end do +end + +integer(c_intptr_t) function assumed_rank_alloc_f (xx) bind(c) result(res) + integer, allocatable :: xx(..) + integer :: i, j, k, l, lb(4) + select rank (xx) + rank (4) + do l = lbound(xx, dim=4), ubound(xx, dim=4) + do k = lbound(xx, dim=3), ubound(xx, dim=3) + do j = lbound(xx, dim=2), ubound(xx, dim=2) + do i = lbound(xx, dim=1), ubound(xx, dim=1) + xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx)) + end do + end do + end do + end do + lb = lbound(xx) + res = %loc(xx(lb(1),lb(2),lb(3),lb(4))) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select +end + +integer(c_intptr_t) function assumed_rank_pointer_f (xx) bind(c) result(res) + integer, pointer :: xx(..) + integer :: i, j, k, l, lb(4) + select rank (xx) + rank (4) + do l = lbound(xx, dim=4), ubound(xx, dim=4) + do k = lbound(xx, dim=3), ubound(xx, dim=3) + do j = lbound(xx, dim=2), ubound(xx, dim=2) + do i = lbound(xx, dim=1), ubound(xx, dim=1) + xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx)) + end do + end do + end do + end do + lb = lbound(xx) + res = %loc(xx(lb(1),lb(2),lb(3),lb(4))) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select +end + + +integer(c_intptr_t) function assumed_rank_f (xx) bind(c) result(res) + integer :: xx(..) + integer :: i, j, k, l + select rank (xx) + rank (4) + do l = 1, size(xx, dim=4) + do k = 1, size(xx, dim=3) + do j = 1, size(xx, dim=2) + do i = 1, size(xx, dim=1) + xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx)) + end do + end do + end do + end do + res = %loc(xx(1,1,1,1)) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select +end + +integer(c_intptr_t) function assumed_rank_cont_f (xx) bind(c) result(res) + integer, contiguous :: xx(..) + integer :: i, j, k, l + select rank (xx) + rank (4) + do l = 1, size(xx, dim=4) + do k = 1, size(xx, dim=3) + do j = 1, size(xx, dim=2) + do i = 1, size(xx, dim=1) + xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx)) + end do + end do + end do + end do + res = %loc(xx(1,1,1,1)) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select +end + +integer(c_intptr_t) function assumed_shape_f (xx) bind(c) result(res) + integer :: xx(:,:,:,:) + integer :: i, j, k, l + do l = 1, ubound(xx, dim=4) + do k = 1, ubound(xx, dim=3) + do j = 1, ubound(xx, dim=2) + do i = 1, ubound(xx, dim=1) + xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx)) + end do + end do + end do + end do + res = %loc(xx(1,1,1,1)) ! { dg-warning "Legacy Extension" } +end + +integer(c_intptr_t) function assumed_shape2_f (xx, n) bind(c) result(res) + integer, value :: n + integer :: xx(-n:, -n:, -n:, -n:) + integer :: i, j, k, l + do l = -n, ubound(xx, dim=4) + do k = -n, ubound(xx, dim=3) + do j = -n, ubound(xx, dim=2) + do i = -n, ubound(xx, dim=1) + xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx)) + end do + end do + end do + end do + res = %loc(xx(-n,-n,-n,-n)) ! { dg-warning "Legacy Extension" } +end + +integer(c_intptr_t) function assumed_shape_cont_f (xx) bind(c) result(res) + integer, contiguous :: xx(:,:,:,:) + integer :: i, j, k, l + do l = 1, ubound(xx, dim=4) + do k = 1, ubound(xx, dim=3) + do j = 1, ubound(xx, dim=2) + do i = 1, ubound(xx, dim=1) + xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx)) + end do + end do + end do + end do + res = %loc(xx(1,1,1,1)) ! { dg-warning "Legacy Extension" } +end + +integer(c_intptr_t) function assumed_shape2_cont_f (xx, n) bind(c) result(res) + integer, value :: n + integer, contiguous :: xx(-n:, -n:, -n:, -n:) + integer :: i, j, k, l + do l = -n, ubound(xx, dim=4) + do k = -n, ubound(xx, dim=3) + do j = -n, ubound(xx, dim=2) + do i = -n, ubound(xx, dim=1) + xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx)) + end do + end do + end do + end do + res = %loc(xx(-n,-n,-n,-n)) ! { dg-warning "Legacy Extension" } +end + +integer(c_intptr_t) function deferred_shape_alloc_f (xx) bind(c) result(res) + integer, allocatable :: xx(:,:,:,:) + integer :: i, j, k, l, lb(4) + do l = lbound(xx, dim=4), ubound(xx, dim=4) + do k = lbound(xx, dim=3), ubound(xx, dim=3) + do j = lbound(xx, dim=2), ubound(xx, dim=2) + do i = lbound(xx, dim=1), ubound(xx, dim=1) + xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx)) + end do + end do + end do + end do + lb = lbound(xx) + res = %loc(xx(lb(1),lb(2),lb(3),lb(4))) ! { dg-warning "Legacy Extension" } +end + +integer(c_intptr_t) function deferred_shape_pointer_f (xx) bind(c) result(res) + integer, pointer :: xx(:,:,:,:) + integer :: i, j, k, l, lb(4) + do l = lbound(xx, dim=4), ubound(xx, dim=4) + do k = lbound(xx, dim=3), ubound(xx, dim=3) + do j = lbound(xx, dim=2), ubound(xx, dim=2) + do i = lbound(xx, dim=1), ubound(xx, dim=1) + xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx)) + end do + end do + end do + end do + lb = lbound(xx) + res = %loc(xx(lb(1),lb(2),lb(3),lb(4))) ! { dg-warning "Legacy Extension" } +end +end module + + +use m +implicit none (type, external) +integer, dimension(10,10,10,10) :: var_init, var +target :: var +integer, allocatable, dimension(:,:,:,:) :: a1, a2 +integer, pointer, dimension(:,:,:,:) :: p1, p2 +integer(c_intptr_t) :: loc4 +integer :: i, k, j, l, cnt + +do l = 1, ubound(var_init, dim=4) + do k = 1, ubound(var_init, dim=3) + do j = 1, ubound(var_init, dim=2) + do i = 1, ubound(var_init, dim=1) + var_init(i,j,k,l) = get_n([i,j,k,l], lbound(var_init), shape(var_init)) + end do + end do + end do +end do + +! Fortran calls + +! ----- allocatable + pointer dummies ------- + +allocate(a1, mold=var_init) +allocate(p1, mold=var_init) +allocate(a2(-5:4,-10:-1,1:10,11:20)) +allocate(p2(-5:4,-10:-1,1:10,11:20)) + +a1(:,:,:,:) = var_init +loc4 = assumed_rank_alloc_f (a1) +cnt = size(a1) - check_unmod (a1) +call check (a1, loc4, .true., cnt) +call check2 (a1) + +a2(:,:,:,:) = var_init +loc4 = assumed_rank_alloc_f (a2) +cnt = size(a2) - check_unmod (a2) +call check (a2, loc4, .true., cnt) +call check2 (a2) + +a1(:,:,:,:) = var_init +loc4 = deferred_shape_alloc_f (a1) +cnt = size(a1) - check_unmod (a1) +call check (a1, loc4, .true., cnt) +call check2 (a1) + +a2(:,:,:,:) = var_init +loc4 = deferred_shape_alloc_f (a2) +cnt = size(a2) - check_unmod (a2) +call check (a2, loc4, .true., cnt) +call check2 (a2) + +deallocate(a1, a2) + +p1(:,:,:,:) = var_init +loc4 = assumed_rank_pointer_f (p1) +cnt = size(p1) - check_unmod (p1) +call check (p1, loc4, .true., cnt) +call check2 (p1) + +p2(:,:,:,:) = var_init +loc4 = assumed_rank_pointer_f (p2) +cnt = size(p2) - check_unmod (p2) +call check (p2, loc4, .true., cnt) +call check2 (p2) + +p1(:,:,:,:) = var_init +loc4 = deferred_shape_pointer_f (p1) +cnt = size(p1) - check_unmod (p1) +call check (p1, loc4, .true., cnt) +call check2 (p1) + +p2(:,:,:,:) = var_init +loc4 = deferred_shape_pointer_f (p2) +cnt = size(p2) - check_unmod (p2) +call check (p2, loc4, .true., cnt) +call check2 (p2) + +deallocate(p1, p2) + +! --- p => var(4:7,::3,::2,:) +var = var_init +p1 => var(4:7,::3,::2,:) +loc4 = assumed_rank_pointer_f (p1) +cnt = size(p1) - check_unmod (p1) +call check (p1, loc4, .false., cnt) +call check2 (p1) + +var = var_init +p2(-5:,-10:,1:,11:) => var(4:7,::3,::2,:) +loc4 = assumed_rank_pointer_f (p2) +cnt = size(p2) - check_unmod (p2) +call check (p2, loc4, .false., cnt) +call check2 (p2) + +var = var_init +p1 => var(4:7,::3,::2,:) +loc4 = deferred_shape_pointer_f (p1) +cnt = size(p1) - check_unmod (p1) +call check (p1, loc4, .false., cnt) +call check2 (p1) + +var = var_init +p2(-5:,-10:,1:,11:) => var(4:7,::3,::2,:) +loc4 = deferred_shape_pointer_f (p2) +cnt = size(p2) - check_unmod (p2) +call check (p2, loc4, .false., cnt) +call check2 (p2) + + + +! ----- nonallocatable + nonpointer dummies ------- + +var = var_init +loc4 = assumed_rank_f (var) +cnt = size(var) - check_unmod (var) +call check (var, loc4, .false., cnt) +call check2 (var) + +var = var_init +loc4 = assumed_shape_f (var) +cnt = size(var) - check_unmod (var) +call check (var, loc4, .false., cnt) +call check2 (var) + +var = var_init +loc4 = assumed_shape2_f (var, 99) +cnt = size(var) - check_unmod (var) +call check (var, loc4, .false., cnt) +call check2 (var) + +var = var_init +loc4 = assumed_rank_cont_f (var) +cnt = size(var) - check_unmod (var) +call check (var, loc4, .true., cnt) +call check2 (var) + +var = var_init +loc4 = assumed_shape_cont_f (var) +cnt = size(var) - check_unmod (var) +call check (var, loc4, .true., cnt) +call check2 (var) + +var = var_init +loc4 = assumed_shape2_cont_f (var, 99) +cnt = size(var) - check_unmod (var) +call check (var, loc4, .true., cnt) +call check2 (var) + +! --- var(4:7,::3,::2,:) + +var = var_init +loc4 = assumed_rank_f (var(4:7,::3,::2,:)) +cnt = size(var) - check_unmod (var) +call check (var(4:7,::3,::2,:), loc4, .false., cnt) +call check2 (var(4:7,::3,::2,:)) + +var = var_init +loc4 = assumed_shape_f (var(4:7,::3,::2,:)) +cnt = size(var) - check_unmod (var) +call check (var(4:7,::3,::2,:), loc4, .false., cnt) +call check2 (var(4:7,::3,::2,:)) + +var = var_init +loc4 = assumed_shape2_f (var(4:7,::3,::2,:), 99) +cnt = size(var) - check_unmod (var) +call check (var(4:7,::3,::2,:), loc4, .false., cnt) +call check2 (var(4:7,::3,::2,:)) + +var = var_init +loc4 = assumed_rank_cont_f (var(4:7,::3,::2,:)) +cnt = size(var) - check_unmod (var) +call check (var(4:7,::3,::2,:), loc4, .true., cnt) +call check2 (var(4:7,::3,::2,:)) + +var = var_init +loc4 = assumed_shape_cont_f (var(4:7,::3,::2,:)) +cnt = size(var) - check_unmod (var) +call check (var(4:7,::3,::2,:), loc4, .true., cnt) +call check2 (var(4:7,::3,::2,:)) + +var = var_init +loc4 = assumed_shape2_cont_f (var(4:7,::3,::2,:), 99) +cnt = size(var) - check_unmod (var) +call check (var(4:7,::3,::2,:), loc4, .true., cnt) +call check2 (var(4:7,::3,::2,:)) + + +! C calls + +! ----- allocatable + pointer dummies ------- + +allocate(a1, mold=var_init) +allocate(p1, mold=var_init) +allocate(a2(-5:4,-10:-1,1:10,11:20)) +allocate(p2(-5:4,-10:-1,1:10,11:20)) + +a1(:,:,:,:) = var_init +loc4 = assumed_rank_alloc_c (a1) +cnt = size(a1) - check_unmod (a1) +call check (a1, loc4, .true., cnt) +call check2 (a1) + +a2(:,:,:,:) = var_init +loc4 = assumed_rank_alloc_c (a2) +cnt = size(a2) - check_unmod (a2) +call check (a2, loc4, .true., cnt) +call check2 (a2) + +a1(:,:,:,:) = var_init +loc4 = deferred_shape_alloc_c (a1) +cnt = size(a1) - check_unmod (a1) +call check (a1, loc4, .true., cnt) +call check2 (a1) + +a2(:,:,:,:) = var_init +loc4 = deferred_shape_alloc_c (a2) +cnt = size(a2) - check_unmod (a2) +call check (a2, loc4, .true., cnt) +call check2 (a2) + +deallocate(a1, a2) + +p1(:,:,:,:) = var_init +loc4 = assumed_rank_pointer_c (p1) +cnt = size(p1) - check_unmod (p1) +call check (p1, loc4, .true., cnt) +call check2 (p1) + +p2(:,:,:,:) = var_init +loc4 = assumed_rank_pointer_c (p2) +cnt = size(p2) - check_unmod (p2) +call check (p2, loc4, .true., cnt) +call check2 (p2) + +p1(:,:,:,:) = var_init +loc4 = deferred_shape_pointer_c (p1) +cnt = size(p1) - check_unmod (p1) +call check (p1, loc4, .true., cnt) +call check2 (p1) + +p2(:,:,:,:) = var_init +loc4 = deferred_shape_pointer_c (p2) +cnt = size(p2) - check_unmod (p2) +call check (p2, loc4, .true., cnt) +call check2 (p2) + +deallocate(p1, p2) + +! --- p => var(4:7,::3,::2,:) +var = var_init +p1 => var(4:7,::3,::2,:) +loc4 = assumed_rank_pointer_c (p1) +cnt = size(p1) - check_unmod (p1) +call check (p1, loc4, .false., cnt) +call check2 (p1) + +var = var_init +p2(-5:,-10:,1:,11:) => var(4:7,::3,::2,:) +loc4 = assumed_rank_pointer_c (p2) +cnt = size(p2) - check_unmod (p2) +call check (p2, loc4, .false., cnt) +call check2 (p2) + +var = var_init +p1 => var(4:7,::3,::2,:) +loc4 = deferred_shape_pointer_c (p1) +cnt = size(p1) - check_unmod (p1) +call check (p1, loc4, .false., cnt) +call check2 (p1) + +var = var_init +p2(-5:,-10:,1:,11:) => var(4:7,::3,::2,:) +loc4 = deferred_shape_pointer_c (p2) +cnt = size(p2) - check_unmod (p2) +call check (p2, loc4, .false., cnt) +call check2 (p2) + + +! ----- nonallocatable + nonpointer dummies ------- + +var = var_init +loc4 = assumed_rank_c (var) +cnt = size(var) - check_unmod (var) +call check (var, loc4, .false., cnt) +call check2 (var) + +var = var_init +! calls assumed_shape_f +loc4 = assumed_shape_c (var, num=1) +cnt = size(var) - check_unmod (var) +call check (var, loc4, .false., cnt) +call check2 (var) + +var = var_init +! calls assumed_shape_cont_f +loc4 = assumed_shape_c (var, num=2) +cnt = size(var) - check_unmod (var) +call check (var, loc4, .true., cnt) +call check2 (var) + +var = var_init +! calls assumed_rank_cont_f +loc4 = assumed_shape_c (var, num=3) +cnt = size(var) - check_unmod (var) +call check (var, loc4, .true., cnt) +call check2 (var) + +var = var_init +loc4 = assumed_rank_cont_c (var) +cnt = size(var) - check_unmod (var) +call check (var, loc4, .true., cnt) +call check2 (var) + +var = var_init +loc4 = assumed_shape_cont_c (var) +cnt = size(var) - check_unmod (var) +call check (var, loc4, .true., cnt) +call check2 (var) + +! --- var(4:7,::3,::2,:) + +var = var_init +loc4 = assumed_rank_c (var(4:7,::3,::2,:)) +cnt = size(var) - check_unmod (var) +call check (var(4:7,::3,::2,:), loc4, .false., cnt) +call check2 (var(4:7,::3,::2,:)) + +var = var_init +! calls assumed_shape_f +loc4 = assumed_shape_c (var(4:7,::3,::2,:), num=4) +cnt = size(var) - check_unmod (var) +call check (var(4:7,::3,::2,:), loc4, .false., cnt) +call check2 (var(4:7,::3,::2,:)) + +var = var_init +! calls assumed_shape_cont_f +loc4 = assumed_shape_c (var(4:7,::3,::2,:), num=5) +cnt = size(var) - check_unmod (var) +call check (var(4:7,::3,::2,:), loc4, .true., cnt) +call check2 (var(4:7,::3,::2,:)) + +var = var_init +! calls assumed_rank_cont_f +loc4 = assumed_shape_c (var(4:7,::3,::2,:), num=6) +cnt = size(var) - check_unmod (var) +call check (var(4:7,::3,::2,:), loc4, .true., cnt) +call check2 (var(4:7,::3,::2,:)) + +var = var_init +loc4 = assumed_rank_cont_c (var(4:7,::3,::2,:)) +cnt = size(var) - check_unmod (var) +call check (var(4:7,::3,::2,:), loc4, .true., cnt) +call check2 (var(4:7,::3,::2,:)) + +var = var_init +loc4 = assumed_shape_cont_c (var(4:7,::3,::2,:)) +cnt = size(var) - check_unmod (var) +call check (var(4:7,::3,::2,:), loc4, .true., cnt) +call check2 (var(4:7,::3,::2,:)) + + +contains + +! Ensure that the rest is still okay +! Returns the number of elements >= 0 +integer function check_unmod (x) result(cnt) + integer, contiguous, intent(in) :: x(:,:,:,:) + integer :: i, k, j, l + cnt = 0 + do l = 1, ubound(x, dim=4) + do k = 1, ubound(x, dim=3) + do j = 1, ubound(x, dim=2) + do i = 1, ubound(x, dim=1) + if (x(i,j,k,l) >= 0) then + cnt = cnt + 1 + if (x(i,j,k,l) /= get_n([i,j,k,l], lbound(x), shape(x))) & + error stop 5 + endif + end do + end do + end do + end do +end + +subroutine check(x, loc1, cont, cnt) + integer, intent(in) :: x(:,:,:,:) + integer(c_intptr_t), intent(in), optional :: loc1 + logical, intent(in), optional :: cont ! dummy has CONTIGUOUS attr + integer, intent(in), optional :: cnt + integer(c_intptr_t) :: loc2 + integer :: i, k, j, l + if (present (loc1)) then + loc2 = %loc(x(1,1,1,1)) ! { dg-warning "Legacy Extension" } + if (is_contiguous (x) .or. .not.cont) then + if (loc1 /= loc2) error stop 1 + else + if (loc1 == loc2) error stop 2 + end if + if (cnt /= size(x)) error stop 3 + end if + do l = 1, ubound(x, dim=4) + do k = 1, ubound(x, dim=3) + do j = 1, ubound(x, dim=2) + do i = 1, ubound(x, dim=1) + if (x(i,j,k,l) /= -get_n([i,j,k,l], lbound(x), shape(x))) & + error stop 4 + end do + end do + end do + end do +end + +subroutine check2(x) + integer, contiguous, intent(in) :: x(:,:,:,:) + call check(x) +end subroutine +end diff --git a/Fortran/gfortran/regression/bind-c-contiguous-4.c b/Fortran/gfortran/regression/bind-c-contiguous-4.c --- /dev/null +++ b/Fortran/gfortran/regression/bind-c-contiguous-4.c @@ -0,0 +1,370 @@ +#include +#include +#include + +struct loc_t { + intptr_t x, y, z; +}; + +typedef struct loc_t (*ftn_fn) (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_size_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_size_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_expl_size_f (CFI_cdesc_t *,CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_expl_size_in_f (CFI_cdesc_t *,CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_rank_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_rank_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_rank_cont_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_rank_cont_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_shape_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_shape_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_shape_cont_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_shape_cont_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); + +static void +basic_check(CFI_cdesc_t *x, bool is_cont) +{ + if (!x->base_addr) + __builtin_abort (); + if (x->elem_len != 3*sizeof(char)) + __builtin_abort (); + if (x->version != CFI_VERSION) + __builtin_abort (); + if (x->rank != 1) + __builtin_abort (); + if (x->attribute != CFI_attribute_other) + __builtin_abort (); + if (x->type != CFI_type_char) + __builtin_abort (); + if (x->dim[0].lower_bound != 0) + __builtin_abort (); + if (x->dim[0].extent != 3) + __builtin_abort (); + if (CFI_is_contiguous (x) != (x->elem_len == x->dim[0].sm)) + __builtin_abort (); + if (is_cont != CFI_is_contiguous (x)) + __builtin_abort (); +} + +static void +print_str (void *p, size_t len) +{ + __builtin_printf ("DEBUG: >"); + for (size_t i = 0; i < len; ++i) + __builtin_printf ("%c", ((const char*) p)[i]); + __builtin_printf ("<\n"); +} + +static void +check_str (CFI_cdesc_t *x, const char *str, const CFI_index_t subscripts[]) +{ + /* Avoid checking for '\0'. */ + if (strncmp ((const char*) CFI_address (x, subscripts), str, strlen(str)) != 0) + __builtin_abort (); +} + +static void +set_str (CFI_cdesc_t *x, const char *str, const CFI_index_t subscripts[]) +{ + char *p = CFI_address (x, subscripts); + size_t len = strlen (str); + if (x->elem_len != len) + __builtin_abort (); + for (size_t i = 0; i < len; ++i) + p[i] = str[i]; +} + +static struct loc_t +do_call (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num, bool intent_in, ftn_fn fn, bool is_cont, bool fort_cont) +{ + const CFI_index_t zero[1] = { 0 }; + const CFI_index_t one[1] = { 1 }; + const CFI_index_t two[1] = { 2 }; + struct loc_t addr1, addr2; + if (k != 3) + __builtin_abort (); + + if (num == 3) + { + if (x != NULL) + __builtin_abort (); + if (y != NULL) + __builtin_abort (); + if (z != NULL) + __builtin_abort (); + addr2 = fn (x, y, z, 3, num); + if (addr2.x != -1 || addr2.y != -1 || addr2.z != -1) + __builtin_abort (); + return addr2; + } + if (x == NULL) + __builtin_abort (); + if (y == NULL) + __builtin_abort (); + if (z == NULL) + __builtin_abort (); + basic_check (x, is_cont || num == 2); + basic_check (y, is_cont || num == 2); + basic_check (z, is_cont || num == 2); + if (!is_cont && num == 1) + { + check_str (x, "abc", zero); + check_str (x, "ghi", one); + check_str (x, "nop", two); + check_str (y, "abc", zero); + check_str (y, "ghi", one); + check_str (y, "nop", two); + check_str (z, "abc", zero); + check_str (z, "ghi", one); + check_str (z, "nop", two); + } + else if (num == 1) + { + if (strncmp ((const char*) x->base_addr, "abcghinop", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) y->base_addr, "abcghinop", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) z->base_addr, "abcghinop", 9) != 0) + __builtin_abort (); + } + else if (num == 2) + { + if (strncmp ((const char*) x->base_addr, "defghijlm", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) y->base_addr, "defghijlm", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) z->base_addr, "defghijlm", 9) != 0) + __builtin_abort (); + } + else + __builtin_abort (); + addr1.x = (intptr_t) x->base_addr; + addr1.y = (intptr_t) y->base_addr; + addr1.z = (intptr_t) z->base_addr; + addr2 = fn (x, y, z, 3, num); + if (!CFI_is_contiguous (x) && fort_cont) + { + /* Check for callee copy in/copy out. */ + if (addr1.x == addr2.x || addr1.x != (intptr_t) x->base_addr) + __builtin_abort (); + if (addr1.y == addr2.y || addr1.y != (intptr_t) y->base_addr) + __builtin_abort (); + if (addr1.z == addr2.z || addr1.z != (intptr_t) z->base_addr) + __builtin_abort (); + } + else + { + if (addr1.x != addr2.x || addr1.x != (intptr_t) x->base_addr) + __builtin_abort (); + if (addr1.y != addr2.y || addr1.y != (intptr_t) y->base_addr) + __builtin_abort (); + if (addr1.z != addr2.z || addr1.z != (intptr_t) z->base_addr) + __builtin_abort (); + } + // intent_in + if (intent_in && !is_cont && num == 1) + { + check_str (x, "abc", zero); + check_str (x, "ghi", one); + check_str (x, "nop", two); + check_str (y, "abc", zero); + check_str (y, "ghi", one); + check_str (y, "nop", two); + check_str (z, "abc", zero); + check_str (z, "ghi", one); + check_str (z, "nop", two); + } + else if (intent_in && num == 1) + { + if (strncmp ((const char*) x->base_addr, "abcghinop", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) y->base_addr, "abcghinop", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) z->base_addr, "abcghinop", 9) != 0) + __builtin_abort (); + } + else if (intent_in && num == 2) + { + if (strncmp ((const char*) x->base_addr, "defghijlm", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) y->base_addr, "defghijlm", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) z->base_addr, "defghijlm", 9) != 0) + __builtin_abort (); + } + else if (intent_in) + __builtin_abort (); + if (intent_in) + { + if (is_cont && num == 1) + { + /* Copy in - set the value to check that no copy out is done. */ + memcpy ((char*) x->base_addr, "123456789", 9); + memcpy ((char*) y->base_addr, "123456789", 9); + memcpy ((char*) z->base_addr, "123456789", 9); + } + return addr1; + } + // !intent_in + if (!is_cont && num == 1) + { + check_str (x, "ABC", zero); + check_str (x, "DEF", one); + check_str (x, "GHI", two); + check_str (y, "ABC", zero); + check_str (y, "DEF", one); + check_str (y, "GHI", two); + check_str (z, "ABC", zero); + check_str (z, "DEF", one); + check_str (z, "GHI", two); + } + else + { + if (strncmp ((const char*) x->base_addr, "ABCDEFGHI", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) y->base_addr, "ABCDEFGHI", 9) != 0) + __builtin_abort (); + if (strncmp ((const char*) z->base_addr, "ABCDEFGHI", 9) != 0) + __builtin_abort (); + } + return addr1; +} + +struct loc_t +char_assumed_size_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_assumed_size_f, true, false); +} + +struct loc_t +char_assumed_size_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_size_in_f, true, false); +} + +struct loc_t +char_expl_size_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_expl_size_f, true, false); +} + +struct loc_t +char_expl_size_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_expl_size_in_f, true, false); +} + +struct loc_t +char_assumed_rank_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_assumed_rank_f, false, false); +} + +struct loc_t +char_assumed_rank_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_rank_in_f, false, false); +} + +struct loc_t +char_assumed_rank_cont_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_assumed_rank_cont_f, true, false); +} + +struct loc_t +char_assumed_rank_cont_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_rank_cont_in_f, true, false); +} + +static void +reset_var (CFI_cdesc_t *x, int num) +{ + const CFI_index_t zero[1] = { 0 }; + const CFI_index_t one[1] = { 1 }; + const CFI_index_t two[1] = { 2 }; + + if (num == 1) + { + set_str (x, "abc", zero); + set_str (x, "ghi", one); + set_str (x, "nop", two); + } + else if (num == 2) + { + set_str (x, "def", zero); + set_str (x, "ghi", one); + set_str (x, "jlm", two); + } + else if (num == 3) + { + if (x != NULL) + __builtin_abort (); + } + else + __builtin_abort (); +} + +static void +reset_vars (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, int num) +{ + reset_var (x, num); + reset_var (y, num); + reset_var (z, num); +} + +struct loc_t +char_assumed_shape_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + /* Make use of having a noncontiguous argument to check that the callee + handles noncontiguous variables. */ + do_call (x, y, z, k, num, false, char_assumed_size_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, true, char_assumed_size_in_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, false, char_expl_size_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, true, char_expl_size_in_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, false, char_assumed_rank_cont_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, true, char_assumed_rank_cont_in_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, false, char_assumed_shape_cont_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, true, char_assumed_shape_cont_in_f, false, true); + /* Actual func call. */ + reset_vars (x, y, z, num); + return do_call (x, y, z, k, num, false, char_assumed_shape_f, false, false); +} + +struct loc_t +char_assumed_shape_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_shape_in_f, false, false); +} + +struct loc_t +char_assumed_shape_cont_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_assumed_shape_cont_f, true, false); +} + +struct loc_t +char_assumed_shape_cont_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_shape_cont_in_f, true, false); +} diff --git a/Fortran/gfortran/regression/bind-c-contiguous-4.f90 b/Fortran/gfortran/regression/bind-c-contiguous-4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind-c-contiguous-4.f90 @@ -0,0 +1,1720 @@ +! { dg-do run } +! +! Same test as bind-c-contiguous-1.* but with OPTIONAL +! +! { dg-additional-sources bind-c-contiguous-4.c } +! { dg-additional-options "-fcheck=all" } +! { dg-additional-options -Wno-complain-wrong-lang } + +! Fortran demands that with bind(C), the callee ensure that for +! * 'contiguous' +! * len=* with explicit/assumed-size arrays +! noncontiguous actual arguments are handled. +! (in without bind(C) in gfortran, caller handles the copy in/out + +! Additionally, for a bind(C) callee, a Fortran-written caller +! has to ensure the same (for contiguous + len=* to explicit-/assumed-size arrays) + +module m + use iso_c_binding, only: c_intptr_t, c_bool, c_loc, c_int + implicit none (type, external) + + type, bind(C) :: loc_t + integer(c_intptr_t) :: x, y, z + end type loc_t + +interface + type(loc_t) function char_assumed_size_c (xx, yy, zz, n, num) bind(C) + import :: loc_t, c_bool, c_int + integer(c_int), value :: n, num + character(len=*), optional :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*) + end function + + type(loc_t) function char_assumed_size_in_c (xx, yy, zz, n, num) bind(C) + import :: loc_t, c_bool, c_int + integer(c_int), value :: n, num + character(len=*), intent(in), optional :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*) + end function + + type(loc_t) function char_expl_size_c (xx, yy, zz, n, num) bind(c) + import :: loc_t, c_bool, c_int + integer(c_int), value :: n, num + character(len=*), optional :: xx(n), yy(n:n+3), zz(6:6, 3:n, 3:n+3) + end function + + type(loc_t) function char_expl_size_in_c (xx, yy, zz, n, num) bind(c) + import :: loc_t, c_bool, c_int + integer(c_int), value :: n, num + character(len=*), intent(in), optional :: xx(n), yy(n:n+3), zz(6:6, 3:n, 3:n+3) + end function + + type(loc_t) function char_assumed_rank_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*), optional :: xx(..) + character(len=3), optional :: yy(..) + character(len=k), optional :: zz(..) + end function + + type(loc_t) function char_assumed_rank_in_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*), intent(in), optional :: xx(..) + character(len=3), intent(in), optional :: yy(..) + character(len=k), intent(in), optional :: zz(..) + end function + + type(loc_t) function char_assumed_rank_cont_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*), contiguous, optional :: xx(..) + character(len=3), contiguous, optional :: yy(..) + character(len=k), contiguous, optional :: zz(..) + end function + + type(loc_t) function char_assumed_rank_cont_in_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*), contiguous, intent(in), optional :: xx(..) + character(len=3), contiguous, intent(in), optional :: yy(..) + character(len=k), contiguous, intent(in), optional :: zz(..) + end function + + type(loc_t) function char_assumed_shape_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*), optional :: xx(:) + character(len=3), optional :: yy(5:) + character(len=k), optional :: zz(-k:) + end function + + type(loc_t) function char_assumed_shape_in_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*), intent(in), optional :: xx(:) + character(len=3), intent(in), optional :: yy(5:) + character(len=k), intent(in), optional :: zz(-k:) + end function + + type(loc_t) function char_assumed_shape_cont_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*), contiguous, optional :: xx(:) + character(len=3), contiguous, optional :: yy(5:) + character(len=k), contiguous, optional :: zz(-k:) + end function + + type(loc_t) function char_assumed_shape_cont_in_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(len=*), contiguous, intent(in), optional :: xx(:) + character(len=3), contiguous, intent(in), optional :: yy(5:) + character(len=k), contiguous, intent(in), optional :: zz(-k:) + end function +end interface + +contains + +type(loc_t) function char_assumed_size_f (xx, yy, zz, n, num) bind(c) result(res) + integer, value :: num, n + character(len=*), optional :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*) + if (num == 3) then + if (present (xx) .or. present (yy) .or. present (zz)) error stop 1 + res%x = -1; res%y = -1; res%z = -1 + return + end if + if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1 + print *, xx(1:3) + if (3 /= len(xx)) error stop 1 + if (3 /= len(yy)) error stop 1 + if (3 /= len(zz)) error stop 1 + if (1 /= lbound(xx,dim=1)) error stop 1 + if (3 /= lbound(yy,dim=1)) error stop 1 + if (6 /= lbound(zz,dim=1)) error stop 1 + if (3 /= lbound(zz,dim=2)) error stop 1 + if (3 /= lbound(zz,dim=3)) error stop 1 + if (1 /= size(zz,dim=1)) error stop 1 + if (1 /= size(zz,dim=2)) error stop 1 + if (6 /= ubound(zz,dim=1)) error stop 1 + if (3 /= ubound(zz,dim=2)) error stop 1 + if (num == 1) then + if (xx(1) /= "abc") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "nop") error stop 4 + if (yy(3) /= "abc") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "nop") error stop 4 + if (zz(6,n,3) /= "abc") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "nop") error stop 4 + else if (num == 2) then + if (xx(1) /= "def") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "jlm") error stop 4 + if (yy(3) /= "def") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "jlm") error stop 4 + if (zz(6,n,3) /= "def") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "jlm") error stop 4 + else + error stop 8 + endif + xx(1) = "ABC" + xx(2) = "DEF" + xx(3) = "GHI" + yy(3) = "ABC" + yy(4) = "DEF" + yy(5) = "GHI" + zz(6,n,3) = "ABC" + zz(6,n,4) = "DEF" + zz(6,n,5) = "GHI" + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + +type(loc_t) function char_assumed_size_in_f (xx, yy, zz, n, num) bind(c) result(res) + integer, value :: num, n + character(len=*), optional :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*) + intent(in) :: xx, yy, zz + if (num == 3) then + if (present (xx) .or. present (yy) .or. present (zz)) error stop 1 + res%x = -1; res%y = -1; res%z = -1 + return + end if + if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1 + print *, xx(1:3) + if (3 /= len(xx)) error stop 1 + if (3 /= len(yy)) error stop 1 + if (3 /= len(zz)) error stop 1 + if (1 /= lbound(xx,dim=1)) error stop 1 + if (3 /= lbound(yy,dim=1)) error stop 1 + if (6 /= lbound(zz,dim=1)) error stop 1 + if (3 /= lbound(zz,dim=2)) error stop 1 + if (3 /= lbound(zz,dim=3)) error stop 1 + if (1 /= size(zz,dim=1)) error stop 1 + if (1 /= size(zz,dim=2)) error stop 1 + if (6 /= ubound(zz,dim=1)) error stop 1 + if (3 /= ubound(zz,dim=2)) error stop 1 + if (num == 1) then + if (xx(1) /= "abc") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "nop") error stop 4 + if (yy(3) /= "abc") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "nop") error stop 4 + if (zz(6,n,3) /= "abc") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "nop") error stop 4 + else if (num == 2) then + if (xx(1) /= "def") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "jlm") error stop 4 + if (yy(3) /= "def") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "jlm") error stop 4 + if (zz(6,n,3) /= "def") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "jlm") error stop 4 + else + error stop 8 + endif + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } if (num == 1) then +end + +type(loc_t) function char_expl_size_f (xx, yy, zz, n, num) bind(c) result(res) + integer, value :: num, n + character(len=*), optional :: xx(n), yy(n:n+2), zz(6:6, 3:n, 3:n+2) + if (num == 3) then + if (present (xx) .or. present (yy) .or. present (zz)) error stop 1 + res%x = -1; res%y = -1; res%z = -1 + return + end if + if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1 + print *, xx(1:3) + if (3 /= len(xx)) error stop 1 + if (3 /= len(yy)) error stop 1 + if (3 /= len(zz)) error stop 1 + if (1 /= lbound(xx,dim=1)) error stop 1 + if (3 /= lbound(yy,dim=1)) error stop 1 + if (6 /= lbound(zz,dim=1)) error stop 1 + if (3 /= lbound(zz,dim=2)) error stop 1 + if (3 /= lbound(zz,dim=3)) error stop 1 + if (3 /= size(xx,dim=1)) error stop 1 + if (3 /= size(yy,dim=1)) error stop 1 + if (1 /= size(zz,dim=1)) error stop 1 + if (1 /= size(zz,dim=2)) error stop 1 + if (3 /= size(zz,dim=3)) error stop 1 + if (3 /= ubound(xx,dim=1)) error stop 1 + if (5 /= ubound(yy,dim=1)) error stop 1 + if (6 /= ubound(zz,dim=1)) error stop 1 + if (3 /= ubound(zz,dim=2)) error stop 1 + if (5 /= ubound(zz,dim=3)) error stop 1 + if (num == 1) then + if (xx(1) /= "abc") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "nop") error stop 4 + if (yy(3) /= "abc") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "nop") error stop 4 + if (zz(6,n,3) /= "abc") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "nop") error stop 4 + else if (num == 2) then + if (xx(1) /= "def") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "jlm") error stop 4 + if (yy(3) /= "def") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "jlm") error stop 4 + if (zz(6,n,3) /= "def") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "jlm") error stop 4 + else + error stop 8 + endif + xx(1) = "ABC" + xx(2) = "DEF" + xx(3) = "GHI" + yy(3) = "ABC" + yy(4) = "DEF" + yy(5) = "GHI" + zz(6,n,3) = "ABC" + zz(6,n,4) = "DEF" + zz(6,n,5) = "GHI" + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + +type(loc_t) function char_expl_size_in_f (xx, yy, zz, n, num) bind(c) result(res) + integer, value :: num, n + character(len=*), optional :: xx(n), yy(n:n+2), zz(6:6, 3:n, 3:n+2) + intent(in) :: xx, yy, zz + if (num == 3) then + if (present (xx) .or. present (yy) .or. present (zz)) error stop 1 + res%x = -1; res%y = -1; res%z = -1 + return + end if + if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1 + print *, xx(1:3) + if (3 /= len(xx)) error stop 1 + if (3 /= len(yy)) error stop 1 + if (3 /= len(zz)) error stop 1 + if (1 /= lbound(xx,dim=1)) error stop 1 + if (3 /= lbound(yy,dim=1)) error stop 1 + if (6 /= lbound(zz,dim=1)) error stop 1 + if (3 /= lbound(zz,dim=2)) error stop 1 + if (3 /= lbound(zz,dim=3)) error stop 1 + if (3 /= size(xx,dim=1)) error stop 1 + if (3 /= size(yy,dim=1)) error stop 1 + if (1 /= size(zz,dim=1)) error stop 1 + if (1 /= size(zz,dim=2)) error stop 1 + if (3 /= size(zz,dim=3)) error stop 1 + if (3 /= ubound(xx,dim=1)) error stop 1 + if (5 /= ubound(yy,dim=1)) error stop 1 + if (6 /= ubound(zz,dim=1)) error stop 1 + if (3 /= ubound(zz,dim=2)) error stop 1 + if (5 /= ubound(zz,dim=3)) error stop 1 + if (num == 1) then + if (xx(1) /= "abc") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "nop") error stop 4 + if (yy(3) /= "abc") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "nop") error stop 4 + if (zz(6,n,3) /= "abc") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "nop") error stop 4 + else if (num == 2) then + if (xx(1) /= "def") error stop 2 + if (xx(2) /= "ghi") error stop 3 + if (xx(3) /= "jlm") error stop 4 + if (yy(3) /= "def") error stop 2 + if (yy(4) /= "ghi") error stop 3 + if (yy(5) /= "jlm") error stop 4 + if (zz(6,n,3) /= "def") error stop 2 + if (zz(6,n,4) /= "ghi") error stop 3 + if (zz(6,n,5) /= "jlm") error stop 4 + else + error stop 8 + endif + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + + +type(loc_t) function char_assumed_rank_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*), optional :: xx(..) + character(len=3), optional :: yy(..) + character(len=k), optional :: zz(..) + if (num == 3) then + if (present (xx) .or. present (yy) .or. present (zz)) error stop 1 + res%x = -1; res%y = -1; res%z = -1 + return + end if + if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1 + if (3 /= len(xx)) error stop 40 + if (3 /= len(yy)) error stop 40 + if (3 /= len(zz)) error stop 40 + if (3 /= size(xx)) error stop 41 + if (3 /= size(yy)) error stop 41 + if (3 /= size(zz)) error stop 41 + if (1 /= rank(xx)) error stop 49 + if (1 /= rank(yy)) error stop 49 + if (1 /= rank(zz)) error stop 49 + if (1 /= lbound(xx, dim=1)) stop 49 + if (1 /= lbound(yy, dim=1)) stop 49 + if (1 /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (3 /= ubound(yy, dim=1)) stop 49 + if (3 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (is_contiguous (xx)) error stop 49 + if (is_contiguous (yy)) error stop 49 + if (is_contiguous (zz)) error stop 49 + else if (num == 2) then + if (.not. is_contiguous (xx)) error stop 49 + if (.not. is_contiguous (yy)) error stop 49 + if (.not. is_contiguous (zz)) error stop 49 + else + error stop 48 + end if + select rank (xx) + rank (1) + print *, xx(1:3) + if (num == 1) then + if (xx(1) /= "abc") error stop 42 + if (xx(2) /= "ghi") error stop 43 + if (xx(3) /= "nop") error stop 44 + else if (num == 2) then + if (xx(1) /= "def") error stop 45 + if (xx(2) /= "ghi") error stop 46 + if (xx(3) /= "jlm") error stop 47 + else + error stop 48 + endif + xx(1) = "ABC" + xx(2) = "DEF" + xx(3) = "GHI" + res%x = get_loc (xx) + rank default + error stop 99 + end select + select rank (yy) + rank (1) + print *, yy(1:3) + if (num == 1) then + if (yy(1) /= "abc") error stop 42 + if (yy(2) /= "ghi") error stop 43 + if (yy(3) /= "nop") error stop 44 + else if (num == 2) then + if (yy(1) /= "def") error stop 45 + if (yy(2) /= "ghi") error stop 46 + if (yy(3) /= "jlm") error stop 47 + else + error stop 48 + endif + yy(1) = "ABC" + yy(2) = "DEF" + yy(3) = "GHI" + res%y = get_loc (yy) + rank default + error stop 99 + end select + select rank (zz) + rank (1) + print *, zz(1:3) + if (num == 1) then + if (zz(1) /= "abc") error stop 42 + if (zz(2) /= "ghi") error stop 43 + if (zz(3) /= "nop") error stop 44 + else if (num == 2) then + if (zz(1) /= "def") error stop 45 + if (zz(2) /= "ghi") error stop 46 + if (zz(3) /= "jlm") error stop 47 + else + error stop 48 + endif + zz(1) = "ABC" + zz(2) = "DEF" + zz(3) = "GHI" + res%z = get_loc (zz) + rank default + error stop 99 + end select +contains + integer (c_intptr_t) function get_loc (arg) + character(len=*), target :: arg(:) + ! %loc does copy in/out if not simply contiguous + ! extra func needed because of 'target' attribute + get_loc = transfer (c_loc(arg), res%x) + end +end + +type(loc_t) function char_assumed_rank_in_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*), optional :: xx(..) + character(len=3), optional :: yy(..) + character(len=k), optional :: zz(..) + intent(in) :: xx, yy, zz + if (num == 3) then + if (present (xx) .or. present (yy) .or. present (zz)) error stop 1 + res%x = -1; res%y = -1; res%z = -1 + return + end if + if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1 + if (3 /= size(yy)) error stop 50 + if (3 /= len(yy)) error stop 51 + if (1 /= rank(yy)) error stop 59 + if (1 /= lbound(xx, dim=1)) stop 49 + if (1 /= lbound(yy, dim=1)) stop 49 + if (1 /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (3 /= ubound(yy, dim=1)) stop 49 + if (3 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (is_contiguous (xx)) error stop 59 + if (is_contiguous (yy)) error stop 59 + if (is_contiguous (zz)) error stop 59 + else if (num == 2) then + if (.not. is_contiguous (xx)) error stop 59 + if (.not. is_contiguous (yy)) error stop 59 + if (.not. is_contiguous (zz)) error stop 59 + else + error stop 48 + end if + select rank (xx) + rank (1) + print *, xx(1:3) + if (num == 1) then + if (xx(1) /= "abc") error stop 52 + if (xx(2) /= "ghi") error stop 53 + if (xx(3) /= "nop") error stop 54 + else if (num == 2) then + if (xx(1) /= "def") error stop 55 + if (xx(2) /= "ghi") error stop 56 + if (xx(3) /= "jlm") error stop 57 + else + error stop 58 + endif + res%x = get_loc(xx) + rank default + error stop 99 + end select + select rank (yy) + rank (1) + print *, yy(1:3) + if (num == 1) then + if (yy(1) /= "abc") error stop 52 + if (yy(2) /= "ghi") error stop 53 + if (yy(3) /= "nop") error stop 54 + else if (num == 2) then + if (yy(1) /= "def") error stop 55 + if (yy(2) /= "ghi") error stop 56 + if (yy(3) /= "jlm") error stop 57 + else + error stop 58 + endif + res%y = get_loc(yy) + rank default + error stop 99 + end select + select rank (zz) + rank (1) + print *, zz(1:3) + if (num == 1) then + if (zz(1) /= "abc") error stop 52 + if (zz(2) /= "ghi") error stop 53 + if (zz(3) /= "nop") error stop 54 + else if (num == 2) then + if (zz(1) /= "def") error stop 55 + if (zz(2) /= "ghi") error stop 56 + if (zz(3) /= "jlm") error stop 57 + else + error stop 58 + endif + res%z = get_loc(zz) + rank default + error stop 99 + end select +contains + integer (c_intptr_t) function get_loc (arg) + character(len=*), target :: arg(:) + ! %loc does copy in/out if not simply contiguous + ! extra func needed because of 'target' attribute + get_loc = transfer (c_loc(arg), res%x) + end +end + + + +type(loc_t) function char_assumed_rank_cont_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*), optional :: xx(..) + character(len=3), optional :: yy(..) + character(len=k), optional :: zz(..) + contiguous :: xx, yy, zz + if (num == 3) then + if (present (xx) .or. present (yy) .or. present (zz)) error stop 1 + res%x = -1; res%y = -1; res%z = -1 + return + end if + if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1 + if (3 /= len(xx)) error stop 60 + if (3 /= len(yy)) error stop 60 + if (3 /= len(zz)) error stop 60 + if (3 /= size(xx)) error stop 61 + if (3 /= size(yy)) error stop 61 + if (3 /= size(zz)) error stop 61 + if (1 /= rank(xx)) error stop 69 + if (1 /= rank(yy)) error stop 69 + if (1 /= rank(zz)) error stop 69 + if (1 /= lbound(xx, dim=1)) stop 49 + if (1 /= lbound(yy, dim=1)) stop 49 + if (1 /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (3 /= ubound(yy, dim=1)) stop 49 + if (3 /= ubound(zz, dim=1)) stop 49 + select rank (xx) + rank (1) + print *, xx(1:3) + if (num == 1) then + if (xx(1) /= "abc") error stop 62 + if (xx(2) /= "ghi") error stop 63 + if (xx(3) /= "nop") error stop 64 + else if (num == 2) then + if (xx(1) /= "def") error stop 65 + if (xx(2) /= "ghi") error stop 66 + if (xx(3) /= "jlm") error stop 67 + else + error stop 68 + endif + xx(1) = "ABC" + xx(2) = "DEF" + xx(3) = "GHI" + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select + select rank (yy) + rank (1) + print *, yy(1:3) + if (num == 1) then + if (yy(1) /= "abc") error stop 62 + if (yy(2) /= "ghi") error stop 63 + if (yy(3) /= "nop") error stop 64 + else if (num == 2) then + if (yy(1) /= "def") error stop 65 + if (yy(2) /= "ghi") error stop 66 + if (yy(3) /= "jlm") error stop 67 + else + error stop 68 + endif + yy(1) = "ABC" + yy(2) = "DEF" + yy(3) = "GHI" + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select + select rank (zz) + rank (1) + print *, zz(1:3) + if (num == 1) then + if (zz(1) /= "abc") error stop 62 + if (zz(2) /= "ghi") error stop 63 + if (zz(3) /= "nop") error stop 64 + else if (num == 2) then + if (zz(1) /= "def") error stop 65 + if (zz(2) /= "ghi") error stop 66 + if (zz(3) /= "jlm") error stop 67 + else + error stop 68 + endif + zz(1) = "ABC" + zz(2) = "DEF" + zz(3) = "GHI" + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select +end + +type(loc_t) function char_assumed_rank_cont_in_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*), optional :: xx(..) + character(len=3), optional :: yy(..) + character(len=k), optional :: zz(..) + intent(in) :: xx, yy, zz + contiguous :: xx, yy, zz + if (num == 3) then + if (present (xx) .or. present (yy) .or. present (zz)) error stop 1 + res%x = -1; res%y = -1; res%z = -1 + return + end if + if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1 + if (3 /= size(xx)) error stop 30 + if (3 /= size(yy)) error stop 30 + if (3 /= size(zz)) error stop 30 + if (3 /= len(xx)) error stop 31 + if (3 /= len(yy)) error stop 31 + if (3 /= len(zz)) error stop 31 + if (1 /= rank(xx)) error stop 69 + if (1 /= rank(yy)) error stop 69 + if (1 /= rank(zz)) error stop 69 + if (1 /= lbound(xx, dim=1)) stop 49 + if (1 /= lbound(yy, dim=1)) stop 49 + if (1 /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (3 /= ubound(yy, dim=1)) stop 49 + if (3 /= ubound(zz, dim=1)) stop 49 + select rank (xx) + rank (1) + print *, xx(1:3) + if (num == 1) then + if (xx(1) /= "abc") error stop 62 + if (xx(2) /= "ghi") error stop 63 + if (xx(3) /= "nop") error stop 64 + else if (num == 2) then + if (xx(1) /= "def") error stop 65 + if (xx(2) /= "ghi") error stop 66 + if (xx(3) /= "jlm") error stop 67 + else + error stop 68 + endif + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select + select rank (yy) + rank (1) + print *, yy(1:3) + if (num == 1) then + if (yy(1) /= "abc") error stop 62 + if (yy(2) /= "ghi") error stop 63 + if (yy(3) /= "nop") error stop 64 + else if (num == 2) then + if (yy(1) /= "def") error stop 65 + if (yy(2) /= "ghi") error stop 66 + if (yy(3) /= "jlm") error stop 67 + else + error stop 68 + endif + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select + select rank (zz) + rank (1) + print *, zz(1:3) + if (num == 1) then + if (zz(1) /= "abc") error stop 62 + if (zz(2) /= "ghi") error stop 63 + if (zz(3) /= "nop") error stop 64 + else if (num == 2) then + if (zz(1) /= "def") error stop 65 + if (zz(2) /= "ghi") error stop 66 + if (zz(3) /= "jlm") error stop 67 + else + error stop 68 + endif + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select +end + +type(loc_t) function char_assumed_shape_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*), optional :: xx(:) + character(len=3), optional :: yy(5:) + character(len=k), optional :: zz(-k:) + if (num == 3) then + if (present (xx) .or. present (yy) .or. present (zz)) error stop 1 + res%x = -1; res%y = -1; res%z = -1 + return + end if + if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1 + print *, xx(1:3) + if (3 /= len(xx)) error stop 70 + if (3 /= len(yy)) error stop 70 + if (3 /= len(zz)) error stop 70 + if (3 /= size(xx)) error stop 71 + if (3 /= size(yy)) error stop 71 + if (3 /= size(zz)) error stop 71 + if (1 /= lbound(xx, dim=1)) stop 49 + if (5 /= lbound(yy, dim=1)) stop 49 + if (-k /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (7 /= ubound(yy, dim=1)) stop 49 + if (-k+2 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (is_contiguous (xx)) error stop 79 + if (is_contiguous (yy)) error stop 79 + if (is_contiguous (zz)) error stop 79 + if (xx(1) /= "abc") error stop 72 + if (xx(2) /= "ghi") error stop 73 + if (xx(3) /= "nop") error stop 74 + if (yy(5) /= "abc") error stop 72 + if (yy(6) /= "ghi") error stop 73 + if (yy(7) /= "nop") error stop 74 + if (zz(-k) /= "abc") error stop 72 + if (zz(-k+1) /= "ghi") error stop 73 + if (zz(-k+2) /= "nop") error stop 74 + else if (num == 2) then + if (.not.is_contiguous (xx)) error stop 79 + if (.not.is_contiguous (yy)) error stop 79 + if (.not.is_contiguous (zz)) error stop 79 + if (xx(1) /= "def") error stop 72 + if (xx(2) /= "ghi") error stop 73 + if (xx(3) /= "jlm") error stop 74 + if (yy(5) /= "def") error stop 72 + if (yy(6) /= "ghi") error stop 73 + if (yy(7) /= "jlm") error stop 74 + if (zz(-k) /= "def") error stop 72 + if (zz(-k+1) /= "ghi") error stop 73 + if (zz(-k+2) /= "jlm") error stop 74 + else + error stop 78 + endif + xx(1) = "ABC" + xx(2) = "DEF" + xx(3) = "GHI" + yy(5) = "ABC" + yy(6) = "DEF" + yy(7) = "GHI" + zz(-k) = "ABC" + zz(-k+1) = "DEF" + zz(-k+2) = "GHI" + res%x = get_loc(xx) + res%y = get_loc(yy) + res%z = get_loc(zz) +contains + integer (c_intptr_t) function get_loc (arg) + character(len=*), target :: arg(:) + ! %loc does copy in/out if not simply contiguous + ! extra func needed because of 'target' attribute + get_loc = transfer (c_loc(arg), res%x) + end +end + +type(loc_t) function char_assumed_shape_in_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*), optional :: xx(:) + character(len=3), optional :: yy(5:) + character(len=k), optional :: zz(-k:) + intent(in) :: xx, yy, zz + if (num == 3) then + if (present (xx) .or. present (yy) .or. present (zz)) error stop 1 + res%x = -1; res%y = -1; res%z = -1 + return + end if + if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1 + print *, xx(1:3) + if (3 /= size(xx)) error stop 80 + if (3 /= size(yy)) error stop 80 + if (3 /= size(zz)) error stop 80 + if (3 /= len(xx)) error stop 81 + if (3 /= len(yy)) error stop 81 + if (3 /= len(zz)) error stop 81 + if (1 /= lbound(xx, dim=1)) stop 49 + if (5 /= lbound(yy, dim=1)) stop 49 + if (-k /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (7 /= ubound(yy, dim=1)) stop 49 + if (-k+2 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (is_contiguous (xx)) error stop 89 + if (is_contiguous (yy)) error stop 89 + if (is_contiguous (zz)) error stop 89 + if (xx(1) /= "abc") error stop 82 + if (xx(2) /= "ghi") error stop 83 + if (xx(3) /= "nop") error stop 84 + if (yy(5) /= "abc") error stop 82 + if (yy(6) /= "ghi") error stop 83 + if (yy(7) /= "nop") error stop 84 + if (zz(-k) /= "abc") error stop 82 + if (zz(-k+1) /= "ghi") error stop 83 + if (zz(-k+2) /= "nop") error stop 84 + else if (num == 2) then + if (.not.is_contiguous (xx)) error stop 89 + if (.not.is_contiguous (yy)) error stop 89 + if (.not.is_contiguous (zz)) error stop 89 + if (xx(1) /= "def") error stop 85 + if (xx(2) /= "ghi") error stop 86 + if (xx(3) /= "jlm") error stop 87 + if (yy(5) /= "def") error stop 85 + if (yy(6) /= "ghi") error stop 86 + if (yy(7) /= "jlm") error stop 87 + if (zz(-k) /= "def") error stop 85 + if (zz(-k+1) /= "ghi") error stop 86 + if (zz(-k+2) /= "jlm") error stop 87 + else + error stop 88 + endif + res%x = get_loc(xx) + res%y = get_loc(yy) + res%z = get_loc(zz) +contains + integer (c_intptr_t) function get_loc (arg) + character(len=*), target :: arg(:) + ! %loc does copy in/out if not simply contiguous + ! extra func needed because of 'target' attribute + get_loc = transfer (c_loc(arg), res%x) + end +end + + + +type(loc_t) function char_assumed_shape_cont_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*), optional :: xx(:) + character(len=3), optional :: yy(5:) + character(len=k), optional :: zz(-k:) + contiguous :: xx, yy, zz + if (num == 3) then + if (present (xx) .or. present (yy) .or. present (zz)) error stop 1 + res%x = -1; res%y = -1; res%z = -1 + return + end if + if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1 + print *, xx(1:3) + if (3 /= len(xx)) error stop 90 + if (3 /= len(yy)) error stop 90 + if (3 /= len(zz)) error stop 90 + if (3 /= size(xx)) error stop 91 + if (3 /= size(yy)) error stop 91 + if (3 /= size(zz)) error stop 91 + if (1 /= lbound(xx, dim=1)) stop 49 + if (5 /= lbound(yy, dim=1)) stop 49 + if (-k /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (7 /= ubound(yy, dim=1)) stop 49 + if (-k+2 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (xx(1) /= "abc") error stop 92 + if (xx(2) /= "ghi") error stop 93 + if (xx(3) /= "nop") error stop 94 + if (yy(5) /= "abc") error stop 92 + if (yy(6) /= "ghi") error stop 93 + if (yy(7) /= "nop") error stop 94 + if (zz(-k) /= "abc") error stop 92 + if (zz(-k+1) /= "ghi") error stop 93 + if (zz(-k+2) /= "nop") error stop 94 + else if (num == 2) then + if (xx(1) /= "def") error stop 92 + if (xx(2) /= "ghi") error stop 93 + if (xx(3) /= "jlm") error stop 94 + if (yy(5) /= "def") error stop 92 + if (yy(6) /= "ghi") error stop 93 + if (yy(7) /= "jlm") error stop 94 + if (zz(-k) /= "def") error stop 92 + if (zz(-k+1) /= "ghi") error stop 93 + if (zz(-k+2) /= "jlm") error stop 94 + else + error stop 98 + endif + xx(1) = "ABC" + xx(2) = "DEF" + xx(3) = "GHI" + yy(5) = "ABC" + yy(6) = "DEF" + yy(7) = "GHI" + zz(-k) = "ABC" + zz(-k+1) = "DEF" + zz(-k+2) = "GHI" + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + +type(loc_t) function char_assumed_shape_cont_in_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(len=*), optional :: xx(:) + character(len=3), optional :: yy(5:) + character(len=k), optional :: zz(-k:) + intent(in) :: xx, yy, zz + contiguous :: xx, yy, zz + if (num == 3) then + if (present (xx) .or. present (yy) .or. present (zz)) error stop 1 + res%x = -1; res%y = -1; res%z = -1 + return + end if + if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1 + print *, xx(1:3) + if (3 /= size(xx)) error stop 100 + if (3 /= size(yy)) error stop 100 + if (3 /= size(zz)) error stop 100 + if (3 /= len(xx)) error stop 101 + if (3 /= len(yy)) error stop 101 + if (3 /= len(zz)) error stop 101 + if (1 /= lbound(xx, dim=1)) stop 49 + if (5 /= lbound(yy, dim=1)) stop 49 + if (-k /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (7 /= ubound(yy, dim=1)) stop 49 + if (-k+2 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (xx(1) /= "abc") error stop 102 + if (xx(2) /= "ghi") error stop 103 + if (xx(3) /= "nop") error stop 104 + if (yy(5) /= "abc") error stop 102 + if (yy(6) /= "ghi") error stop 103 + if (yy(7) /= "nop") error stop 104 + if (zz(-k) /= "abc") error stop 102 + if (zz(-k+1) /= "ghi") error stop 103 + if (zz(-k+2) /= "nop") error stop 104 + else if (num == 2) then + if (xx(1) /= "def") error stop 105 + if (xx(2) /= "ghi") error stop 106 + if (xx(3) /= "jlm") error stop 107 + if (yy(5) /= "def") error stop 105 + if (yy(6) /= "ghi") error stop 106 + if (yy(7) /= "jlm") error stop 107 + if (zz(-k) /= "def") error stop 105 + if (zz(-k+1) /= "ghi") error stop 106 + if (zz(-k+2) /= "jlm") error stop 107 + else + error stop 108 + endif + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + +end module + + +use m +implicit none (type, external) +character(len=3) :: a(6), a2(6), a3(6), a_init(6) +type(loc_t) :: loc3 + +a_init = ['abc', 'def', 'ghi', 'jlm', 'nop', 'qrs'] + +! -- Fortran: assumed size +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_f (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +loc3 = char_assumed_size_f (n=size(a(2:4)), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_in_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_in_f (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +loc3 = char_assumed_size_in_f (n=size(a(2:4)), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +! -- Fortran: explicit shape +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_f (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +loc3 = char_expl_size_f (n=size(a(2:4)), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_in_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_in_f (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +loc3 = char_expl_size_in_f (n=size(a(::2)), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +! -- Fortran: assumed rank +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_f (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +loc3 = char_assumed_rank_f (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +loc3 = char_assumed_rank_in_f (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +! -- Fortran: assumed rank contiguous +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +loc3 = char_assumed_rank_cont_f (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +loc3 = char_assumed_rank_cont_in_f (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +! -- Fortran: assumed shape +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_f (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +loc3 = char_assumed_shape_f (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +loc3 = char_assumed_shape_in_f (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +! -- Fortran: assumed shape contiguous +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +loc3 = char_assumed_shape_cont_f (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +loc3 = char_assumed_shape_cont_in_f (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + + +! --- character - call C directly -- + +! -- C: assumed size +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_c (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +loc3 = char_assumed_size_c (n=size(a(2:4)), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_in_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_in_c (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +loc3 = char_assumed_size_in_c (n=size(a(2:4)), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +! -- C: explicit shape +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_c (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +loc3 = char_expl_size_c (n=size(a(::2)), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_in_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_in_c (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +loc3 = char_expl_size_in_c (n=size(a(::2)), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +! -- C: assumed rank +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_c (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +loc3 = char_assumed_rank_c (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +loc3 = char_assumed_rank_in_c (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +! -- C: assumed rank contiguous +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +loc3 = char_assumed_rank_cont_c (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +loc3 = char_assumed_rank_cont_in_c (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +! -- C: assumed shape +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_c (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +loc3 = char_assumed_shape_c (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +loc3 = char_assumed_shape_in_c (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +! -- C: assumed shape contiguous +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 +if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 +if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54 + +loc3 = char_assumed_shape_cont_c (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +loc3 = char_assumed_shape_cont_in_c (k=len(a), num=3) +if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2 +end + +! { dg-output "At line 1003 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_f'(\r*\n+)" }" +! { dg-output "At line 1003 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_f'(\r*\n+)" }" +! { dg-output "At line 1003 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_f'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1024 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_in_f'(\r*\n+)" }" +! { dg-output "At line 1024 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_in_f'(\r*\n+)" }" +! { dg-output "At line 1024 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_in_f'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1046 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_f'(\r*\n+)" }" +! { dg-output "At line 1046 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_f'(\r*\n+)" }" +! { dg-output "At line 1046 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_f'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1067 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_in_f'(\r*\n+)" }" +! { dg-output "At line 1067 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_in_f'(\r*\n+)" }" +! { dg-output "At line 1067 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_in_f'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1132 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_f'(\r*\n+)" }" +! { dg-output "At line 1132 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_f'(\r*\n+)" }" +! { dg-output "At line 1132 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_f'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1153 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_in_f'(\r*\n+)" }" +! { dg-output "At line 1153 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_in_f'(\r*\n+)" }" +! { dg-output "At line 1153 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_in_f'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1218 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_f'(\r*\n+)" }" +! { dg-output "At line 1218 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_f'(\r*\n+)" }" +! { dg-output "At line 1218 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_f'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1239 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_in_f'(\r*\n+)" }" +! { dg-output "At line 1239 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_in_f'(\r*\n+)" }" +! { dg-output "At line 1239 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_in_f'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1264 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_c'(\r*\n+)" }" +! { dg-output "At line 1264 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_c'(\r*\n+)" }" +! { dg-output "At line 1264 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_c'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1285 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_in_c'(\r*\n+)" }" +! { dg-output "At line 1285 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_in_c'(\r*\n+)" }" +! { dg-output "At line 1285 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_in_c'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1307 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_c'(\r*\n+)" }" +! { dg-output "At line 1307 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_c'(\r*\n+)" }" +! { dg-output "At line 1307 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_c'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1328 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_in_c'(\r*\n+)" }" +! { dg-output "At line 1328 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_in_c'(\r*\n+)" }" +! { dg-output "At line 1328 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_in_c'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1393 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_c'(\r*\n+)" }" +! { dg-output "At line 1393 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_c'(\r*\n+)" }" +! { dg-output "At line 1393 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_c'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1414 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_in_c'(\r*\n+)" }" +! { dg-output "At line 1414 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_in_c'(\r*\n+)" }" +! { dg-output "At line 1414 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_in_c'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1479 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_c'(\r*\n+)" }" +! { dg-output "At line 1479 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_c'(\r*\n+)" }" +! { dg-output "At line 1479 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_c'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1500 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_in_c'(\r*\n+)" }" +! { dg-output "At line 1500 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_in_c'(\r*\n+)" }" +! { dg-output "At line 1500 of file .*bind-c-contiguous-4.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_in_c'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" diff --git a/Fortran/gfortran/regression/bind-c-contiguous-5.c b/Fortran/gfortran/regression/bind-c-contiguous-5.c --- /dev/null +++ b/Fortran/gfortran/regression/bind-c-contiguous-5.c @@ -0,0 +1,446 @@ +#include +#include +#include + +struct loc_t { + intptr_t x, y, z; +}; + +typedef struct loc_t (*ftn_fn) (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_size_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_size_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_expl_size_f (CFI_cdesc_t *,CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_expl_size_in_f (CFI_cdesc_t *,CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_rank_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_rank_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_rank_cont_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_rank_cont_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_shape_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_shape_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_shape_cont_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); +struct loc_t char_assumed_shape_cont_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int); + +static void +basic_check(CFI_cdesc_t *x, bool is_cont) +{ + if (!x->base_addr) + __builtin_abort (); + if (x->elem_len != 3*(4*sizeof(char))) /* ucs4_char */ + __builtin_abort (); + if (x->version != CFI_VERSION) + __builtin_abort (); + if (x->rank != 1) + __builtin_abort (); + if (x->attribute != CFI_attribute_other) + __builtin_abort (); + if (x->type != CFI_type_ucs4_char) + __builtin_abort (); + if (x->dim[0].lower_bound != 0) + __builtin_abort (); + if (x->dim[0].extent != 3) + __builtin_abort (); + if (CFI_is_contiguous (x) != (x->elem_len == x->dim[0].sm)) + __builtin_abort (); + if (is_cont != CFI_is_contiguous (x)) + __builtin_abort (); +} + +static void +print_str (void *p, size_t len) +{ + __builtin_printf ("DEBUG: >"); + /* Use ' ' for '\0' */ + for (size_t i = 0; i < len*4; ++i) + __builtin_printf ("%c", ((const char*) p)[i] ? ((const char*) p)[i] : ' '); + __builtin_printf ("<\n"); +} + +static void +check_str (CFI_cdesc_t *x, const char *str, size_t n, const CFI_index_t subscripts[]) +{ + /* Avoid checking for '\0'. */ + if (memcmp ((const char*) CFI_address (x, subscripts), str, n) != 0) + __builtin_abort (); +} + +static void +set_str (CFI_cdesc_t *x, const char *str, size_t n, const CFI_index_t subscripts[]) +{ + char *p = CFI_address (x, subscripts); + if (x->elem_len != n) + __builtin_abort (); + for (size_t i = 0; i < n; ++i) + p[i] = str[i]; +} + +static struct loc_t +do_call (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num, bool intent_in, ftn_fn fn, bool is_cont, bool fort_cont) +{ + const CFI_index_t zero[1] = { 0 }; + const CFI_index_t one[1] = { 1 }; + const CFI_index_t two[1] = { 2 }; + struct loc_t addr1, addr2; + if (k != 3) + __builtin_abort (); + basic_check (x, is_cont || num == 2); + basic_check (y, is_cont || num == 2); + basic_check (z, is_cont || num == 2); + if (!is_cont && num == 1) + { +#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ + check_str (x, "a\0\0\0b\0\0\0c\0\0\0", 3*4, zero); + check_str (x, "g\0\0\0h\0\0\0i\0\0\0", 3*4, one); + check_str (x, "n\0\0\0o\0\0\0p\0\0\0", 3*4, two); + check_str (y, "a\0\0\0b\0\0\0c\0\0\0", 3*4, zero); + check_str (y, "g\0\0\0h\0\0\0i\0\0\0", 3*4, one); + check_str (y, "n\0\0\0o\0\0\0p\0\0\0", 3*4, two); + check_str (z, "a\0\0\0b\0\0\0c\0\0\0", 3*4, zero); + check_str (z, "g\0\0\0h\0\0\0i\0\0\0", 3*4, one); + check_str (z, "n\0\0\0o\0\0\0p\0\0\0", 3*4, two); +#elif __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ + check_str (x, "\0\0\0a\0\0\0b\0\0\0c", 3*4, zero); + check_str (x, "\0\0\0g\0\0\0h\0\0\0i", 3*4, one); + check_str (x, "\0\0\0n\0\0\0o\0\0\0p", 3*4, two); + check_str (y, "\0\0\0a\0\0\0b\0\0\0c", 3*4, zero); + check_str (y, "\0\0\0g\0\0\0h\0\0\0i", 3*4, one); + check_str (y, "\0\0\0n\0\0\0o\0\0\0p", 3*4, two); + check_str (z, "\0\0\0a\0\0\0b\0\0\0c", 3*4, zero); + check_str (z, "\0\0\0g\0\0\0h\0\0\0i", 3*4, one); + check_str (z, "\0\0\0n\0\0\0o\0\0\0p", 3*4, two); +#else +#error "Unsupported __BYTE_ORDER__" +#endif + } + else if (num == 1) + { +#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ + if (memcmp ((const char*) x->base_addr, "a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p\0\0\0", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) y->base_addr, "a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p\0\0\0", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) z->base_addr, "a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p\0\0\0", 9*4) != 0) + __builtin_abort (); +#else + if (memcmp ((const char*) x->base_addr, "\0\0\0a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) y->base_addr, "\0\0\0a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) z->base_addr, "\0\0\0a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p", 9*4) != 0) + __builtin_abort (); +#endif + } + else if (num == 2) + { +#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ + if (memcmp ((const char*) x->base_addr, "d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m\0\0\0", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) y->base_addr, "d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m\0\0\0", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) z->base_addr, "d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m\0\0\0", 9*4) != 0) + __builtin_abort (); +#else + if (memcmp ((const char*) x->base_addr, "\0\0\0d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) y->base_addr, "\0\0\0d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) z->base_addr, "\0\0\0d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m", 9*4) != 0) + __builtin_abort (); +#endif + } + else + __builtin_abort (); + addr1.x = (intptr_t) x->base_addr; + addr1.y = (intptr_t) y->base_addr; + addr1.z = (intptr_t) z->base_addr; + addr2 = fn (x, y, z, 3, num); + if (!CFI_is_contiguous (x) && fort_cont) + { + /* Check for callee copy in/copy out. */ + if (addr1.x == addr2.x || addr1.x != (intptr_t) x->base_addr) + __builtin_abort (); + if (addr1.y == addr2.y || addr1.y != (intptr_t) y->base_addr) + __builtin_abort (); + if (addr1.z == addr2.z || addr1.z != (intptr_t) z->base_addr) + __builtin_abort (); + } + else + { + if (addr1.x != addr2.x || addr1.x != (intptr_t) x->base_addr) + __builtin_abort (); + if (addr1.y != addr2.y || addr1.y != (intptr_t) y->base_addr) + __builtin_abort (); + if (addr1.z != addr2.z || addr1.z != (intptr_t) z->base_addr) + __builtin_abort (); + } + // intent_in + if (intent_in && !is_cont && num == 1) + { +#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ + check_str (x, "a\0\0\0b\0\0\0c\0\0\0", 3*4, zero); + check_str (x, "g\0\0\0h\0\0\0i\0\0\0", 3*4, one); + check_str (x, "n\0\0\0o\0\0\0p\0\0\0", 3*4, two); + check_str (y, "a\0\0\0b\0\0\0c\0\0\0", 3*4, zero); + check_str (y, "g\0\0\0h\0\0\0i\0\0\0", 3*4, one); + check_str (y, "n\0\0\0o\0\0\0p\0\0\0", 3*4, two); + check_str (z, "a\0\0\0b\0\0\0c\0\0\0", 3*4, zero); + check_str (z, "g\0\0\0h\0\0\0i\0\0\0", 3*4, one); + check_str (z, "n\0\0\0o\0\0\0p\0\0\0", 3*4, two); +#else + check_str (x, "\0\0\0a\0\0\0b\0\0\0c", 3*4, zero); + check_str (x, "\0\0\0g\0\0\0h\0\0\0i", 3*4, one); + check_str (x, "\0\0\0n\0\0\0o\0\0\0p", 3*4, two); + check_str (y, "\0\0\0a\0\0\0b\0\0\0c", 3*4, zero); + check_str (y, "\0\0\0g\0\0\0h\0\0\0i", 3*4, one); + check_str (y, "\0\0\0n\0\0\0o\0\0\0p", 3*4, two); + check_str (z, "\0\0\0a\0\0\0b\0\0\0c", 3*4, zero); + check_str (z, "\0\0\0g\0\0\0h\0\0\0i", 3*4, one); + check_str (z, "\0\0\0n\0\0\0o\0\0\0p", 3*4, two); +#endif + } + else if (intent_in && num == 1) + { +#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ + if (memcmp ((const char*) x->base_addr, "a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p\0\0\0", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) y->base_addr, "a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p\0\0\0", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) z->base_addr, "a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p\0\0\0", 9*4) != 0) + __builtin_abort (); +#else + if (memcmp ((const char*) x->base_addr, "\0\0\0a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) y->base_addr, "\0\0\0a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) z->base_addr, "\0\0\0a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p", 9*4) != 0) + __builtin_abort (); +#endif + } + else if (intent_in && num == 2) + { +#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ + if (memcmp ((const char*) x->base_addr, "d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m\0\0\0", 9) != 0) + __builtin_abort (); + if (memcmp ((const char*) y->base_addr, "d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m\0\0\0", 9) != 0) + __builtin_abort (); + if (memcmp ((const char*) z->base_addr, "d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m\0\0\0", 9) != 0) + __builtin_abort (); +#else + if (memcmp ((const char*) x->base_addr, "\0\0\0d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m", 9) != 0) + __builtin_abort (); + if (memcmp ((const char*) y->base_addr, "\0\0\0d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m", 9) != 0) + __builtin_abort (); + if (memcmp ((const char*) z->base_addr, "\0\0\0d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m", 9) != 0) + __builtin_abort (); +#endif + } + else if (intent_in) + __builtin_abort (); + if (intent_in) + { + if (is_cont && num == 1) + { + /* Copy in - set the value to check that no copy out is done. */ +#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ + memcpy ((char*) x->base_addr, "1\0\0\0""2\0\0\0""3\0\0\0""4\0\0\0""5\0\0\0""6\0\0\0""7\0\0\0""8\0\0\0""9\0\0\0", 9*4); + memcpy ((char*) y->base_addr, "1\0\0\0""2\0\0\0""3\0\0\0""4\0\0\0""5\0\0\0""6\0\0\0""7\0\0\0""8\0\0\0""9\0\0\0", 9*4); + memcpy ((char*) z->base_addr, "1\0\0\0""2\0\0\0""3\0\0\0""4\0\0\0""5\0\0\0""6\0\0\0""7\0\0\0""8\0\0\0""9\0\0\0", 9*4); +#else + memcpy ((char*) x->base_addr, "\0\0\0""1\0\0\0""2\0\0\0""3\0\0\0""4\0\0\0""5\0\0\0""6\0\0\0""7\0\0\0""8\0\0\0""9", 9*4); + memcpy ((char*) y->base_addr, "\0\0\0""1\0\0\0""2\0\0\0""3\0\0\0""4\0\0\0""5\0\0\0""6\0\0\0""7\0\0\0""8\0\0\0""9", 9*4); + memcpy ((char*) z->base_addr, "\0\0\0""1\0\0\0""2\0\0\0""3\0\0\0""4\0\0\0""5\0\0\0""6\0\0\0""7\0\0\0""8\0\0\0""9", 9*4); +#endif + } + return addr1; + } + // !intent_in + if (!is_cont && num == 1) + { +#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ + check_str (x, "A\0\0\0B\0\0\0C\0\0\0", 3*4, zero); + check_str (x, "D\0\0\0E\0\0\0F\0\0\0", 3*4, one); + check_str (x, "G\0\0\0H\0\0\0I\0\0\0", 3*4, two); + check_str (y, "A\0\0\0B\0\0\0C\0\0\0", 3*4, zero); + check_str (y, "D\0\0\0E\0\0\0F\0\0\0", 3*4, one); + check_str (y, "G\0\0\0H\0\0\0I\0\0\0", 3*4, two); + check_str (z, "A\0\0\0B\0\0\0C\0\0\0", 3*4, zero); + check_str (z, "D\0\0\0E\0\0\0F\0\0\0", 3*4, one); + check_str (z, "G\0\0\0H\0\0\0I\0\0\0", 3*4, two); +#else + check_str (x, "\0\0\0A\0\0\0B\0\0\0C", 3*4, zero); + check_str (x, "\0\0\0D\0\0\0E\0\0\0F", 3*4, one); + check_str (x, "\0\0\0G\0\0\0H\0\0\0I", 3*4, two); + check_str (y, "\0\0\0A\0\0\0B\0\0\0C", 3*4, zero); + check_str (y, "\0\0\0D\0\0\0E\0\0\0F", 3*4, one); + check_str (y, "\0\0\0G\0\0\0H\0\0\0I", 3*4, two); + check_str (z, "\0\0\0A\0\0\0B\0\0\0C", 3*4, zero); + check_str (z, "\0\0\0D\0\0\0E\0\0\0F", 3*4, one); + check_str (z, "\0\0\0G\0\0\0H\0\0\0I", 3*4, two); +#endif + } + else + { +#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ + if (memcmp ((const char*) x->base_addr, "A\0\0\0B\0\0\0C\0\0\0D\0\0\0E\0\0\0F\0\0\0G\0\0\0H\0\0\0I\0\0\0", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) y->base_addr, "A\0\0\0B\0\0\0C\0\0\0D\0\0\0E\0\0\0F\0\0\0G\0\0\0H\0\0\0I\0\0\0", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) z->base_addr, "A\0\0\0B\0\0\0C\0\0\0D\0\0\0E\0\0\0F\0\0\0G\0\0\0H\0\0\0I\0\0\0", 9*4) != 0) + __builtin_abort (); +#else + if (memcmp ((const char*) x->base_addr, "\0\0\0A\0\0\0B\0\0\0C\0\0\0D\0\0\0E\0\0\0F\0\0\0G\0\0\0H\0\0\0I", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) y->base_addr, "\0\0\0A\0\0\0B\0\0\0C\0\0\0D\0\0\0E\0\0\0F\0\0\0G\0\0\0H\0\0\0I", 9*4) != 0) + __builtin_abort (); + if (memcmp ((const char*) z->base_addr, "\0\0\0A\0\0\0B\0\0\0C\0\0\0D\0\0\0E\0\0\0F\0\0\0G\0\0\0H\0\0\0I", 9*4) != 0) + __builtin_abort (); +#endif + } + return addr1; +} + +struct loc_t +char_assumed_size_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_assumed_size_f, true, false); +} + +struct loc_t +char_assumed_size_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_size_in_f, true, false); +} + +struct loc_t +char_expl_size_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_expl_size_f, true, false); +} + +struct loc_t +char_expl_size_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_expl_size_in_f, true, false); +} + +struct loc_t +char_assumed_rank_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_assumed_rank_f, false, false); +} + +struct loc_t +char_assumed_rank_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_rank_in_f, false, false); +} + +struct loc_t +char_assumed_rank_cont_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_assumed_rank_cont_f, true, false); +} + +struct loc_t +char_assumed_rank_cont_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_rank_cont_in_f, true, false); +} + +static void +reset_var (CFI_cdesc_t *x, int num) +{ + const CFI_index_t zero[1] = { 0 }; + const CFI_index_t one[1] = { 1 }; + const CFI_index_t two[1] = { 2 }; + + if (num == 1) + { +#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ + set_str (x, "a\0\0\0b\0\0\0c\0\0\0", 3*4, zero); + set_str (x, "g\0\0\0h\0\0\0i\0\0\0", 3*4, one); + set_str (x, "n\0\0\0o\0\0\0p\0\0\0", 3*4, two); +#else + set_str (x, "\0\0\0a\0\0\0b\0\0\0c", 3*4, zero); + set_str (x, "\0\0\0g\0\0\0h\0\0\0i", 3*4, one); + set_str (x, "\0\0\0n\0\0\0o\0\0\0p", 3*4, two); +#endif + } + else if (num == 2) + { +#if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ + set_str (x, "d\0\0\0e\0\0\0f\0\0\0", 3*4, zero); + set_str (x, "g\0\0\0h\0\0\0i\0\0\0", 3*4, one); + set_str (x, "j\0\0\0l\0\0\0m\0\0\0", 3*4, two); +#else + set_str (x, "\0\0\0d\0\0\0e\0\0\0f", 3*4, zero); + set_str (x, "\0\0\0g\0\0\0h\0\0\0i", 3*4, one); + set_str (x, "\0\0\0j\0\0\0l\0\0\0m", 3*4, two); +#endif + } + else + __builtin_abort (); +} + +static void +reset_vars (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, int num) +{ + reset_var (x, num); + reset_var (y, num); + reset_var (z, num); +} + +struct loc_t +char_assumed_shape_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + /* Make use of having a noncontiguous argument to check that the callee + handles noncontiguous variables. */ + do_call (x, y, z, k, num, false, char_assumed_size_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, true, char_assumed_size_in_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, false, char_expl_size_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, true, char_expl_size_in_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, false, char_assumed_rank_cont_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, true, char_assumed_rank_cont_in_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, false, char_assumed_shape_cont_f, false, true); + reset_vars (x, y, z, num); + do_call (x, y, z, k, num, true, char_assumed_shape_cont_in_f, false, true); + /* Actual func call. */ + reset_vars (x, y, z, num); + return do_call (x, y, z, k, num, false, char_assumed_shape_f, false, false); +} + +struct loc_t +char_assumed_shape_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_shape_in_f, false, false); +} + +struct loc_t +char_assumed_shape_cont_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, false, char_assumed_shape_cont_f, true, false); +} + +struct loc_t +char_assumed_shape_cont_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, + int k, int num) +{ + return do_call (x, y, z, k, num, true, char_assumed_shape_cont_in_f, true, false); +} diff --git a/Fortran/gfortran/regression/bind-c-contiguous-5.f90 b/Fortran/gfortran/regression/bind-c-contiguous-5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind-c-contiguous-5.f90 @@ -0,0 +1,1574 @@ +! { dg-do run } +! { dg-additional-sources bind-c-contiguous-5.c } +! { dg-additional-options "-fcheck=all" } +! { dg-additional-options -Wno-complain-wrong-lang } +! ---- Same as bind-c-contiguous-1.f90 - but with kind=4 characters +! Fortran demands that with bind(C), the callee ensure that for +! * 'contiguous' +! * len=* with explicit/assumed-size arrays +! noncontiguous actual arguments are handled. +! (in without bind(C) in gfortran, caller handles the copy in/out + +! Additionally, for a bind(C) callee, a Fortran-written caller +! has to ensure the same (for contiguous + len=* to explicit-/assumed-size arrays) + +module m + use iso_c_binding, only: c_intptr_t, c_bool, c_loc, c_int + implicit none (type, external) + + type, bind(C) :: loc_t + integer(c_intptr_t) :: x, y, z + end type loc_t + +interface + type(loc_t) function char_assumed_size_c (xx, yy, zz, n, num) bind(C) + import :: loc_t, c_bool, c_int + integer(c_int), value :: n, num + character(kind=4, len=*) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*) + end function + + type(loc_t) function char_assumed_size_in_c (xx, yy, zz, n, num) bind(C) + import :: loc_t, c_bool, c_int + integer(c_int), value :: n, num + character(kind=4, len=*), intent(in) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*) + end function + + type(loc_t) function char_expl_size_c (xx, yy, zz, n, num) bind(c) + import :: loc_t, c_bool, c_int + integer(c_int), value :: n, num + character(kind=4, len=*) :: xx(n), yy(n:n+3), zz(6:6, 3:n, 3:n+3) + end function + + type(loc_t) function char_expl_size_in_c (xx, yy, zz, n, num) bind(c) + import :: loc_t, c_bool, c_int + integer(c_int), value :: n, num + character(kind=4, len=*), intent(in) :: xx(n), yy(n:n+3), zz(6:6, 3:n, 3:n+3) + end function + + type(loc_t) function char_assumed_rank_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(kind=4, len=*) :: xx(..) + character(kind=4, len=3) :: yy(..) + character(kind=4, len=k) :: zz(..) + end function + + type(loc_t) function char_assumed_rank_in_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(kind=4, len=*), intent(in) :: xx(..) + character(kind=4, len=3), intent(in) :: yy(..) + character(kind=4, len=k), intent(in) :: zz(..) + end function + + type(loc_t) function char_assumed_rank_cont_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(kind=4, len=*), contiguous :: xx(..) + character(kind=4, len=3), contiguous :: yy(..) + character(kind=4, len=k), contiguous :: zz(..) + end function + + type(loc_t) function char_assumed_rank_cont_in_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(kind=4, len=*), contiguous, intent(in) :: xx(..) + character(kind=4, len=3), contiguous, intent(in) :: yy(..) + character(kind=4, len=k), contiguous, intent(in) :: zz(..) + end function + + type(loc_t) function char_assumed_shape_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(kind=4, len=*) :: xx(:) + character(kind=4, len=3) :: yy(5:) + character(kind=4, len=k) :: zz(-k:) + end function + + type(loc_t) function char_assumed_shape_in_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(kind=4, len=*), intent(in) :: xx(:) + character(kind=4, len=3), intent(in) :: yy(5:) + character(kind=4, len=k), intent(in) :: zz(-k:) + end function + + type(loc_t) function char_assumed_shape_cont_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(kind=4, len=*), contiguous :: xx(:) + character(kind=4, len=3), contiguous :: yy(5:) + character(kind=4, len=k), contiguous :: zz(-k:) + end function + + type(loc_t) function char_assumed_shape_cont_in_c (xx, yy, zz, k, num) bind(c) + import :: loc_t, c_bool, c_int + integer, value :: k, num + character(kind=4, len=*), contiguous, intent(in) :: xx(:) + character(kind=4, len=3), contiguous, intent(in) :: yy(5:) + character(kind=4, len=k), contiguous, intent(in) :: zz(-k:) + end function +end interface + +contains + +type(loc_t) function char_assumed_size_f (xx, yy, zz, n, num) bind(c) result(res) + integer, value :: num, n + character(kind=4, len=*) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*) + print *, xx(1:3) + if (3 /= len(xx)) error stop 1 + if (3 /= len(yy)) error stop 1 + if (3 /= len(zz)) error stop 1 + if (1 /= lbound(xx,dim=1)) error stop 1 + if (3 /= lbound(yy,dim=1)) error stop 1 + if (6 /= lbound(zz,dim=1)) error stop 1 + if (3 /= lbound(zz,dim=2)) error stop 1 + if (3 /= lbound(zz,dim=3)) error stop 1 + if (1 /= size(zz,dim=1)) error stop 1 + if (1 /= size(zz,dim=2)) error stop 1 + if (6 /= ubound(zz,dim=1)) error stop 1 + if (3 /= ubound(zz,dim=2)) error stop 1 + if (num == 1) then + if (xx(1) /= 4_"abc") error stop 2 + if (xx(2) /= 4_"ghi") error stop 3 + if (xx(3) /= 4_"nop") error stop 4 + if (yy(3) /= 4_"abc") error stop 2 + if (yy(4) /= 4_"ghi") error stop 3 + if (yy(5) /= 4_"nop") error stop 4 + if (zz(6,n,3) /= 4_"abc") error stop 2 + if (zz(6,n,4) /= 4_"ghi") error stop 3 + if (zz(6,n,5) /= 4_"nop") error stop 4 + else if (num == 2) then + if (xx(1) /= 4_"def") error stop 2 + if (xx(2) /= 4_"ghi") error stop 3 + if (xx(3) /= 4_"jlm") error stop 4 + if (yy(3) /= 4_"def") error stop 2 + if (yy(4) /= 4_"ghi") error stop 3 + if (yy(5) /= 4_"jlm") error stop 4 + if (zz(6,n,3) /= 4_"def") error stop 2 + if (zz(6,n,4) /= 4_"ghi") error stop 3 + if (zz(6,n,5) /= 4_"jlm") error stop 4 + else + error stop 8 + endif + xx(1) = 4_"ABC" + xx(2) = 4_"DEF" + xx(3) = 4_"GHI" + yy(3) = 4_"ABC" + yy(4) = 4_"DEF" + yy(5) = 4_"GHI" + zz(6,n,3) = 4_"ABC" + zz(6,n,4) = 4_"DEF" + zz(6,n,5) = 4_"GHI" + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + +type(loc_t) function char_assumed_size_in_f (xx, yy, zz, n, num) bind(c) result(res) + integer, value :: num, n + character(kind=4, len=*) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*) + intent(in) :: xx, yy, zz + print *, xx(1:3) + if (3 /= len(xx)) error stop 1 + if (3 /= len(yy)) error stop 1 + if (3 /= len(zz)) error stop 1 + if (1 /= lbound(xx,dim=1)) error stop 1 + if (3 /= lbound(yy,dim=1)) error stop 1 + if (6 /= lbound(zz,dim=1)) error stop 1 + if (3 /= lbound(zz,dim=2)) error stop 1 + if (3 /= lbound(zz,dim=3)) error stop 1 + if (1 /= size(zz,dim=1)) error stop 1 + if (1 /= size(zz,dim=2)) error stop 1 + if (6 /= ubound(zz,dim=1)) error stop 1 + if (3 /= ubound(zz,dim=2)) error stop 1 + if (num == 1) then + if (xx(1) /= 4_"abc") error stop 2 + if (xx(2) /= 4_"ghi") error stop 3 + if (xx(3) /= 4_"nop") error stop 4 + if (yy(3) /= 4_"abc") error stop 2 + if (yy(4) /= 4_"ghi") error stop 3 + if (yy(5) /= 4_"nop") error stop 4 + if (zz(6,n,3) /= 4_"abc") error stop 2 + if (zz(6,n,4) /= 4_"ghi") error stop 3 + if (zz(6,n,5) /= 4_"nop") error stop 4 + else if (num == 2) then + if (xx(1) /= 4_"def") error stop 2 + if (xx(2) /= 4_"ghi") error stop 3 + if (xx(3) /= 4_"jlm") error stop 4 + if (yy(3) /= 4_"def") error stop 2 + if (yy(4) /= 4_"ghi") error stop 3 + if (yy(5) /= 4_"jlm") error stop 4 + if (zz(6,n,3) /= 4_"def") error stop 2 + if (zz(6,n,4) /= 4_"ghi") error stop 3 + if (zz(6,n,5) /= 4_"jlm") error stop 4 + else + error stop 8 + endif + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } if (num == 1) then +end + +type(loc_t) function char_expl_size_f (xx, yy, zz, n, num) bind(c) result(res) + integer, value :: num, n + character(kind=4, len=*) :: xx(n), yy(n:n+2), zz(6:6, 3:n, 3:n+2) + print *, xx(1:3) + if (3 /= len(xx)) error stop 1 + if (3 /= len(yy)) error stop 1 + if (3 /= len(zz)) error stop 1 + if (1 /= lbound(xx,dim=1)) error stop 1 + if (3 /= lbound(yy,dim=1)) error stop 1 + if (6 /= lbound(zz,dim=1)) error stop 1 + if (3 /= lbound(zz,dim=2)) error stop 1 + if (3 /= lbound(zz,dim=3)) error stop 1 + if (3 /= size(xx,dim=1)) error stop 1 + if (3 /= size(yy,dim=1)) error stop 1 + if (1 /= size(zz,dim=1)) error stop 1 + if (1 /= size(zz,dim=2)) error stop 1 + if (3 /= size(zz,dim=3)) error stop 1 + if (3 /= ubound(xx,dim=1)) error stop 1 + if (5 /= ubound(yy,dim=1)) error stop 1 + if (6 /= ubound(zz,dim=1)) error stop 1 + if (3 /= ubound(zz,dim=2)) error stop 1 + if (5 /= ubound(zz,dim=3)) error stop 1 + if (num == 1) then + if (xx(1) /= 4_"abc") error stop 2 + if (xx(2) /= 4_"ghi") error stop 3 + if (xx(3) /= 4_"nop") error stop 4 + if (yy(3) /= 4_"abc") error stop 2 + if (yy(4) /= 4_"ghi") error stop 3 + if (yy(5) /= 4_"nop") error stop 4 + if (zz(6,n,3) /= 4_"abc") error stop 2 + if (zz(6,n,4) /= 4_"ghi") error stop 3 + if (zz(6,n,5) /= 4_"nop") error stop 4 + else if (num == 2) then + if (xx(1) /= 4_"def") error stop 2 + if (xx(2) /= 4_"ghi") error stop 3 + if (xx(3) /= 4_"jlm") error stop 4 + if (yy(3) /= 4_"def") error stop 2 + if (yy(4) /= 4_"ghi") error stop 3 + if (yy(5) /= 4_"jlm") error stop 4 + if (zz(6,n,3) /= 4_"def") error stop 2 + if (zz(6,n,4) /= 4_"ghi") error stop 3 + if (zz(6,n,5) /= 4_"jlm") error stop 4 + else + error stop 8 + endif + xx(1) = 4_"ABC" + xx(2) = 4_"DEF" + xx(3) = 4_"GHI" + yy(3) = 4_"ABC" + yy(4) = 4_"DEF" + yy(5) = 4_"GHI" + zz(6,n,3) = 4_"ABC" + zz(6,n,4) = 4_"DEF" + zz(6,n,5) = 4_"GHI" + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + +type(loc_t) function char_expl_size_in_f (xx, yy, zz, n, num) bind(c) result(res) + integer, value :: num, n + character(kind=4, len=*) :: xx(n), yy(n:n+2), zz(6:6, 3:n, 3:n+2) + intent(in) :: xx, yy, zz + print *, xx(1:3) + if (3 /= len(xx)) error stop 1 + if (3 /= len(yy)) error stop 1 + if (3 /= len(zz)) error stop 1 + if (1 /= lbound(xx,dim=1)) error stop 1 + if (3 /= lbound(yy,dim=1)) error stop 1 + if (6 /= lbound(zz,dim=1)) error stop 1 + if (3 /= lbound(zz,dim=2)) error stop 1 + if (3 /= lbound(zz,dim=3)) error stop 1 + if (3 /= size(xx,dim=1)) error stop 1 + if (3 /= size(yy,dim=1)) error stop 1 + if (1 /= size(zz,dim=1)) error stop 1 + if (1 /= size(zz,dim=2)) error stop 1 + if (3 /= size(zz,dim=3)) error stop 1 + if (3 /= ubound(xx,dim=1)) error stop 1 + if (5 /= ubound(yy,dim=1)) error stop 1 + if (6 /= ubound(zz,dim=1)) error stop 1 + if (3 /= ubound(zz,dim=2)) error stop 1 + if (5 /= ubound(zz,dim=3)) error stop 1 + if (num == 1) then + if (xx(1) /= 4_"abc") error stop 2 + if (xx(2) /= 4_"ghi") error stop 3 + if (xx(3) /= 4_"nop") error stop 4 + if (yy(3) /= 4_"abc") error stop 2 + if (yy(4) /= 4_"ghi") error stop 3 + if (yy(5) /= 4_"nop") error stop 4 + if (zz(6,n,3) /= 4_"abc") error stop 2 + if (zz(6,n,4) /= 4_"ghi") error stop 3 + if (zz(6,n,5) /= 4_"nop") error stop 4 + else if (num == 2) then + if (xx(1) /= 4_"def") error stop 2 + if (xx(2) /= 4_"ghi") error stop 3 + if (xx(3) /= 4_"jlm") error stop 4 + if (yy(3) /= 4_"def") error stop 2 + if (yy(4) /= 4_"ghi") error stop 3 + if (yy(5) /= 4_"jlm") error stop 4 + if (zz(6,n,3) /= 4_"def") error stop 2 + if (zz(6,n,4) /= 4_"ghi") error stop 3 + if (zz(6,n,5) /= 4_"jlm") error stop 4 + else + error stop 8 + endif + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + + +type(loc_t) function char_assumed_rank_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(kind=4, len=*) :: xx(..) + character(kind=4, len=3) :: yy(..) + character(kind=4, len=k) :: zz(..) + if (3 /= len(xx)) error stop 40 + if (3 /= len(yy)) error stop 40 + if (3 /= len(zz)) error stop 40 + if (3 /= size(xx)) error stop 41 + if (3 /= size(yy)) error stop 41 + if (3 /= size(zz)) error stop 41 + if (1 /= rank(xx)) error stop 49 + if (1 /= rank(yy)) error stop 49 + if (1 /= rank(zz)) error stop 49 + if (1 /= lbound(xx, dim=1)) stop 49 + if (1 /= lbound(yy, dim=1)) stop 49 + if (1 /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (3 /= ubound(yy, dim=1)) stop 49 + if (3 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (is_contiguous (xx)) error stop 49 + if (is_contiguous (yy)) error stop 49 + if (is_contiguous (zz)) error stop 49 + else if (num == 2) then + if (.not. is_contiguous (xx)) error stop 49 + if (.not. is_contiguous (yy)) error stop 49 + if (.not. is_contiguous (zz)) error stop 49 + else + error stop 48 + end if + select rank (xx) + rank (1) + print *, xx(1:3) + if (num == 1) then + if (xx(1) /= 4_"abc") error stop 42 + if (xx(2) /= 4_"ghi") error stop 43 + if (xx(3) /= 4_"nop") error stop 44 + else if (num == 2) then + if (xx(1) /= 4_"def") error stop 45 + if (xx(2) /= 4_"ghi") error stop 46 + if (xx(3) /= 4_"jlm") error stop 47 + else + error stop 48 + endif + xx(1) = 4_"ABC" + xx(2) = 4_"DEF" + xx(3) = 4_"GHI" + res%x = get_loc (xx) + rank default + error stop 99 + end select + select rank (yy) + rank (1) + print *, yy(1:3) + if (num == 1) then + if (yy(1) /= 4_"abc") error stop 42 + if (yy(2) /= 4_"ghi") error stop 43 + if (yy(3) /= 4_"nop") error stop 44 + else if (num == 2) then + if (yy(1) /= 4_"def") error stop 45 + if (yy(2) /= 4_"ghi") error stop 46 + if (yy(3) /= 4_"jlm") error stop 47 + else + error stop 48 + endif + yy(1) = 4_"ABC" + yy(2) = 4_"DEF" + yy(3) = 4_"GHI" + res%y = get_loc (yy) + rank default + error stop 99 + end select + select rank (zz) + rank (1) + print *, zz(1:3) + if (num == 1) then + if (zz(1) /= 4_"abc") error stop 42 + if (zz(2) /= 4_"ghi") error stop 43 + if (zz(3) /= 4_"nop") error stop 44 + else if (num == 2) then + if (zz(1) /= 4_"def") error stop 45 + if (zz(2) /= 4_"ghi") error stop 46 + if (zz(3) /= 4_"jlm") error stop 47 + else + error stop 48 + endif + zz(1) = 4_"ABC" + zz(2) = 4_"DEF" + zz(3) = 4_"GHI" + res%z = get_loc (zz) + rank default + error stop 99 + end select +contains + integer (c_intptr_t) function get_loc (arg) + character(kind=4, len=*), target :: arg(:) + ! %loc does copy in/out if not simply contiguous + ! extra func needed because of 'target' attribute + get_loc = transfer (c_loc(arg), res%x) + end +end + +type(loc_t) function char_assumed_rank_in_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(kind=4, len=*) :: xx(..) + character(kind=4, len=3) :: yy(..) + character(kind=4, len=k) :: zz(..) + intent(in) :: xx, yy, zz + if (3 /= size(yy)) error stop 50 + if (3 /= len(yy)) error stop 51 + if (1 /= rank(yy)) error stop 59 + if (1 /= lbound(xx, dim=1)) stop 49 + if (1 /= lbound(yy, dim=1)) stop 49 + if (1 /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (3 /= ubound(yy, dim=1)) stop 49 + if (3 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (is_contiguous (xx)) error stop 59 + if (is_contiguous (yy)) error stop 59 + if (is_contiguous (zz)) error stop 59 + else if (num == 2) then + if (.not. is_contiguous (xx)) error stop 59 + if (.not. is_contiguous (yy)) error stop 59 + if (.not. is_contiguous (zz)) error stop 59 + else + error stop 48 + end if + select rank (xx) + rank (1) + print *, xx(1:3) + if (num == 1) then + if (xx(1) /= 4_"abc") error stop 52 + if (xx(2) /= 4_"ghi") error stop 53 + if (xx(3) /= 4_"nop") error stop 54 + else if (num == 2) then + if (xx(1) /= 4_"def") error stop 55 + if (xx(2) /= 4_"ghi") error stop 56 + if (xx(3) /= 4_"jlm") error stop 57 + else + error stop 58 + endif + res%x = get_loc(xx) + rank default + error stop 99 + end select + select rank (yy) + rank (1) + print *, yy(1:3) + if (num == 1) then + if (yy(1) /= 4_"abc") error stop 52 + if (yy(2) /= 4_"ghi") error stop 53 + if (yy(3) /= 4_"nop") error stop 54 + else if (num == 2) then + if (yy(1) /= 4_"def") error stop 55 + if (yy(2) /= 4_"ghi") error stop 56 + if (yy(3) /= 4_"jlm") error stop 57 + else + error stop 58 + endif + res%y = get_loc(yy) + rank default + error stop 99 + end select + select rank (zz) + rank (1) + print *, zz(1:3) + if (num == 1) then + if (zz(1) /= 4_"abc") error stop 52 + if (zz(2) /= 4_"ghi") error stop 53 + if (zz(3) /= 4_"nop") error stop 54 + else if (num == 2) then + if (zz(1) /= 4_"def") error stop 55 + if (zz(2) /= 4_"ghi") error stop 56 + if (zz(3) /= 4_"jlm") error stop 57 + else + error stop 58 + endif + res%z = get_loc(zz) + rank default + error stop 99 + end select +contains + integer (c_intptr_t) function get_loc (arg) + character(kind=4, len=*), target :: arg(:) + ! %loc does copy in/out if not simply contiguous + ! extra func needed because of 'target' attribute + get_loc = transfer (c_loc(arg), res%x) + end +end + + + +type(loc_t) function char_assumed_rank_cont_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(kind=4, len=*) :: xx(..) + character(kind=4, len=3) :: yy(..) + character(kind=4, len=k) :: zz(..) + contiguous :: xx, yy, zz + if (3 /= len(xx)) error stop 60 + if (3 /= len(yy)) error stop 60 + if (3 /= len(zz)) error stop 60 + if (3 /= size(xx)) error stop 61 + if (3 /= size(yy)) error stop 61 + if (3 /= size(zz)) error stop 61 + if (1 /= rank(xx)) error stop 69 + if (1 /= rank(yy)) error stop 69 + if (1 /= rank(zz)) error stop 69 + if (1 /= lbound(xx, dim=1)) stop 49 + if (1 /= lbound(yy, dim=1)) stop 49 + if (1 /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (3 /= ubound(yy, dim=1)) stop 49 + if (3 /= ubound(zz, dim=1)) stop 49 + select rank (xx) + rank (1) + print *, xx(1:3) + if (num == 1) then + if (xx(1) /= 4_"abc") error stop 62 + if (xx(2) /= 4_"ghi") error stop 63 + if (xx(3) /= 4_"nop") error stop 64 + else if (num == 2) then + if (xx(1) /= 4_"def") error stop 65 + if (xx(2) /= 4_"ghi") error stop 66 + if (xx(3) /= 4_"jlm") error stop 67 + else + error stop 68 + endif + xx(1) = 4_"ABC" + xx(2) = 4_"DEF" + xx(3) = 4_"GHI" + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select + select rank (yy) + rank (1) + print *, yy(1:3) + if (num == 1) then + if (yy(1) /= 4_"abc") error stop 62 + if (yy(2) /= 4_"ghi") error stop 63 + if (yy(3) /= 4_"nop") error stop 64 + else if (num == 2) then + if (yy(1) /= 4_"def") error stop 65 + if (yy(2) /= 4_"ghi") error stop 66 + if (yy(3) /= 4_"jlm") error stop 67 + else + error stop 68 + endif + yy(1) = 4_"ABC" + yy(2) = 4_"DEF" + yy(3) = 4_"GHI" + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select + select rank (zz) + rank (1) + print *, zz(1:3) + if (num == 1) then + if (zz(1) /= 4_"abc") error stop 62 + if (zz(2) /= 4_"ghi") error stop 63 + if (zz(3) /= 4_"nop") error stop 64 + else if (num == 2) then + if (zz(1) /= 4_"def") error stop 65 + if (zz(2) /= 4_"ghi") error stop 66 + if (zz(3) /= 4_"jlm") error stop 67 + else + error stop 68 + endif + zz(1) = 4_"ABC" + zz(2) = 4_"DEF" + zz(3) = 4_"GHI" + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select +end + +type(loc_t) function char_assumed_rank_cont_in_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(kind=4, len=*) :: xx(..) + character(kind=4, len=3) :: yy(..) + character(kind=4, len=k) :: zz(..) + intent(in) :: xx, yy, zz + contiguous :: xx, yy, zz + if (3 /= size(xx)) error stop 30 + if (3 /= size(yy)) error stop 30 + if (3 /= size(zz)) error stop 30 + if (3 /= len(xx)) error stop 31 + if (3 /= len(yy)) error stop 31 + if (3 /= len(zz)) error stop 31 + if (1 /= rank(xx)) error stop 69 + if (1 /= rank(yy)) error stop 69 + if (1 /= rank(zz)) error stop 69 + if (1 /= lbound(xx, dim=1)) stop 49 + if (1 /= lbound(yy, dim=1)) stop 49 + if (1 /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (3 /= ubound(yy, dim=1)) stop 49 + if (3 /= ubound(zz, dim=1)) stop 49 + select rank (xx) + rank (1) + print *, xx(1:3) + if (num == 1) then + if (xx(1) /= 4_"abc") error stop 62 + if (xx(2) /= 4_"ghi") error stop 63 + if (xx(3) /= 4_"nop") error stop 64 + else if (num == 2) then + if (xx(1) /= 4_"def") error stop 65 + if (xx(2) /= 4_"ghi") error stop 66 + if (xx(3) /= 4_"jlm") error stop 67 + else + error stop 68 + endif + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select + select rank (yy) + rank (1) + print *, yy(1:3) + if (num == 1) then + if (yy(1) /= 4_"abc") error stop 62 + if (yy(2) /= 4_"ghi") error stop 63 + if (yy(3) /= 4_"nop") error stop 64 + else if (num == 2) then + if (yy(1) /= 4_"def") error stop 65 + if (yy(2) /= 4_"ghi") error stop 66 + if (yy(3) /= 4_"jlm") error stop 67 + else + error stop 68 + endif + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select + select rank (zz) + rank (1) + print *, zz(1:3) + if (num == 1) then + if (zz(1) /= 4_"abc") error stop 62 + if (zz(2) /= 4_"ghi") error stop 63 + if (zz(3) /= 4_"nop") error stop 64 + else if (num == 2) then + if (zz(1) /= 4_"def") error stop 65 + if (zz(2) /= 4_"ghi") error stop 66 + if (zz(3) /= 4_"jlm") error stop 67 + else + error stop 68 + endif + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } + rank default + error stop 99 + end select +end + +type(loc_t) function char_assumed_shape_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(kind=4, len=*) :: xx(:) + character(kind=4, len=3) :: yy(5:) + character(kind=4, len=k) :: zz(-k:) + print *, xx(1:3) + if (3 /= len(xx)) error stop 70 + if (3 /= len(yy)) error stop 70 + if (3 /= len(zz)) error stop 70 + if (3 /= size(xx)) error stop 71 + if (3 /= size(yy)) error stop 71 + if (3 /= size(zz)) error stop 71 + if (1 /= lbound(xx, dim=1)) stop 49 + if (5 /= lbound(yy, dim=1)) stop 49 + if (-k /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (7 /= ubound(yy, dim=1)) stop 49 + if (-k+2 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (is_contiguous (xx)) error stop 79 + if (is_contiguous (yy)) error stop 79 + if (is_contiguous (zz)) error stop 79 + if (xx(1) /= 4_"abc") error stop 72 + if (xx(2) /= 4_"ghi") error stop 73 + if (xx(3) /= 4_"nop") error stop 74 + if (yy(5) /= 4_"abc") error stop 72 + if (yy(6) /= 4_"ghi") error stop 73 + if (yy(7) /= 4_"nop") error stop 74 + if (zz(-k) /= 4_"abc") error stop 72 + if (zz(-k+1) /= 4_"ghi") error stop 73 + if (zz(-k+2) /= 4_"nop") error stop 74 + else if (num == 2) then + if (.not.is_contiguous (xx)) error stop 79 + if (.not.is_contiguous (yy)) error stop 79 + if (.not.is_contiguous (zz)) error stop 79 + if (xx(1) /= 4_"def") error stop 72 + if (xx(2) /= 4_"ghi") error stop 73 + if (xx(3) /= 4_"jlm") error stop 74 + if (yy(5) /= 4_"def") error stop 72 + if (yy(6) /= 4_"ghi") error stop 73 + if (yy(7) /= 4_"jlm") error stop 74 + if (zz(-k) /= 4_"def") error stop 72 + if (zz(-k+1) /= 4_"ghi") error stop 73 + if (zz(-k+2) /= 4_"jlm") error stop 74 + else + error stop 78 + endif + xx(1) = 4_"ABC" + xx(2) = 4_"DEF" + xx(3) = 4_"GHI" + yy(5) = 4_"ABC" + yy(6) = 4_"DEF" + yy(7) = 4_"GHI" + zz(-k) = 4_"ABC" + zz(-k+1) = 4_"DEF" + zz(-k+2) = 4_"GHI" + res%x = get_loc(xx) + res%y = get_loc(yy) + res%z = get_loc(zz) +contains + integer (c_intptr_t) function get_loc (arg) + character(kind=4, len=*), target :: arg(:) + ! %loc does copy in/out if not simply contiguous + ! extra func needed because of 'target' attribute + get_loc = transfer (c_loc(arg), res%x) + end +end + +type(loc_t) function char_assumed_shape_in_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(kind=4, len=*) :: xx(:) + character(kind=4, len=3) :: yy(5:) + character(kind=4, len=k) :: zz(-k:) + intent(in) :: xx, yy, zz + print *, xx(1:3) + if (3 /= size(xx)) error stop 80 + if (3 /= size(yy)) error stop 80 + if (3 /= size(zz)) error stop 80 + if (3 /= len(xx)) error stop 81 + if (3 /= len(yy)) error stop 81 + if (3 /= len(zz)) error stop 81 + if (1 /= lbound(xx, dim=1)) stop 49 + if (5 /= lbound(yy, dim=1)) stop 49 + if (-k /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (7 /= ubound(yy, dim=1)) stop 49 + if (-k+2 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (is_contiguous (xx)) error stop 89 + if (is_contiguous (yy)) error stop 89 + if (is_contiguous (zz)) error stop 89 + if (xx(1) /= 4_"abc") error stop 82 + if (xx(2) /= 4_"ghi") error stop 83 + if (xx(3) /= 4_"nop") error stop 84 + if (yy(5) /= 4_"abc") error stop 82 + if (yy(6) /= 4_"ghi") error stop 83 + if (yy(7) /= 4_"nop") error stop 84 + if (zz(-k) /= 4_"abc") error stop 82 + if (zz(-k+1) /= 4_"ghi") error stop 83 + if (zz(-k+2) /= 4_"nop") error stop 84 + else if (num == 2) then + if (.not.is_contiguous (xx)) error stop 89 + if (.not.is_contiguous (yy)) error stop 89 + if (.not.is_contiguous (zz)) error stop 89 + if (xx(1) /= 4_"def") error stop 85 + if (xx(2) /= 4_"ghi") error stop 86 + if (xx(3) /= 4_"jlm") error stop 87 + if (yy(5) /= 4_"def") error stop 85 + if (yy(6) /= 4_"ghi") error stop 86 + if (yy(7) /= 4_"jlm") error stop 87 + if (zz(-k) /= 4_"def") error stop 85 + if (zz(-k+1) /= 4_"ghi") error stop 86 + if (zz(-k+2) /= 4_"jlm") error stop 87 + else + error stop 88 + endif + res%x = get_loc(xx) + res%y = get_loc(yy) + res%z = get_loc(zz) +contains + integer (c_intptr_t) function get_loc (arg) + character(kind=4, len=*), target :: arg(:) + ! %loc does copy in/out if not simply contiguous + ! extra func needed because of 'target' attribute + get_loc = transfer (c_loc(arg), res%x) + end +end + + + +type(loc_t) function char_assumed_shape_cont_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(kind=4, len=*) :: xx(:) + character(kind=4, len=3) :: yy(5:) + character(kind=4, len=k) :: zz(-k:) + contiguous :: xx, yy, zz + print *, xx(1:3) + if (3 /= len(xx)) error stop 90 + if (3 /= len(yy)) error stop 90 + if (3 /= len(zz)) error stop 90 + if (3 /= size(xx)) error stop 91 + if (3 /= size(yy)) error stop 91 + if (3 /= size(zz)) error stop 91 + if (1 /= lbound(xx, dim=1)) stop 49 + if (5 /= lbound(yy, dim=1)) stop 49 + if (-k /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (7 /= ubound(yy, dim=1)) stop 49 + if (-k+2 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (xx(1) /= 4_"abc") error stop 92 + if (xx(2) /= 4_"ghi") error stop 93 + if (xx(3) /= 4_"nop") error stop 94 + if (yy(5) /= 4_"abc") error stop 92 + if (yy(6) /= 4_"ghi") error stop 93 + if (yy(7) /= 4_"nop") error stop 94 + if (zz(-k) /= 4_"abc") error stop 92 + if (zz(-k+1) /= 4_"ghi") error stop 93 + if (zz(-k+2) /= 4_"nop") error stop 94 + else if (num == 2) then + if (xx(1) /= 4_"def") error stop 92 + if (xx(2) /= 4_"ghi") error stop 93 + if (xx(3) /= 4_"jlm") error stop 94 + if (yy(5) /= 4_"def") error stop 92 + if (yy(6) /= 4_"ghi") error stop 93 + if (yy(7) /= 4_"jlm") error stop 94 + if (zz(-k) /= 4_"def") error stop 92 + if (zz(-k+1) /= 4_"ghi") error stop 93 + if (zz(-k+2) /= 4_"jlm") error stop 94 + else + error stop 98 + endif + xx(1) = 4_"ABC" + xx(2) = 4_"DEF" + xx(3) = 4_"GHI" + yy(5) = 4_"ABC" + yy(6) = 4_"DEF" + yy(7) = 4_"GHI" + zz(-k) = 4_"ABC" + zz(-k+1) = 4_"DEF" + zz(-k+2) = 4_"GHI" + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + +type(loc_t) function char_assumed_shape_cont_in_f (xx, yy, zz, k, num) bind(c) result(res) + integer, value :: num, k + character(kind=4, len=*) :: xx(:) + character(kind=4, len=3) :: yy(5:) + character(kind=4, len=k) :: zz(-k:) + intent(in) :: xx, yy, zz + contiguous :: xx, yy, zz + print *, xx(1:3) + if (3 /= size(xx)) error stop 100 + if (3 /= size(yy)) error stop 100 + if (3 /= size(zz)) error stop 100 + if (3 /= len(xx)) error stop 101 + if (3 /= len(yy)) error stop 101 + if (3 /= len(zz)) error stop 101 + if (1 /= lbound(xx, dim=1)) stop 49 + if (5 /= lbound(yy, dim=1)) stop 49 + if (-k /= lbound(zz, dim=1)) stop 49 + if (3 /= ubound(xx, dim=1)) stop 49 + if (7 /= ubound(yy, dim=1)) stop 49 + if (-k+2 /= ubound(zz, dim=1)) stop 49 + if (num == 1) then + if (xx(1) /= 4_"abc") error stop 102 + if (xx(2) /= 4_"ghi") error stop 103 + if (xx(3) /= 4_"nop") error stop 104 + if (yy(5) /= 4_"abc") error stop 102 + if (yy(6) /= 4_"ghi") error stop 103 + if (yy(7) /= 4_"nop") error stop 104 + if (zz(-k) /= 4_"abc") error stop 102 + if (zz(-k+1) /= 4_"ghi") error stop 103 + if (zz(-k+2) /= 4_"nop") error stop 104 + else if (num == 2) then + if (xx(1) /= 4_"def") error stop 105 + if (xx(2) /= 4_"ghi") error stop 106 + if (xx(3) /= 4_"jlm") error stop 107 + if (yy(5) /= 4_"def") error stop 105 + if (yy(6) /= 4_"ghi") error stop 106 + if (yy(7) /= 4_"jlm") error stop 107 + if (zz(-k) /= 4_"def") error stop 105 + if (zz(-k+1) /= 4_"ghi") error stop 106 + if (zz(-k+2) /= 4_"jlm") error stop 107 + else + error stop 108 + endif + res%x = %loc(xx) ! { dg-warning "Legacy Extension" } + res%y = %loc(yy) ! { dg-warning "Legacy Extension" } + res%z = %loc(zz) ! { dg-warning "Legacy Extension" } +end + +end module + + +use m +implicit none (type, external) +character(kind=4, len=3) :: a(6), a2(6), a3(6), a_init(6) +type(loc_t) :: loc3 + +a_init = [4_'abc', 4_'def', 4_'ghi', 4_'jlm', 4_'nop', 4_'qrs'] + +! -- Fortran: assumed size +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_f (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_in_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_in_f (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- Fortran: explicit shape +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_f (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_in_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_in_f (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- Fortran: assumed rank +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_f (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- Fortran: assumed rank contiguous +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- Fortran: assumed shape +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_f (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- Fortran: assumed shape contiguous +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + + +! --- character - call C directly -- + +! -- C: assumed size +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_c (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_in_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_size_in_c (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- C: explicit shape +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_c (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_in_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_expl_size_in_c (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- C: assumed rank +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_c (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- C: assumed rank contiguous +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_rank_cont_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- C: assumed shape +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_c (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) +if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 + +! -- C: assumed shape contiguous +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 +if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" } +if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 +if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning +if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" } +if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 56 +if (any (a2 /= a_init)) error stop 56 +if (any (a3 /= a_init)) error stop 56 + +a = a_init; a2 = a_init; a3 = a_init +loc3 = char_assumed_shape_cont_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2) +if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" } +if (any (a /= a_init)) error stop 58 +if (any (a2 /= a_init)) error stop 58 +if (any (a3 /= a_init)) error stop 58 +end + + +! { dg-output "At line 928 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_f'(\r*\n+)" }" +! { dg-output "At line 928 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_f'(\r*\n+)" }" +! { dg-output "At line 928 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_f'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 946 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_in_f'(\r*\n+)" }" +! { dg-output "At line 946 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_in_f'(\r*\n+)" }" +! { dg-output "At line 946 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_in_f'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 965 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_f'(\r*\n+)" }" +! { dg-output "At line 965 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_f'(\r*\n+)" }" +! { dg-output "At line 965 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_f'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 983 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_in_f'(\r*\n+)" }" +! { dg-output "At line 983 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_in_f'(\r*\n+)" }" +! { dg-output "At line 983 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_in_f'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1039 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_f'(\r*\n+)" }" +! { dg-output "At line 1039 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_f'(\r*\n+)" }" +! { dg-output "At line 1039 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_f'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1057 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_in_f'(\r*\n+)" }" +! { dg-output "At line 1057 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_in_f'(\r*\n+)" }" +! { dg-output "At line 1057 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_in_f'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1113 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_f'(\r*\n+)" }" +! { dg-output "At line 1113 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_f'(\r*\n+)" }" +! { dg-output "At line 1113 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_f'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1131 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_in_f'(\r*\n+)" }" +! { dg-output "At line 1131 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_in_f'(\r*\n+)" }" +! { dg-output "At line 1131 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_in_f'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1153 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_c'(\r*\n+)" }" +! { dg-output "At line 1153 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_c'(\r*\n+)" }" +! { dg-output "At line 1153 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_c'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1171 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_in_c'(\r*\n+)" }" +! { dg-output "At line 1171 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_in_c'(\r*\n+)" }" +! { dg-output "At line 1171 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_in_c'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1190 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_c'(\r*\n+)" }" +! { dg-output "At line 1190 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_c'(\r*\n+)" }" +! { dg-output "At line 1190 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_c'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1208 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_in_c'(\r*\n+)" }" +! { dg-output "At line 1208 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_in_c'(\r*\n+)" }" +! { dg-output "At line 1208 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_in_c'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1264 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_c'(\r*\n+)" }" +! { dg-output "At line 1264 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_c'(\r*\n+)" }" +! { dg-output "At line 1264 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_c'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1282 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_in_c'(\r*\n+)" }" +! { dg-output "At line 1282 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_in_c'(\r*\n+)" }" +! { dg-output "At line 1282 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_in_c'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1338 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_c'(\r*\n+)" }" +! { dg-output "At line 1338 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_c'(\r*\n+)" }" +! { dg-output "At line 1338 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_c'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" +! { dg-output "At line 1356 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_in_c'(\r*\n+)" }" +! { dg-output "At line 1356 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_in_c'(\r*\n+)" }" +! { dg-output "At line 1356 of file .*bind-c-contiguous-5.f90(\r*\n+)" }" +! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_in_c'(\r*\n+)" }" +! { dg-output " abcghinop(\r*\n+)" }" +! { dg-output " defghijlm(\r*\n+)" }" diff --git a/Fortran/gfortran/regression/bind-c-intent-out.f90 b/Fortran/gfortran/regression/bind-c-intent-out.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind-c-intent-out.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/91863 +! +! Contributed by G. Steinmetz +! + +subroutine sub(x) bind(c) + implicit none (type, external) + integer, allocatable, intent(out) :: x(:) + + allocate(x(3:5)) + x(:) = [1, 2, 3] +end subroutine sub + + +program p + implicit none (type, external) + interface + subroutine sub(x) bind(c) + integer, allocatable, intent(out) :: x(:) + end + end interface + integer, allocatable :: a(:) + + call sub(a) + if (.not.allocated(a)) stop 1 + if (any(shape(a) /= [3])) stop 2 + if (lbound(a,1) /= 3 .or. ubound(a,1) /= 5) stop 3 + print *, a(0), a(1), a(2), a(3), a(4) + print *, a + if (any(a /= [1, 2, 3])) stop 4 +end program p + +! "cfi" only appears in context of "a" -> bind-C descriptor +! the intent(out) implies freeing in the callee (!) (when implemented in Fortran), hence the "free" +! and also in the caller (when implemented in Fortran) +! It is the only 'free' as 'a' is part of the main program and, hence, implicitly has the SAVE attribute. +! The 'cfi = 0' appears before the call due to the deallocate and when preparing the C descriptor +! As cfi (i.e. the descriptor itself) is allocated in libgomp, it has to be freed after the call. + +! { dg-final { scan-tree-dump-times "__builtin_free" 2 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free \\(_x->base_addr\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_x->base_addr = 0B;" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free \\(cfi\\.\[0-9\]+\\.base_addr\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "cfi\\.\[0-9\]+\\.base_addr = 0B;" 1 "original" } } diff --git a/Fortran/gfortran/regression/bind_c_18.f90 b/Fortran/gfortran/regression/bind_c_18.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_18.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! PR fortran/37201 +! +! Before character arrays were allowed as bind(C) return value. +! +implicit none + INTERFACE + FUNCTION my() BIND(C,name="my") RESULT(r) ! { dg-error "cannot be an array" } + USE iso_c_binding + CHARACTER(kind=C_CHAR) :: r(10) + END FUNCTION + END INTERFACE + INTERFACE + FUNCTION two() BIND(C,name="two") RESULT(r) ! { dg-error "must have length 1" } + USE iso_c_binding + CHARACTER(kind=C_CHAR,len=2) :: r + END FUNCTION + END INTERFACE +END diff --git a/Fortran/gfortran/regression/bind_c_array_params.f03 b/Fortran/gfortran/regression/bind_c_array_params.f03 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_array_params.f03 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +module bind_c_array_params +use, intrinsic :: iso_c_binding +implicit none + +contains + subroutine sub0(assumed_array) bind(c) ! { dg-error "Fortran 2018: Assumed-shape array 'assumed_array' at .1. as dummy argument to the BIND.C. procedure 'sub0'" } + integer(c_int), dimension(:) :: assumed_array + end subroutine sub0 + + subroutine sub1(deferred_array) bind(c) ! { dg-error "Fortran 2018: Variable 'deferred_array' at .1. with POINTER attribute in procedure 'sub1' with BIND.C." } + integer(c_int), pointer :: deferred_array(:) + end subroutine sub1 +end module bind_c_array_params diff --git a/Fortran/gfortran/regression/bind_c_array_params_2.f90 b/Fortran/gfortran/regression/bind_c_array_params_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_array_params_2.f90 @@ -0,0 +1,53 @@ +! { dg-do compile } +! { dg-options "-std=f2008ts -fdump-tree-original" } +! { dg-additional-options "-mno-explicit-relocs" { target alpha*-*-* } } +! { dg-additional-options "-mno-relax-pic-calls" { target mips*-*-* } } +! +! Check that assumed-shape variables are correctly passed to BIND(C) +! as defined in TS 29913 +! +interface + subroutine test (xx) bind(C, name="myBindC") + type(*), dimension(:,:) :: xx + end subroutine test +end interface + +integer :: aa(4,4) +call test(aa) +end + +! { dg-final { scan-assembler-times "\[ \t\]\[$,_0-9\]*myBindC" 1 { target { ! { hppa*-*-* s390*-*-* *-*-cygwin* amdgcn*-*-* powerpc-ibm-aix* *-*-ming* } } } } } +! { dg-final { scan-assembler-times "myBindC,%r2" 1 { target { hppa*-*-* } } } } +! { dg-final { scan-assembler-times "call\tmyBindC" 1 { target { *-*-cygwin* *-*-ming* } } } } +! { dg-final { scan-assembler-times "brasl\t%r\[0-9\]*,myBindC" 1 { target { s390*-*-* } } } } +! { dg-final { scan-assembler-times "bl \.myBindC" 1 { target { powerpc-ibm-aix* } } } } +! { dg-final { scan-assembler-times "add_u32\t\[sv\]\[0-9\]*, \[sv\]\[0-9\]*, myBindC@rel32@lo" 1 { target { amdgcn*-*-* } } } } + + +! { dg-final { scan-tree-dump "parm...span = 4;" "original" } } +! { dg-final { scan-tree-dump "parm...dtype = {.elem_len=4, .rank=2, .type=1};" "original" } } +! { dg-final { scan-tree-dump "parm...dim\\\[0\\\].lbound = 1;" "original" } } +! { dg-final { scan-tree-dump "parm...dim\\\[0\\\].ubound = 4;" "original" } } +! { dg-final { scan-tree-dump "parm...dim\\\[0\\\].stride = 1;" "original" } } +! { dg-final { scan-tree-dump "parm...dim\\\[1\\\].lbound = 1;" "original" } } +! { dg-final { scan-tree-dump "parm...dim\\\[1\\\].ubound = 4;" "original" } } +! { dg-final { scan-tree-dump "parm...dim\\\[1\\\].stride = 4;" "original" } } +! { dg-final { scan-tree-dump "parm...data = \\(void \\*\\) &aa\\\[0\\\];" "original" } } +! { dg-final { scan-tree-dump "parm...offset = -5;" "original" } } +! { dg-final { scan-tree-dump "cfi...version = 1;" "original" } } +! { dg-final { scan-tree-dump "cfi...rank = 2;" "original" } } +! { dg-final { scan-tree-dump "cfi...type = 1025;" "original" } } +! { dg-final { scan-tree-dump "cfi...attribute = 2;" "original" } } +! { dg-final { scan-tree-dump "cfi...base_addr = parm.0.data;" "original" } } +! { dg-final { scan-tree-dump "cfi...elem_len = 4;" "original" } } +! { dg-final { scan-tree-dump "idx.2 = 0;" "original" } } + +! { dg-final { scan-tree-dump "if \\(idx.. <= 1\\) goto L..;" "original" } } +! { dg-final { scan-tree-dump "cfi...dim\\\[idx..\\\].lower_bound = 0;" "original" } } +! { dg-final { scan-tree-dump "cfi...dim\\\[idx..\\\].extent = \\(parm...dim\\\[idx..\\\].ubound - parm...dim\\\[idx..\\\].lbound\\) \\+ 1;" "original" } } +! { dg-final { scan-tree-dump "cfi...dim\\\[idx..\\\].sm = parm...dim\\\[idx..\\\].stride \\* parm...span;" "original" } } +! { dg-final { scan-tree-dump "idx.. = idx.. \\+ 1;" "original" } } + +! { dg-final { scan-tree-dump "test \\(&cfi..\\);" "original" } } + + diff --git a/Fortran/gfortran/regression/bind_c_array_params_3.f90 b/Fortran/gfortran/regression/bind_c_array_params_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_array_params_3.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! { dg-additional-sources bind_c_array_params_3_aux.c } +! +! PR fortran/92284 +! +! Contributed by José Rui Faustino de Sousa +! +program arr_p + use, intrinsic :: iso_c_binding, only: c_int + implicit none (type, external) + + integer(kind=c_int), pointer :: arr(:) + integer :: i + + nullify(arr) + call arr_set(arr) + + if (.not.associated(arr)) stop 1 + if (lbound(arr,dim=1) /= 1) stop 2 + if (ubound(arr,dim=1) /= 9) stop 3 + if (any (arr /= [(i, i=0,8)])) stop 4 + deallocate(arr) + +contains + + subroutine arr_set(this) !bind(c) + integer(kind=c_int), pointer, intent(out) :: this(:) + + interface + subroutine arr_set_c(this) bind(c) + use, intrinsic :: iso_c_binding, only: c_int + implicit none + integer(kind=c_int), pointer, intent(out) :: this(:) + end subroutine arr_set_c + end interface + + call arr_set_c(this) + end subroutine arr_set +end program arr_p diff --git a/Fortran/gfortran/regression/bind_c_array_params_3_aux.c b/Fortran/gfortran/regression/bind_c_array_params_3_aux.c --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_array_params_3_aux.c @@ -0,0 +1,26 @@ +/* Used by bind_c_array_params_3.f90. */ +/* PR fortran/92284. */ + +#include +#include +#include + +#include + +void arr_set_c(CFI_cdesc_t*); + +void arr_set_c(CFI_cdesc_t *arr){ + int i, stat, *auxp = NULL; + CFI_index_t lb[] = {1}; + CFI_index_t ub[] = {9}; + + assert(arr); + assert(arr->rank==1); + assert(!arr->base_addr); + stat = CFI_allocate(arr, lb, ub, sizeof(int)); + assert(stat==CFI_SUCCESS); + auxp = (int*)arr->base_addr; + assert(auxp); + for(i=0; i as dummy argument +! but not len= +! Additionally, for allocatable/pointer, len=: is required. + +! Scalar, nonallocatable/nonpointer + +subroutine val_s1(x1) bind(C) + character(len=1), value :: x1 +end + +subroutine val_s2(x2) bind(C) ! { dg-error "Character dummy argument 'x2' at .1. must be of length 1 as it has the VALUE attribute" } + character(len=2), value :: x2 +end + +subroutine s1 (x1) bind(C) + character(len=1) :: x1 +end + +subroutine s2 (x2) bind(C) ! { dg-error "Character dummy argument 'x2' at .1. must be of constant length of one or assumed length, unless it has assumed shape or assumed rank, as procedure 's2' has the BIND\\(C\\) attribute" } + character(len=2) :: x2 +end + +subroutine s3 (xn, n) bind(C) ! { dg-error "Character dummy argument 'xn' at .1. must be of constant length of one or assumed length, unless it has assumed shape or assumed rank, as procedure 's3' has the BIND\\(C\\) attribute" } + integer :: n + character(len=n) :: xn +end + +subroutine s4 (xstar) bind(C) + character(len=*) :: xstar +end + +! Assumed-shape array, nonallocatable/nonpointer + +subroutine as1 (x1) bind(C) + character(len=1) :: x1(:) +end + +subroutine as2 (x2) bind(C) + character(len=2) :: x2(:,:) +end + +subroutine as3 (xn, n) bind(C) + integer :: n + character(len=n) :: xn(:,:,:) +end + +subroutine as4 (xstar) bind(C) + character(len=*) :: xstar(:,:,:,:) +end + +! Assumed-rank array, nonallocatable/nonpointer + +subroutine ar1 (x1) bind(C) + character(len=1) :: x1(..) +end + +subroutine ar2 (x2) bind(C) + character(len=2) :: x2(..) +end + +subroutine ar3 (xn, n) bind(C) + integer :: n + character(len=n) :: xn(..) +end + +subroutine ar4 (xstar) bind(C) + character(len=*) :: xstar(..) +end + +! Assumed-size array, nonallocatable/nonpointer + +subroutine az1 (x1) bind(C) + character(len=1) :: x1(*) +end + +subroutine az2 (x2) bind(C) ! { dg-error "Character dummy argument 'x2' at .1. must be of constant length of one or assumed length, unless it has assumed shape or assumed rank, as procedure 'az2' has the BIND\\(C\\) attribute" } + character(len=2) :: x2(*) +end + +subroutine az3 (xn, n) bind(C) ! { dg-error "Character dummy argument 'xn' at .1. must be of constant length of one or assumed length, unless it has assumed shape or assumed rank, as procedure 'az3' has the BIND\\(C\\) attribute" } + integer :: n + character(len=n) :: xn(*) +end + +subroutine az4 (xstar) bind(C) + character(len=*) :: xstar(*) +end + +! Explicit-size array, nonallocatable/nonpointer + +subroutine ae1 (x1) bind(C) + character(len=1) :: x1(5) +end + +subroutine ae2 (x2) bind(C) ! { dg-error "Character dummy argument 'x2' at .1. must be of constant length of one or assumed length, unless it has assumed shape or assumed rank, as procedure 'ae2' has the BIND\\(C\\) attribute" } + character(len=2) :: x2(7) +end + +subroutine ae3 (xn, n) bind(C) ! { dg-error "Character dummy argument 'xn' at .1. must be of constant length of one or assumed length, unless it has assumed shape or assumed rank, as procedure 'ae3' has the BIND\\(C\\) attribute" } + integer :: n + character(len=n) :: xn(9) +end + +subroutine ae4 (xstar) bind(C) + character(len=*) :: xstar(3) +end + +! ALLOCATABLE +! Scalar, allocatable + +subroutine s1a (x1) bind(C) ! { dg-error "Allocatable character dummy argument 'x1' at .1. must have deferred length as procedure 's1a' is BIND\\(C\\)" } + character(len=1), allocatable :: x1 +end + +subroutine s2a (x2) bind(C) ! { dg-error "Allocatable character dummy argument 'x2' at .1. must have deferred length as procedure 's2a' is BIND\\(C\\)" } + character(len=2), allocatable :: x2 +end + +subroutine s3a (xn, n) bind(C) ! { dg-error "Allocatable character dummy argument 'xn' at .1. must have deferred length as procedure 's3a' is BIND\\(C\\)" } + integer :: n + character(len=n), allocatable :: xn +end + +subroutine s4a (xstar) bind(C) ! { dg-error "Allocatable character dummy argument 'xstar' at .1. must have deferred length as procedure 's4a' is BIND\\(C\\)" } + character(len=*), allocatable :: xstar +end + +subroutine s5a (xcolon) bind(C) + character(len=:), allocatable :: xcolon +end + +! Assumed-shape array, allocatable + +subroutine a1a (x1) bind(C) ! { dg-error "Allocatable character dummy argument 'x1' at .1. must have deferred length as procedure 'a1a' is BIND\\(C\\)" } + character(len=1), allocatable :: x1(:) +end + +subroutine a2a (x2) bind(C) ! { dg-error "Allocatable character dummy argument 'x2' at .1. must have deferred length as procedure 'a2a' is BIND\\(C\\)" } + character(len=2), allocatable :: x2(:,:) +end + +subroutine a3a (xn, n) bind(C) ! { dg-error "Allocatable character dummy argument 'xn' at .1. must have deferred length as procedure 'a3a' is BIND\\(C\\)" } + integer :: n + character(len=n), allocatable :: xn(:,:,:) +end + +subroutine a4a (xstar) bind(C) ! { dg-error "Allocatable character dummy argument 'xstar' at .1. must have deferred length as procedure 'a4a' is BIND\\(C\\)" } + character(len=*), allocatable :: xstar(:,:,:,:) +end + +subroutine a5a (xcolon) bind(C) + character(len=:), allocatable :: xcolon(:) +end + +! Assumed-rank array, allocatable + +subroutine a1ar (x1) bind(C) ! { dg-error "Allocatable character dummy argument 'x1' at .1. must have deferred length as procedure 'a1ar' is BIND\\(C\\)" } + character(len=1), allocatable :: x1(..) +end + +subroutine a2ar (x2) bind(C) ! { dg-error "Allocatable character dummy argument 'x2' at .1. must have deferred length as procedure 'a2ar' is BIND\\(C\\)" } + character(len=2), allocatable :: x2(..) +end + +subroutine a3ar (xn, n) bind(C) ! { dg-error "Allocatable character dummy argument 'xn' at .1. must have deferred length as procedure 'a3ar' is BIND\\(C\\)" } + integer :: n + character(len=n), allocatable :: xn(..) +end + +subroutine a4ar (xstar) bind(C) ! { dg-error "Allocatable character dummy argument 'xstar' at .1. must have deferred length as procedure 'a4ar' is BIND\\(C\\)" } + character(len=*), allocatable :: xstar(..) +end + +subroutine a5ar (xcolon) bind(C) + character(len=:), allocatable :: xcolon(..) +end + +! POINTER +! Scalar, pointer + +subroutine s1p (x1) bind(C) ! { dg-error "Pointer character dummy argument 'x1' at .1. must have deferred length as procedure 's1p' is BIND\\(C\\)" } + character(len=1), pointer :: x1 +end + +subroutine s2p (x2) bind(C) ! { dg-error "Pointer character dummy argument 'x2' at .1. must have deferred length as procedure 's2p' is BIND\\(C\\)" } + character(len=2), pointer :: x2 +end + +subroutine s3p (xn, n) bind(C) ! { dg-error "Pointer character dummy argument 'xn' at .1. must have deferred length as procedure 's3p' is BIND\\(C\\)" } + integer :: n + character(len=n), pointer :: xn +end + +subroutine s4p (xstar) bind(C) ! { dg-error "Pointer character dummy argument 'xstar' at .1. must have deferred length as procedure 's4p' is BIND\\(C\\)" } + character(len=*), pointer :: xstar +end + +subroutine s5p (xcolon) bind(C) + character(len=:), pointer :: xcolon +end + +! Assumed-shape array, pointer + +subroutine a1p (x1) bind(C) ! { dg-error "Pointer character dummy argument 'x1' at .1. must have deferred length as procedure 'a1p' is BIND\\(C\\)" } + character(len=1), pointer :: x1(:) +end + +subroutine a2p (x2) bind(C) ! { dg-error "Pointer character dummy argument 'x2' at .1. must have deferred length as procedure 'a2p' is BIND\\(C\\)" } + character(len=2), pointer :: x2(:,:) +end + +subroutine a3p (xn, n) bind(C) ! { dg-error "Pointer character dummy argument 'xn' at .1. must have deferred length as procedure 'a3p' is BIND\\(C\\)" } + integer :: n + character(len=n), pointer :: xn(:,:,:) +end + +subroutine a4p (xstar) bind(C) ! { dg-error "Pointer character dummy argument 'xstar' at .1. must have deferred length as procedure 'a4p' is BIND\\(C\\)" } + character(len=*), pointer :: xstar(:,:,:,:) +end + +subroutine a5p (xcolon) bind(C) + character(len=:), pointer :: xcolon(:) +end + +! Assumed-rank array, pointer + +subroutine a1pr (x1) bind(C) ! { dg-error "Pointer character dummy argument 'x1' at .1. must have deferred length as procedure 'a1pr' is BIND\\(C\\)" } + character(len=1), pointer :: x1(..) +end + +subroutine a2pr (x2) bind(C) ! { dg-error "Pointer character dummy argument 'x2' at .1. must have deferred length as procedure 'a2pr' is BIND\\(C\\)" } + character(len=2), pointer :: x2(..) +end + +subroutine a3pr (xn, n) bind(C) ! { dg-error "Pointer character dummy argument 'xn' at .1. must have deferred length as procedure 'a3pr' is BIND\\(C\\)" } + integer :: n + character(len=n), pointer :: xn(..) +end + +subroutine a4pr (xstar) bind(C) ! { dg-error "Pointer character dummy argument 'xstar' at .1. must have deferred length as procedure 'a4pr' is BIND\\(C\\)" } + character(len=*), pointer :: xstar(..) +end + +subroutine a5pr (xcolon) bind(C) + character(len=:), pointer :: xcolon(..) +end diff --git a/Fortran/gfortran/regression/bind_c_char_9.f90 b/Fortran/gfortran/regression/bind_c_char_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_char_9.f90 @@ -0,0 +1,207 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } + +! F2018 - examples without array descriptor + + +module m + use iso_c_binding, only: c_char + implicit none (type, external) + +contains + +! Scalar, nonallocatable/nonpointer +subroutine s1 (x1) bind(C) + character(kind=c_char, len=1) :: x1 + if (len (x1) /= 1) stop + if (x1 /= 'Z') stop + x1 = 'A' +end + +! Valid as Fortran code - but with BIND(C) +! 18.3.6 (5) (bullet 5) requires interoperability, i.e. len=1 +! which is not fullfilled. +! +! [It would work as with len= the length is known +! and only a bytestream is passed around.] +!subroutine s2 (x2) bind(C) +! character(kind=c_char, len=2) :: x2 +! if (len (x2) /= 2) stop +! if (x2 /= '42') stop +! x2 = '64' +!end + +! Assumed-size array, nonallocatable/nonpointer + +subroutine az1 (x1) bind(C) + character(kind=c_char, len=1) :: x1(*) + if (len(x1) /= 1) stop + if (any (x1(:6) /= ['g', & + 'd', & + 'f', & + 's', & + '3', & + '5'])) stop 1 + x1(:6) = ['1', & + 'h', & + 'f', & + '3', & + '4', & + 'h'] +end + +! Valid as Fortran code - but with BIND(C) +! 18.3.6 (5) (bullet 5) requires interoperability, i.e. len=1 +! which is not fullfilled. +! +! [It would work as with len= the length is known +! and only a bytestream is passed around.] +!subroutine az2 (x2) bind(C) +! character(kind=c_char, len=2) :: x2(*) +! if (len(x2) /= 2) stop +! if (any (x2(:6) /= ['ab', & +! 'fd', & +! 'D4', & +! '54', & +! 'ga', & +! 'hg'])) stop +! x2(:6) = ['ab', & +! 'hd', & +! 'fj', & +! 'a4', & +! '4a', & +! 'hf'] +!end + +! Explicit-size array, nonallocatable/nonpointer + +subroutine ae1 (x1) bind(C) + character(kind=c_char, len=1) :: x1(6) + if (size(x1) /= 6) stop + if (len(x1) /= 1) stop + if (any (x1 /= ['g', & + 'd', & + 'f', & + 's', & + '3', & + '5'])) stop 1 + x1 = ['1', & + 'h', & + 'f', & + '3', & + '4', & + 'h'] +end + +! Valid as Fortran code - but with BIND(C) +! 18.3.6 (5) (bullet 5) requires interoperability, i.e. len=1 +! which is not fullfilled. +! +! [It would work as with len= the length is known +! and only a bytestream is passed around.] +!subroutine ae2 (x2) bind(C) +! character(kind=c_char, len=2) :: x2(6) +! if (size(x2) /= 6) stop +! if (len(x2) /= 2) stop +! if (any (x2 /= ['ab', & +! 'fd', & +! 'D4', & +! '54', & +! 'ga', & +! 'hg'])) stop +! x2 = ['ab', & +! 'hd', & +! 'fj', & +! 'a4', & +! '4a', & +! 'hf'] +!end + +end module m + +program main + use m + implicit none (type, external) + character(kind=c_char, len=1) :: str1 + character(kind=c_char, len=2) :: str2 + + character(kind=c_char, len=1) :: str1a6(6) + character(kind=c_char, len=2) :: str2a6(6) + + ! Scalar - no array descriptor + + str1 = 'Z' + call s1 (str1) + if (str1 /= 'A') stop + +! str2 = '42' +! call s2 (str2) +! if (str2 /= '64') stop + + ! assumed size - without array descriptor + + str1a6 = ['g', & + 'd', & + 'f', & + 's', & + '3', & + '5'] + call az1 (str1a6) + if (any (str1a6 /= ['1', & + 'h', & + 'f', & + '3', & + '4', & + 'h'])) stop +! str2a6 = ['ab', & +! 'fd', & +! 'D4', & +! '54', & +! 'ga', & +! 'hg'] +! call az2 (str2a6) +! if (any (str2a6 /= ['ab', & +! 'hd', & +! 'fj', & +! 'a4', & +! '4a', & +! 'hf'])) stop + + ! explicit size - without array descriptor + + str1a6 = ['g', & + 'd', & + 'f', & + 's', & + '3', & + '5'] + call ae1 (str1a6) + if (any (str1a6 /= ['1', & + 'h', & + 'f', & + '3', & + '4', & + 'h'])) stop +! str2a6 = ['ab', & +! 'fd', & +! 'D4', & +! '54', & +! 'ga', & +! 'hg'] +! call ae2 (str2a6) +! if (any (str2a6 /= ['ab', & +! 'hd', & +! 'fj', & +! 'a4', & +! '4a', & +! 'hf'])) stop +end + +! All argument shall be passed without descriptor +! { dg-final { scan-tree-dump-not "dtype" "original" } } +! { dg-final { scan-tree-dump-times "void s1 \\(character\\(kind=1\\)\\\[1:1\\\] & restrict x1\\)" 1 "original" } } +! { dg-final { scan-tree-dump-not "void s2 " "original" } } +! { dg-final { scan-tree-dump-times "void az1 \\(character\\(kind=1\\)\\\[0:\\\]\\\[1:1\\\] \\* restrict x1\\)" 1 "original" } } +! { dg-final { scan-tree-dump-not "void az2 " "original" } } +! { dg-final { scan-tree-dump-times "void ae1 \\(character\\(kind=1\\)\\\[6\\\]\\\[1:1\\\] \\* restrict x1\\)" 1 "original" } } +! { dg-final { scan-tree-dump-not "void ae2 " "original" } } diff --git a/Fortran/gfortran/regression/bind_c_coms.f90 b/Fortran/gfortran/regression/bind_c_coms.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_coms.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +! { dg-additional-sources bind_c_coms_driver.c } +! { dg-options "-w" } +! the -w option is to prevent the warning about long long ints +module bind_c_coms + use, intrinsic :: iso_c_binding + implicit none + + common /COM/ R, S + real(c_double) :: r + real(c_double) :: t + real(c_double) :: s + bind(c) :: /COM/, /SINGLE/, /MYCOM/ + common /SINGLE/ T + common /MYCOM/ LONG_INTS + integer(c_long) :: LONG_INTS + common /MYCOM2/ LONG_LONG_INTS + integer(c_long_long) :: long_long_ints + bind(c) :: /mycom2/ + + common /com2/ i, j + integer(c_int) :: i, j + bind(c, name="f03_com2") /com2/ + + common /com3/ m, n + integer(c_int) :: m, n + bind(c, name="") /com3/ + +contains + subroutine test_coms() bind(c) + r = r + .1d0; + s = s + .1d0; + t = t + .1d0; + long_ints = long_ints + 1 + long_long_ints = long_long_ints + 1 + i = i + 1 + j = j + 1 + + m = 1 + n = 1 + end subroutine test_coms +end module bind_c_coms + +module bind_c_coms_2 + use, intrinsic :: iso_c_binding, only: c_int + common /com3/ m, n + integer(c_int) :: m, n + bind(c, name="") /com3/ +end module bind_c_coms_2 diff --git a/Fortran/gfortran/regression/bind_c_coms_driver.c b/Fortran/gfortran/regression/bind_c_coms_driver.c --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_coms_driver.c @@ -0,0 +1,42 @@ +double fabs(double); + +void test_coms(void); + +extern void abort(void); + +struct {double r, s; } com; /* refers to the common block "com" */ +double single; /* refers to the common block "single" */ +long int mycom; /* refers to the common block "MYCOM" */ +long long int mycom2; /* refers to the common block "MYCOM2" */ +struct {int i, j; } f03_com2; /* refers to the common block "com2" */ + +int main(int argc, char **argv) +{ + com.r = 1.0; + com.s = 2.0; + single = 1.0; + mycom = 1; + mycom2 = 2; + f03_com2.i = 1; + f03_com2.j = 2; + + /* change the common block variables in F90 */ + test_coms(); + + if(fabs(com.r - 1.1) > 0.00000000) + abort(); + if(fabs(com.s - 2.1) > 0.00000000) + abort(); + if(fabs(single - 1.1) > 0.00000000) + abort(); + if(mycom != 2) + abort(); + if(mycom2 != 3) + abort(); + if(f03_com2.i != 2) + abort(); + if(f03_com2.j != 3) + abort(); + + return 0; +}/* end main() */ diff --git a/Fortran/gfortran/regression/bind_c_contiguous.f90 b/Fortran/gfortran/regression/bind_c_contiguous.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_contiguous.f90 @@ -0,0 +1,33 @@ +module m + use iso_c_binding + implicit none (type, external) +contains + +! All of the following use an array descriptor +! F2018, 18.3.7 (5) applies: + +subroutine f1 (x) bind(c) ! { dg-error "Dummy argument 'x' at .1. may not be a pointer with CONTIGUOUS attribute as procedure 'f1' is BIND\\(C\\)" } + character(len=:, kind=c_char), pointer, contiguous :: x(:) +end + +subroutine f2 (x) bind(c) ! { dg-error "Dummy argument 'x' at .1. may not be a pointer with CONTIGUOUS attribute as procedure 'f2' is BIND\\(C\\)" } + integer(c_int), pointer, contiguous :: x(:) +end + +subroutine f3 (x) bind(c) + character(len=:, kind=c_char), pointer :: x(:) ! OK - pointer but not contiguous +end + +subroutine f4 (x) bind(c) + character(len=*, kind=c_char), contiguous :: x(:) ! OK - contiguous but not a pointer +end + +subroutine f5 (x) bind(c) + integer(c_int), pointer :: x(:) ! OK - pointer but not contigous +end + +subroutine f6 (x) bind(c) + integer(c_int), contiguous :: x(:) ! OK - contiguous but not a pointer +end + +end diff --git a/Fortran/gfortran/regression/bind_c_dts.f90 b/Fortran/gfortran/regression/bind_c_dts.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_dts.f90 @@ -0,0 +1,41 @@ +! { dg-do run } +! { dg-additional-sources bind_c_dts_driver.c } +module bind_c_dts + use, intrinsic :: iso_c_binding + implicit none + + type, bind(c) :: MYFTYPE_1 + integer(c_int) :: i, j + real(c_float) :: s + end type MYFTYPE_1 + + TYPE, BIND(C) :: particle + REAL(C_DOUBLE) :: x,vx + REAL(C_DOUBLE) :: y,vy + REAL(C_DOUBLE) :: z,vz + REAL(C_DOUBLE) :: m + END TYPE particle + + type(myftype_1), bind(c, name="myDerived") :: myDerived + +contains + subroutine types_test(my_particles, num_particles) bind(c) + integer(c_int), value :: num_particles + type(particle), dimension(num_particles) :: my_particles + integer :: i + + ! going to set the particle in the middle of the list + i = num_particles / 2; + my_particles(i)%x = my_particles(i)%x + .2d0 + my_particles(i)%vx = my_particles(i)%vx + .2d0 + my_particles(i)%y = my_particles(i)%y + .2d0 + my_particles(i)%vy = my_particles(i)%vy + .2d0 + my_particles(i)%z = my_particles(i)%z + .2d0 + my_particles(i)%vz = my_particles(i)%vz + .2d0 + my_particles(i)%m = my_particles(i)%m + .2d0 + + myDerived%i = myDerived%i + 1 + myDerived%j = myDerived%j + 1 + myDerived%s = myDerived%s + 1.0; + end subroutine types_test +end module bind_c_dts diff --git a/Fortran/gfortran/regression/bind_c_dts_2.f03 b/Fortran/gfortran/regression/bind_c_dts_2.f03 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_dts_2.f03 @@ -0,0 +1,61 @@ +! { dg-do run } +! { dg-additional-sources bind_c_dts_2_driver.c } +module bind_c_dts_2 +use, intrinsic :: iso_c_binding +implicit none + +type, bind(c) :: my_c_type_0 + integer(c_int) :: i + type(c_ptr) :: nested_c_address + integer(c_int) :: array(3) +end type my_c_type_0 + +type, bind(c) :: my_c_type_1 + type(my_c_type_0) :: my_nested_type + type(c_ptr) :: c_address + integer(c_int) :: j +end type my_c_type_1 + +contains + subroutine sub0(my_type, expected_i, expected_nested_c_address, & + expected_array_1, expected_array_2, expected_array_3, & + expected_c_address, expected_j) bind(c) + type(my_c_type_1) :: my_type + integer(c_int), value :: expected_i + type(c_ptr), value :: expected_nested_c_address + integer(c_int), value :: expected_array_1 + integer(c_int), value :: expected_array_2 + integer(c_int), value :: expected_array_3 + type(c_ptr), value :: expected_c_address + integer(c_int), value :: expected_j + + if (my_type%my_nested_type%i .ne. expected_i) then + STOP 1 + end if + + if (.not. c_associated(my_type%my_nested_type%nested_c_address, & + expected_nested_c_address)) then + STOP 2 + end if + + if (my_type%my_nested_type%array(1) .ne. expected_array_1) then + STOP 3 + end if + + if (my_type%my_nested_type%array(2) .ne. expected_array_2) then + STOP 4 + end if + + if (my_type%my_nested_type%array(3) .ne. expected_array_3) then + STOP 5 + end if + + if (.not. c_associated(my_type%c_address, expected_c_address)) then + STOP 6 + end if + + if (my_type%j .ne. expected_j) then + STOP 7 + end if + end subroutine sub0 +end module bind_c_dts_2 diff --git a/Fortran/gfortran/regression/bind_c_dts_2_driver.c b/Fortran/gfortran/regression/bind_c_dts_2_driver.c --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_dts_2_driver.c @@ -0,0 +1,37 @@ +typedef struct c_type_0 +{ + int i; + int *ptr; + int array[3]; +}c_type_0_t; + +typedef struct c_type_1 +{ + c_type_0_t nested_type; + int *ptr; + int j; +}c_type_1_t; + +void sub0(c_type_1_t *c_type, int expected_i, int *expected_nested_ptr, + int array_0, int array_1, int array_2, + int *expected_ptr, int expected_j); + +int main(int argc, char **argv) +{ + c_type_1_t c_type; + + c_type.nested_type.i = 10; + c_type.nested_type.ptr = &(c_type.nested_type.i); + c_type.nested_type.array[0] = 1; + c_type.nested_type.array[1] = 2; + c_type.nested_type.array[2] = 3; + c_type.ptr = &(c_type.j); + c_type.j = 11; + + sub0(&c_type, c_type.nested_type.i, c_type.nested_type.ptr, + c_type.nested_type.array[0], + c_type.nested_type.array[1], c_type.nested_type.array[2], + c_type.ptr, c_type.j); + + return 0; +} diff --git a/Fortran/gfortran/regression/bind_c_dts_3.f03 b/Fortran/gfortran/regression/bind_c_dts_3.f03 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_dts_3.f03 @@ -0,0 +1,37 @@ +! { dg-do compile } +module bind_c_dts_3 +use, intrinsic :: iso_c_binding +implicit none + +TYPE, bind(c) :: t + integer(c_int) :: i +end type t + +type :: my_c_type_0 ! { dg-error "must have the BIND attribute" } + integer(c_int) :: i +end type my_c_type_0 + +type, bind(c) :: my_c_type_1 ! { dg-error "BIND.C. derived type" } + type(my_c_type_0) :: my_nested_type + type(c_ptr) :: c_address + integer(c_int), pointer :: j ! { dg-error "cannot have the POINTER" } +end type my_c_type_1 + +type, bind(c) :: t2 ! { dg-error "BIND.C. derived type" } + type (t2), pointer :: next ! { dg-error "cannot have the POINTER" } +end type t2 + +type, bind(c):: t3 ! { dg-error "BIND.C. derived type" } + type(t), allocatable :: c(:) ! { dg-error "cannot have the ALLOCATABLE" } +end type t3 + +contains + subroutine sub0(my_type, expected_value) bind(c) + type(my_c_type_1) :: my_type + integer(c_int), value :: expected_value + + if (my_type%my_nested_type%i .ne. expected_value) then + STOP 1 + end if + end subroutine sub0 +end module bind_c_dts_3 diff --git a/Fortran/gfortran/regression/bind_c_dts_4.f03 b/Fortran/gfortran/regression/bind_c_dts_4.f03 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_dts_4.f03 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-Wc-binding-type" } +module test +use iso_c_binding, only: c_int + type, bind(c) :: foo + integer :: p ! { dg-warning "may not be C interoperable" } + end type + type(foo), bind(c) :: cp +end module test diff --git a/Fortran/gfortran/regression/bind_c_dts_5.f90 b/Fortran/gfortran/regression/bind_c_dts_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_dts_5.f90 @@ -0,0 +1,52 @@ +! { dg-do compile } +! +! PR fortran/50933 +! +! Check whether type-compatibility checks for BIND(C) work. +! +! Contributed by Richard Maine +! + +MODULE liter_cb_mod +USE ISO_C_BINDING +CONTAINS + FUNCTION liter_cb(link_info) bind(C) + USE ISO_C_BINDING + IMPLICIT NONE + + INTEGER(c_int) liter_cb + + TYPE, bind(C) :: info_t + INTEGER(c_int) :: type + END TYPE info_t + + TYPE(info_t) :: link_info + + liter_cb = 0 + + END FUNCTION liter_cb + +END MODULE liter_cb_mod + +PROGRAM main + USE ISO_C_BINDING + interface + FUNCTION liter_cb(link_info) bind(C) + USE ISO_C_BINDING + IMPLICIT NONE + INTEGER(c_int) liter_cb + TYPE, bind(C) :: info_t + INTEGER(c_int) :: type + END TYPE info_t + TYPE(info_t) :: link_info + END FUNCTION liter_cb + end interface + + TYPE, bind(C) :: info_t + INTEGER(c_int) :: type + END TYPE info_t + type(info_t) :: link_info + + write (*,*) liter_cb(link_info) + +END PROGRAM main diff --git a/Fortran/gfortran/regression/bind_c_dts_driver.c b/Fortran/gfortran/regression/bind_c_dts_driver.c --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_dts_driver.c @@ -0,0 +1,66 @@ +double fabs (double); + +/* interops with myftype_1 */ +typedef struct { + int m, n; + float r; +} myctype_t; + +/* interops with particle in f90 */ +typedef struct particle +{ + double x; /* x position */ + double vx; /* velocity in x direction */ + double y; /* y position */ + double vy; /* velocity in y direction */ + double z; /* z position */ + double vz; /* velocity in z direction */ + double m; /* mass */ +}particle_t; + +extern void abort(void); +void types_test(particle_t *my_particles, int num_particles); +/* declared in the fortran module bind_c_dts */ +extern myctype_t myDerived; + +int main(int argc, char **argv) +{ + particle_t my_particles[100]; + + /* the fortran code will modify the middle particle */ + my_particles[49].x = 1.0; + my_particles[49].vx = 1.0; + my_particles[49].y = 1.0; + my_particles[49].vy = 1.0; + my_particles[49].z = 1.0; + my_particles[49].vz = 1.0; + my_particles[49].m = 1.0; + + myDerived.m = 1; + myDerived.n = 2; + myDerived.r = 3.0; + + types_test(&(my_particles[0]), 100); + + if(fabs(my_particles[49].x - 1.2) > 0.00000000) + abort(); + if(fabs(my_particles[49].vx - 1.2) > 0.00000000) + abort(); + if(fabs(my_particles[49].y - 1.2) > 0.00000000) + abort(); + if(fabs(my_particles[49].vy - 1.2) > 0.00000000) + abort(); + if(fabs(my_particles[49].z - 1.2) > 0.00000000) + abort(); + if(fabs(my_particles[49].vz - 1.2) > 0.00000000) + abort(); + if(fabs(my_particles[49].m - 1.2) > 0.00000000) + abort(); + if(myDerived.m != 2) + abort(); + if(myDerived.n != 3) + abort(); + if(fabs(myDerived.r - 4.0) > 0.00000000) + abort(); + return 0; +}/* end main() */ diff --git a/Fortran/gfortran/regression/bind_c_implicit_vars.f03 b/Fortran/gfortran/regression/bind_c_implicit_vars.f03 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_implicit_vars.f03 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-Wc-binding-type" } +module bind_c_implicit_vars + +bind(c) :: j ! { dg-warning "may not be C interoperable" } + +contains + subroutine sub0(i) bind(c) ! { dg-warning "may not be C interoperable" } + i = 0 + end subroutine sub0 +end module bind_c_implicit_vars diff --git a/Fortran/gfortran/regression/bind_c_module.f90 b/Fortran/gfortran/regression/bind_c_module.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_module.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! See PR fortran/36251. +module a + implicit none + integer :: i = 42 +end module a + +! Causes ICE +module b + use iso_c_binding + use a + implicit none + bind(c) :: a ! { dg-error "applied to" } +end module b + +! Causes ICE +module d + use a + implicit none + bind(c) :: a ! { dg-error "applied to" } +end module d diff --git a/Fortran/gfortran/regression/bind_c_optional-1.f90 b/Fortran/gfortran/regression/bind_c_optional-1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_optional-1.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! +! PR fortran/92872 +! +! Contributed by G. Steinmetz +! +module m +contains +subroutine s(x) bind(c) + integer, allocatable, optional :: x(:) + x = [1, 2, 3] +end +end + +use m +integer, allocatable :: y(:) +! NOTE: starting at 0, otherwise it will fail due to PR 92189 +allocate(y(0:2)) +y = [9, 8, 7] +call s(y) +if (any (y /= [1, 2, 3])) stop 1 +end diff --git a/Fortran/gfortran/regression/bind_c_procs.f03 b/Fortran/gfortran/regression/bind_c_procs.f03 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_procs.f03 @@ -0,0 +1,38 @@ +! { dg-do compile } +! { dg-options "-Wc-binding-type" } +module bind_c_procs + use, intrinsic :: iso_c_binding, only: c_int + + interface + ! warning for my_param possibly not being C interoperable + subroutine my_c_sub(my_param) bind(c) ! { dg-warning "may not be C interoperable" } + integer, value :: my_param + end subroutine my_c_sub + + ! warning for my_c_func possibly not being a C interoperable kind + ! warning for my_param possibly not being C interoperable + ! error message truncated to provide an expression that both warnings + ! should match. + function my_c_func(my_param) bind(c) ! { dg-warning "may not be" } + integer, value :: my_param + integer :: my_c_func + end function my_c_func + end interface + +contains + ! warning for my_param possibly not being C interoperable + subroutine my_f03_sub(my_param) bind(c) ! { dg-warning "may not be" } + integer, value :: my_param + end subroutine my_f03_sub + + ! warning for my_f03_func possibly not being a C interoperable kind + ! warning for my_param possibly not being C interoperable + ! error message truncated to provide an expression that both warnings + ! should match. + function my_f03_func(my_param) bind(c) ! { dg-warning "may not be" } + integer, value :: my_param + integer :: my_f03_func + my_f03_func = 1 + end function my_f03_func + +end module bind_c_procs diff --git a/Fortran/gfortran/regression/bind_c_procs_2.f90 b/Fortran/gfortran/regression/bind_c_procs_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_procs_2.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +! PR 59023: [4.9 regression] ICE in gfc_search_interface with BIND(C) +! +! Contributed by Francois-Xavier Coudert + + type t + integer hidden + end type + +contains + + subroutine bar + type(t) :: toto + interface + integer function helper() bind(c) + end function + end interface + toto = t(helper()) + end subroutine + +end diff --git a/Fortran/gfortran/regression/bind_c_procs_3.f90 b/Fortran/gfortran/regression/bind_c_procs_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_procs_3.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! +! Test the fix for PR92123, in which 'dat' caused an error with the message +! "Scalar variable 'dat' at ?? with POINTER or ALLOCATABLE in procedure Fsub +! with BIND(C) is not yet supported." +! +! Contributed by Vipul Parekh +! +module m + use, intrinsic :: iso_c_binding, only : c_int +contains + subroutine Fsub( dat ) bind(C, name="Fsub") + !.. Argument list + integer(c_int), allocatable, intent(out) :: dat + dat = 42 + return + end subroutine +end module m + + use, intrinsic :: iso_c_binding, only : c_int + use m, only : Fsub + integer(c_int), allocatable :: x + call Fsub( x ) + if (x .ne. 42) stop 1 +end diff --git a/Fortran/gfortran/regression/bind_c_procs_4.f90 b/Fortran/gfortran/regression/bind_c_procs_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_procs_4.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! PR fortran/95375 - ICE in add_use_op +! Contributed by G.Steinmetz + +function f() result(n) bind(c) ! { dg-error "not C interoperable" } + class(*), allocatable :: n +end +program p + interface + function f() result(n) bind(c) + integer :: n + end + end interface + if ( f() /= 0 ) stop +end + +! { dg-prune-output "Type mismatch" } diff --git a/Fortran/gfortran/regression/bind_c_usage_10.f03 b/Fortran/gfortran/regression/bind_c_usage_10.f03 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_10.f03 @@ -0,0 +1,73 @@ +! { dg-do run } +! { dg-additional-sources bind_c_usage_10_c.c } +! +! PR fortran/34079 +! +! Check BIND(C) for ENTRY +! +module mod + use iso_c_binding + implicit none +contains + subroutine sub1(j) bind(c, name="mySub1") + integer(c_int) :: j + real(c_float) :: x + j = 5 + return + entry sub1ent(x) + x = 55.0 + end subroutine sub1 + subroutine sub2(j) + integer(c_int) :: j + real(c_float) :: x + j = 6 + return + entry sub2ent(x) bind(c, name="mySubEnt2") + x = 66.0 + end subroutine sub2 + subroutine sub3(j) bind(c, name="mySub3") + integer(c_int) :: j + real(c_float) :: x + j = 7 + return + entry sub3ent(x) bind(c, name="mySubEnt3") + x = 77.0 + end subroutine sub3 + subroutine sub4(j) + integer(c_int) :: j + real(c_float) :: x + j = 8 + return + entry sub4ent(x) bind(c) + x = 88.0 + end subroutine sub4 + + integer(c_int) function func1() bind(c, name="myFunc1") + real(c_float) :: func1ent + func1 = -5 + return + entry func1ent() + func1ent = -55.0 + end function func1 + integer(c_int) function func2() + real(c_float) :: func2ent + func2 = -6 + return + entry func2ent() bind(c, name="myFuncEnt2") + func2ent = -66.0 + end function func2 + integer(c_int) function func3() bind(c, name="myFunc3") + real(c_float) :: func3ent + func3 = -7 + return + entry func3ent() bind(c, name="myFuncEnt3") + func3ent = -77.0 + end function func3 + integer(c_int) function func4() + real(c_float) :: func4ent + func4 = -8 + return + entry func4ent() bind(c) + func4ent = -88.0 + end function func4 +end module mod diff --git a/Fortran/gfortran/regression/bind_c_usage_10_c.c b/Fortran/gfortran/regression/bind_c_usage_10_c.c --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_10_c.c @@ -0,0 +1,48 @@ +/* Check BIND(C) for ENTRY + PR fortran/34079 + To be linked with bind_c_usage_10.f03 +*/ + +void mySub1(int *); +void mySub3(int *); +void mySubEnt2(float *); +void mySubEnt3(float *); +void sub4ent(float *); + +int myFunc1(void); +int myFunc3(void); +float myFuncEnt2(void); +float myFuncEnt3(void); +float func4ent(void); + +extern void abort(void); + +int main() +{ + int i = -1; + float r = -3.0f; + + mySub1(&i); + if(i != 5) abort(); + mySub3(&i); + if(i != 7) abort(); + mySubEnt2(&r); + if(r != 66.0f) abort(); + mySubEnt3(&r); + if(r != 77.0f) abort(); + sub4ent(&r); + if(r != 88.0f) abort(); + + i = myFunc1(); + if(i != -5) abort(); + i = myFunc3(); + if(i != -7) abort(); + r = myFuncEnt2(); + if(r != -66.0f) abort(); + r = myFuncEnt3(); + if(r != -77.0f) abort(); + r = func4ent(); + if(r != -88.0f) abort(); + + return 0; +} diff --git a/Fortran/gfortran/regression/bind_c_usage_11.f03 b/Fortran/gfortran/regression/bind_c_usage_11.f03 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_11.f03 @@ -0,0 +1,50 @@ +! { dg-do compile } +! { dg-options "-std=gnu" } +! PR fortran/34133 +! +! The compiler should accept internal procedures with BIND(c) attribute +! for STD GNU / Fortran 2008. +! +subroutine foo() bind(c) +contains + subroutine bar() bind (c) + end subroutine bar +end subroutine foo + +subroutine foo2() bind(c) + use iso_c_binding +contains + integer(c_int) function barbar() bind (c) + barbar = 1 + end function barbar +end subroutine foo2 + +function one() bind(c) + use iso_c_binding + integer(c_int) :: one + one = 1 +contains + integer(c_int) function two() bind (c) + two = 1 + end function two +end function one + +function one2() bind(c) + use iso_c_binding + integer(c_int) :: one2 + one2 = 1 +contains + subroutine three() bind (c) + end subroutine three +end function one2 + +program main + use iso_c_binding + implicit none +contains + subroutine test() bind(c) + end subroutine test + integer(c_int) function test2() bind (c) + test2 = 1 + end function test2 +end program main diff --git a/Fortran/gfortran/regression/bind_c_usage_12.f03 b/Fortran/gfortran/regression/bind_c_usage_12.f03 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_12.f03 @@ -0,0 +1,63 @@ +! { dg-do compile } +! { dg-options "-std=gnu" } +! PR fortran/34133 +! +! bind(C,name="...") is invalid for dummy procedures +! and for internal procedures. +! +subroutine dummy1(a,b) +! implicit none + interface + function b() bind(c,name="jakl") ! { dg-error "no binding name is allowed" } +! use iso_c_binding +! integer(c_int) :: b + end function b ! { dg-error "Expecting END INTERFACE" } + end interface + interface + subroutine a() bind(c,name="") ! { dg-error "no binding name is allowed" } + end subroutine a ! { dg-error "Expecting END INTERFACE" } + end interface +end subroutine dummy1 + +subroutine internal() + implicit none +contains + subroutine int1() bind(c, name="jj") ! { dg-error "No binding name is allowed" } + end subroutine int1 ! { dg-error "Expected label" } +end subroutine internal + +subroutine internal1() + use iso_c_binding + implicit none +contains + integer(c_int) function int2() bind(c, name="jjj") ! { dg-error "No binding name is allowed" } + end function int2 ! { dg-error "Expecting END SUBROUTINE" } +end subroutine internal1 + +integer(c_int) function internal2() + use iso_c_binding + implicit none + internal2 = 0 +contains + subroutine int1() bind(c, name="kk") ! { dg-error "No binding name is allowed" } + end subroutine int1 ! { dg-error "Expecting END FUNCTION" } +end function internal2 + +integer(c_int) function internal3() + use iso_c_binding + implicit none + internal3 = 0 +contains + integer(c_int) function int2() bind(c, name="kkk") ! { dg-error "No binding name is allowed" } + end function int2 ! { dg-error "Expected label" } +end function internal3 + +program internal_prog + use iso_c_binding + implicit none +contains + subroutine int1() bind(c, name="mm") ! { dg-error "No binding name is allowed" } + end subroutine int1 ! { dg-error "Expecting END PROGRAM statement" } + integer(c_int) function int2() bind(c, name="mmm") ! { dg-error "No binding name is allowed" } + end function int2 ! { dg-error "Expecting END PROGRAM statement" } +end program diff --git a/Fortran/gfortran/regression/bind_c_usage_13.f03 b/Fortran/gfortran/regression/bind_c_usage_13.f03 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_13.f03 @@ -0,0 +1,150 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -Wc-binding-type" } +! +! PR fortran/34079 +! Character bind(c) arguments shall not pass the length as additional argument +! + +subroutine multiArgTest() + implicit none +interface ! Array + subroutine multiso_array(x,y) bind(c) + use iso_c_binding + character(kind=c_char,len=1), dimension(*) :: x,y + end subroutine multiso_array + subroutine multiso2_array(x,y) bind(c) ! { dg-warning "may not be C interoperable" } + character(len=1), dimension(*) :: x,y + end subroutine multiso2_array + subroutine mult_array(x,y) + use iso_c_binding + character(kind=c_char,len=1), dimension(*) :: x,y + end subroutine mult_array +end interface + +interface ! Scalar: call by reference + subroutine multiso(x,y) bind(c) + use iso_c_binding + character(kind=c_char,len=1) :: x,y + end subroutine multiso + subroutine multiso2(x,y) bind(c) ! { dg-warning "may not be C interoperable" } + character(len=1) :: x,y + end subroutine multiso2 + subroutine mult(x,y) + use iso_c_binding + character(kind=c_char,len=1) :: x,y + end subroutine mult +end interface + +interface ! Scalar: call by VALUE + subroutine multiso_val(x,y) bind(c) + use iso_c_binding + character(kind=c_char,len=1), value :: x,y + end subroutine multiso_val + subroutine multiso2_val(x,y) bind(c) ! { dg-warning "may not be C interoperable" } + character(len=1), value :: x,y + end subroutine multiso2_val + subroutine mult_val(x,y) + use iso_c_binding + character(kind=c_char,len=1), value :: x,y + end subroutine mult_val +end interface + +call mult_array ("abc","ab") +call multiso_array ("ABCDEF","ab") +call multiso2_array("AbCdEfGhIj","ab") + +call mult ("u","x") +call multiso ("v","x") +call multiso2("w","x") + +call mult_val ("x","x") +call multiso_val ("y","x") +call multiso2_val("z","x") +end subroutine multiArgTest + +program test +implicit none + +interface ! Array + subroutine subiso_array(x) bind(c) + use iso_c_binding + character(kind=c_char,len=1), dimension(*) :: x + end subroutine subiso_array + subroutine subiso2_array(x) bind(c) ! { dg-warning "may not be C interoperable" } + character(len=1), dimension(*) :: x + end subroutine subiso2_array + subroutine sub_array(x) + use iso_c_binding + character(kind=c_char,len=1), dimension(*) :: x + end subroutine sub_array +end interface + +interface ! Scalar: call by reference + subroutine subiso(x) bind(c) + use iso_c_binding + character(kind=c_char,len=1) :: x + end subroutine subiso + subroutine subiso2(x) bind(c) ! { dg-warning "may not be C interoperable" } + character(len=1) :: x + end subroutine subiso2 + subroutine sub(x) + use iso_c_binding + character(kind=c_char,len=1) :: x + end subroutine sub +end interface + +interface ! Scalar: call by VALUE + subroutine subiso_val(x) bind(c) + use iso_c_binding + character(kind=c_char,len=1), value :: x + end subroutine subiso_val + subroutine subiso2_val(x) bind(c) ! { dg-warning "may not be C interoperable" } + character(len=1), value :: x + end subroutine subiso2_val + subroutine sub_val(x) + use iso_c_binding + character(kind=c_char,len=1), value :: x + end subroutine sub_val +end interface + +call sub_array ("abc") +call subiso_array ("ABCDEF") +call subiso2_array("AbCdEfGhIj") + +call sub ("u") +call subiso ("v") +call subiso2("w") + +call sub_val ("x") +call subiso_val ("y") +call subiso2_val("z") +end program test + +! Double argument dump: +! +! { dg-final { scan-tree-dump "mult_array .&.abc..1..lb: 1 sz: 1., &.ab..1..lb: 1 sz: 1., 3, 2.;" "original" } } +! { dg-final { scan-tree-dump "multiso_array .&.ABCDEF..1..lb: 1 sz: 1., &.ab..1..lb: 1 sz: 1..;" "original" } } +! { dg-final { scan-tree-dump "multiso2_array .&.AbCdEfGhIj..1..lb: 1 sz: 1., &.ab..1..lb: 1 sz: 1..;" "original" } } +! +! { dg-final { scan-tree-dump "mult .&.u..1..lb: 1 sz: 1., &.x..1..lb: 1 sz: 1., 1, 1.;" "original" } } +! { dg-final { scan-tree-dump "multiso .&.v..1..lb: 1 sz: 1., &.x..1..lb: 1 sz: 1..;" "original" } } +! { dg-final { scan-tree-dump "multiso2 .&.w..1..lb: 1 sz: 1., &.x..1..lb: 1 sz: 1..;" "original" } } +! +! { dg-final { scan-tree-dump "mult_val ..x., .x., 1, 1.;" "original" } } +! { dg-final { scan-tree-dump "multiso_val .121, 120.;" "original" } } +! { dg-final { scan-tree-dump "multiso2_val ..z., .x..;" "original" } } +! +! Single argument dump: +! +! { dg-final { scan-tree-dump "sub_array .&.abc..1..lb: 1 sz: 1., 3.;" "original" } } +! { dg-final { scan-tree-dump "subiso_array .&.ABCDEF..1..lb: 1 sz: 1..;" "original" } } +! { dg-final { scan-tree-dump "subiso2_array .&.AbCdEfGhIj..1..lb: 1 sz: 1..;" "original" } } +! +! { dg-final { scan-tree-dump "sub .&.u..1..lb: 1 sz: 1., 1.;" "original" } } +! { dg-final { scan-tree-dump "subiso .&.v..1..lb: 1 sz: 1..;" "original" } } +! { dg-final { scan-tree-dump "subiso2 .&.w..1..lb: 1 sz: 1..;" "original" } } +! +! { dg-final { scan-tree-dump "sub_val ..x., 1.;" "original" } } +! { dg-final { scan-tree-dump "subiso_val .121.;" "original" } } +! { dg-final { scan-tree-dump "subiso2_val ..z..;" "original" } } +! diff --git a/Fortran/gfortran/regression/bind_c_usage_14.f03 b/Fortran/gfortran/regression/bind_c_usage_14.f03 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_14.f03 @@ -0,0 +1,114 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/34079 +! Bind(C) procedures shall have no character length +! dummy and actual arguments. +! + +! SUBROUTINES + +subroutine sub1noiso(a, b) + use iso_c_binding + implicit none + character(len=1,kind=c_char) :: a(*), b + character(len=1,kind=c_char):: x,z + integer(c_int) :: y + value :: b + print *, a(1:2), b +end subroutine sub1noiso + +subroutine sub2(a, b) bind(c) + use iso_c_binding + implicit none + character(len=1,kind=c_char) :: a(*), b + character(len=1,kind=c_char):: x,z + integer(c_int) :: y + value :: b + print *, a(1:2), b +end subroutine sub2 + +! SUBROUTINES with ENTRY + +subroutine sub3noiso(a, b) + use iso_c_binding + implicit none + character(len=1,kind=c_char) :: a(*), b + character(len=1,kind=c_char):: x,z + integer(c_int) :: y + value :: b + print *, a(1:2), b +entry sub3noisoEntry(x,y,z) + x = 'd' +end subroutine sub3noiso + +subroutine sub4iso(a, b) bind(c) + use iso_c_binding + implicit none + character(len=1,kind=c_char) :: a(*), b + character(len=1,kind=c_char):: x,z + integer(c_int) :: y + value :: b + print *, a(1:2), b +entry sub4isoEntry(x,y,z) + x = 'd' +end subroutine sub4iso + +subroutine sub5iso(a, b) bind(c) + use iso_c_binding + implicit none + character(len=1,kind=c_char) :: a(*), b + character(len=1,kind=c_char):: x,z + integer(c_int) :: y + value :: b + print *, a(1:2), b +entry sub5noIsoEntry(x,y,z) + x = 'd' +end subroutine sub5iso + +subroutine sub6NoIso(a, b) + use iso_c_binding + implicit none + character(len=1,kind=c_char) :: a(*), b + character(len=1,kind=c_char):: x,z + integer(c_int) :: y + value :: b + print *, a(1:2), b +entry sub6isoEntry(x,y,z) + x = 'd' +end subroutine sub6NoIso + +! The subroutines (including entry) should have +! only a char-length parameter if they are not bind(C). +! +! { dg-final { scan-tree-dump "sub1noiso \\(\[^.\]*a, \[^.\]*b, \[^.\]*_a, \[^.\]*_b\\)" "original" } } +! { dg-final { scan-tree-dump "sub2 \\(\[^.\]*a, \[^.\]*b\\)" "original" } } +! { dg-final { scan-tree-dump "sub3noiso \\(\[^.\]*a, \[^.\]*b, \[^.\]*_a, \[^.\]*_b\\)" "original" } } +! { dg-final { scan-tree-dump "sub3noisoentry \\(\[^.\]*x, \[^.\]*y, \[^.\]*z, \[^.\]*_x, \[^.\]*_z\\)" "original" } } +! { dg-final { scan-tree-dump "sub4iso \\(\[^.\]*a, \[^.\]*b\\)" "original" } } +! { dg-final { scan-tree-dump "sub4isoentry \\(\[^.\]*x, \[^.\]*y, \[^.\]*z, \[^.\]*_x, \[^.\]*_z\\)" "original" } } +! { dg-final { scan-tree-dump "sub5iso \\(\[^.\]*a, \[^.\]*b\\)" "original" } } +! { dg-final { scan-tree-dump "sub5noisoentry \\(\[^.\]*x, \[^.\]*y, \[^.\]*z, \[^.\]*_x, \[^.\]*_z\\)" "original" } } +! { dg-final { scan-tree-dump "sub6noiso \\(\[^.\]*a, \[^.\]*b, \[^.\]*_a, \[^.\]*_b\\)" "original" } } +! { dg-final { scan-tree-dump "sub6isoentry \\(\[^.\]*x, \[^.\]*y, \[^.\]*z, \[^.\]*_x, \[^.\]*_z\\)" "original" } } + +! The master functions should have always a length parameter +! to ensure sharing a parameter between bind(C) and non-bind(C) works +! +! { dg-final { scan-tree-dump "master.0.sub3noiso \\(\[^.\]*__entry, \[^.\]*z, \[^.\]*y, \[^.\]*x, \[^.\]*b, \[^.\]*a, \[^.\]*_z, \[^.\]*_x, \[^.\]*_b, \[^.\]*_a\\)" "original" } } +! { dg-final { scan-tree-dump "master.1.sub4iso \\(\[^.\]*__entry, \[^.\]*z, \[^.\]*y, \[^.\]*x, \[^.\]*b, \[^.\]*a, \[^.\]*_z, \[^.\]*_x, \[^.\]*_b, \[^.\]*_a\\)" "original" } } +! { dg-final { scan-tree-dump "master.2.sub5iso \\(\[^.\]*__entry, \[^.\]*z, \[^.\]*y, \[^.\]*x, \[^.\]*b, \[^.\]*a, \[^.\]*_z, \[^.\]*_x, \[^.\]*_b, \[^.\]*_a\\)" "original" } } +! { dg-final { scan-tree-dump "master.3.sub6noiso \\(\[^.\]*__entry, \[^.\]*z, \[^.\]*y, \[^.\]*x, \[^.\]*b, \[^.\]*a, \[^.\]*_z, \[^.\]*_x, \[^.\]*_b, \[^.\]*_a\\)" "original" } } + +! Thus, the master functions need to be called with length arguments +! present +! +! { dg-final { scan-tree-dump "master.0.sub3noiso .0, 0B, 0B, 0B, b, a, 0, 0, 1, 1\\);" "original" } } +! { dg-final { scan-tree-dump "master.0.sub3noiso .1, z, y, x, 0B, 0B, 1, 1, 0, 0\\);" "original" } } +! { dg-final { scan-tree-dump "master.1.sub4iso .0, 0B, 0B, 0B, b, a, 0, 0, 1, 1\\);" "original" } } +! { dg-final { scan-tree-dump "master.1.sub4iso .1, z, y, x, 0B, 0B, 1, 1, 0, 0\\);" "original" } } +! { dg-final { scan-tree-dump "master.2.sub5iso .0, 0B, 0B, 0B, b, a, 0, 0, 1, 1\\);" "original" } } +! { dg-final { scan-tree-dump "master.2.sub5iso .1, z, y, x, 0B, 0B, 1, 1, 0, 0\\);" "original" } } +! { dg-final { scan-tree-dump "master.3.sub6noiso .0, 0B, 0B, 0B, b, a, 0, 0, 1, 1\\);" "original" } } +! { dg-final { scan-tree-dump "master.3.sub6noiso .1, z, y, x, 0B, 0B, 1, 1, 0, 0\\);" "original" } } + diff --git a/Fortran/gfortran/regression/bind_c_usage_15.f90 b/Fortran/gfortran/regression/bind_c_usage_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_15.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! +! PR fortran/34187 +! The binding label was not exported for private procedures +! with public generic interfaces. +! +module mod + use iso_c_binding, only: c_int + implicit none + private + public :: gen, c_int + interface gen + module procedure test + end interface gen +contains + subroutine test(a) bind(c, name="myFunc") + integer(c_int), intent(out) :: a + a = 17 + end subroutine test +end module mod + +program main + use mod + implicit none + integer(c_int) :: x + x = -44 + call gen(x) + if(x /= 17) STOP 1 +end program main diff --git a/Fortran/gfortran/regression/bind_c_usage_16.f03 b/Fortran/gfortran/regression/bind_c_usage_16.f03 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_16.f03 @@ -0,0 +1,57 @@ +! { dg-do run } +! { dg-additional-sources bind_c_usage_16_c.c } +! +! PR fortran/34079 +! +! Ensure character-returning, bind(C) function work. +! +module mod + use iso_c_binding + implicit none +contains + function bar(x) bind(c, name="returnA") + character(len=1,kind=c_char) :: bar, x + bar = x + bar = 'A' + end function bar + function foo() bind(c, name="returnB") + character(len=1,kind=c_char) :: foo + foo = 'B' + end function foo +end module mod + +subroutine test() bind(c) + use mod + implicit none + character(len=1,kind=c_char) :: a + character(len=3,kind=c_char) :: b + character(len=1,kind=c_char) :: c(3) + character(len=3,kind=c_char) :: d(3) + integer :: i + + a = 'z' + b = 'fffff' + c = 'h' + d = 'uuuuu' + + a = bar('x') + if (a /= 'A') STOP 1 + b = bar('y') + if (b /= 'A' .or. iachar(b(2:2))/=32 .or. iachar(b(3:3))/=32) STOP 2 + c = bar('x') + if (any(c /= 'A')) STOP 3 + d = bar('y') + if (any(d /= 'A')) STOP 4 + + a = foo() + if (a /= 'B') STOP 5 + b = foo() + if (b /= 'B') STOP 6 + c = foo() + if (any(c /= 'B')) STOP 7 + d = foo() + if (any(d /= 'B')) STOP 8 + do i = 1,3 + if(iachar(d(i)(2:2)) /=32 .or. iachar(d(i)(3:3)) /= 32) STOP 9 + end do +end subroutine diff --git a/Fortran/gfortran/regression/bind_c_usage_16_c.c b/Fortran/gfortran/regression/bind_c_usage_16_c.c --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_16_c.c @@ -0,0 +1,22 @@ +/* Check character-returning bind(C) functions + PR fortran/34079 + To be linked with bind_c_usage_16.f03 +*/ + +#include + +char returnA(char *); +char returnB(void); +void test(void); + +int main() +{ + char c; + c = 'z'; + c = returnA(&c); + if (c != 'A') abort(); + c = returnB(); + if (c != 'B') abort(); + test(); + return 0; +} diff --git a/Fortran/gfortran/regression/bind_c_usage_17.f90 b/Fortran/gfortran/regression/bind_c_usage_17.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_17.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! { dg-additional-sources bind_c_usage_17_c.c } +! +! PR fortran/37201 +! +! +! +MODULE mod + INTERFACE + FUNCTION cdir() BIND(C,name="cdir") RESULT(r) + USE iso_c_binding + CHARACTER(kind=C_CHAR) :: r + END FUNCTION + END INTERFACE +END MODULE + +PROGRAM test + USE mod + integer :: i = -43 + character(len=1) :: str1 + character(len=4) :: str4 + str1 = 'x' + str4 = 'xyzz' + str1 = cdir() + if(str1 /= '/') STOP 1 + str4 = cdir() + if(str4 /= '/' .or. ichar(str4(2:2)) /= 32) STOP 2 + i = ICHAR(cdir()) + if (i /= 47) STOP 3 + str4 = 'xyzz' + WRITE(str4,'(a)') cdir() + if(str4 /= '/' .or. ichar(str4(2:2)) /= 32) STOP 4 + str4 = 'xyzz' + WRITE(str4,'(i0)') ICHAR(cdir()) + if(str4 /= '47' .or. ichar(str4(3:3)) /= 32) STOP 5 +END PROGRAM diff --git a/Fortran/gfortran/regression/bind_c_usage_17_c.c b/Fortran/gfortran/regression/bind_c_usage_17_c.c --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_17_c.c @@ -0,0 +1,4 @@ +/* PR fortran/37201. + Linked with bind_c_usage_17.f90. */ + +char cdir(void){return '/';} diff --git a/Fortran/gfortran/regression/bind_c_usage_18.f90 b/Fortran/gfortran/regression/bind_c_usage_18.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_18.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! { dg-options "-Wc-binding-type" } +! +! PR fortran/38160 +! + +subroutine foo(x,y,z,a) bind(c) ! { dg-warning "but may not be C interoperable" } + use iso_c_binding + implicit none + integer(4) :: x + integer(c_float) :: y ! { dg-warning "C kind type parameter is for type REAL" } + complex(c_float) :: z ! OK, c_float == c_float_complex + real(c_float_complex) :: a ! OK, c_float == c_float_complex +end subroutine foo + +use iso_c_binding +implicit none +integer, parameter :: it = c_int +integer, parameter :: dt = c_double +complex(c_int), target :: z1 ! { dg-warning "C kind type parameter is for type INTEGER" } +complex(it), target :: z2 ! { dg-warning "C kind type parameter is for type INTEGER" } +complex(c_double), target :: z3 ! OK +complex(dt), target :: z4 ! OK +type(c_ptr) :: ptr + +ptr = c_loc(z1) +ptr = c_loc(z2) +ptr = c_loc(z3) +ptr = c_loc(z4) +end diff --git a/Fortran/gfortran/regression/bind_c_usage_19.f90 b/Fortran/gfortran/regression/bind_c_usage_19.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_19.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +function return_char1(i) bind(c,name='return_char1') + use iso_c_binding + implicit none + integer(c_int) :: i + character(c_char) :: j + character(c_char) :: return_char1 + + j = achar(i) + return_char1 = j +end function return_char1 +function return_char2(i) result(output) bind(c,name='return_char2') + use iso_c_binding + implicit none + integer(c_int) :: i + character(c_char) :: j + character(c_char) :: output + + j = achar(i) + output = j +end function return_char2 +function return_char3(i) bind(c,name='return_char3') result(output) + use iso_c_binding + implicit none + integer(c_int) :: i + character(c_char) :: j + character(c_char) :: output + + j = achar(i) + output = j +end function return_char3 diff --git a/Fortran/gfortran/regression/bind_c_usage_2.f03 b/Fortran/gfortran/regression/bind_c_usage_2.f03 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_2.f03 @@ -0,0 +1,15 @@ +! { dg-do compile } +use, intrinsic :: iso_c_binding +type, bind(c) :: mytype + integer(c_int) :: j +end type mytype + +type(mytype), bind(c) :: mytype_var ! { dg-error "cannot be BIND.C." } + +integer(c_int), bind(c) :: i ! { dg-error "cannot be declared with BIND.C." } +integer(c_int), bind(c), dimension(10) :: my_array ! { dg-error "cannot be BIND.C." } + +common /COM/ i +bind(c) :: /com/ + +end diff --git a/Fortran/gfortran/regression/bind_c_usage_20.f90 b/Fortran/gfortran/regression/bind_c_usage_20.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_20.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-fcheck=bounds" } +! +! PR fortran/43015 +! +! Contributed by Dennis Wassel +! +SUBROUTINE foo(msg) BIND(C, name = "Foo") + USE, INTRINSIC :: iso_c_binding + IMPLICIT NONE + CHARACTER (KIND=C_CHAR), INTENT (out) :: msg(*) +END SUBROUTINE foo + diff --git a/Fortran/gfortran/regression/bind_c_usage_21.f90 b/Fortran/gfortran/regression/bind_c_usage_21.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_21.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! PR fortran/45211 +! +! Contributed by Scot Breitenfeld +! +module m +contains + FUNCTION liter_cb(link_info) bind(C) + USE ISO_C_BINDING + IMPLICIT NONE + + INTEGER(c_int) liter_cb + + TYPE, bind(C) :: info_t + INTEGER(c_int) :: type + END TYPE info_t + + TYPE(info_t) :: link_info + + liter_cb = 0 + END FUNCTION liter_cb +end module m diff --git a/Fortran/gfortran/regression/bind_c_usage_22.f90 b/Fortran/gfortran/regression/bind_c_usage_22.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_22.f90 @@ -0,0 +1,64 @@ +! { dg-do compile } +! { dg-options "-std=f2008ts" } +! +! PR fortran/48858 +! PR fortran/48820 +! +! OPTIONAL + BIND(C) is allowed since TS 29113 +! + +! VALID +subroutine sub(z) bind(C) + use iso_c_binding + integer(c_int), value :: z +end subroutine sub + +! VALID since TS29113 +subroutine sub2(z) bind(C) + use iso_c_binding + integer(c_int), optional :: z +end subroutine sub2 + +! VALID since TS29113 +subroutine sub2a(z) bind(C) + use iso_c_binding + integer(c_int) :: z + optional :: z +end subroutine sub2a + +! VALID since TS29113 +subroutine sub2b(z) bind(C) + use iso_c_binding + optional :: z + integer(c_int) :: z +end subroutine sub2b + +! Invalid +subroutine sub3(z) bind(C) ! { dg-error "cannot have both the OPTIONAL and the VALUE attribute" } + use iso_c_binding + integer(c_int), value, optional :: z +end subroutine sub3 + +! Invalid +subroutine sub3a(z) bind(C) ! { dg-error "cannot have both the OPTIONAL and the VALUE attribute" } + use iso_c_binding + integer(c_int) :: z + optional :: z + value :: z +end subroutine sub3a + +! Invalid +subroutine sub3b(z) bind(C) ! { dg-error "cannot have both the OPTIONAL and the VALUE attribute" } + use iso_c_binding + optional :: z + value :: z + integer(c_int) :: z +end subroutine sub3b + +! Invalid +subroutine sub3c(z) bind(C) ! { dg-error "cannot have both the OPTIONAL and the VALUE attribute" } + use iso_c_binding + value :: z + integer(c_int) :: z + optional :: z +end subroutine sub3c diff --git a/Fortran/gfortran/regression/bind_c_usage_23.f90 b/Fortran/gfortran/regression/bind_c_usage_23.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_23.f90 @@ -0,0 +1,64 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +! PR fortran/48858 +! PR fortran/48820 +! +! OPTIONAL + BIND(C) is allowed since TS 29113 +! + +! VALID +subroutine sub(z) bind(C) + use iso_c_binding + integer(c_int), value :: z +end subroutine sub + +! VALID since TS29113 +subroutine sub2(z) bind(C) ! { dg-error "with OPTIONAL attribute in procedure" } + use iso_c_binding + integer(c_int), optional :: z +end subroutine sub2 + +! VALID since TS29113 +subroutine sub2a(z) bind(C) ! { dg-error "with OPTIONAL attribute in procedure" } + use iso_c_binding + integer(c_int) :: z + optional :: z +end subroutine sub2a + +! VALID since TS29113 +subroutine sub2b(z) bind(C) ! { dg-error "with OPTIONAL attribute in procedure" } + use iso_c_binding + optional :: z + integer(c_int) :: z +end subroutine sub2b + +! Invalid +subroutine sub3(z) bind(C) ! { dg-error "cannot have both the OPTIONAL and the VALUE attribute" } + use iso_c_binding + integer(c_int), value, optional :: z +end subroutine sub3 + +! Invalid +subroutine sub3a(z) bind(C) ! { dg-error "cannot have both the OPTIONAL and the VALUE attribute" } + use iso_c_binding + integer(c_int) :: z + optional :: z + value :: z +end subroutine sub3a + +! Invalid +subroutine sub3b(z) bind(C) ! { dg-error "cannot have both the OPTIONAL and the VALUE attribute" } + use iso_c_binding + optional :: z + value :: z + integer(c_int) :: z +end subroutine sub3b + +! Invalid +subroutine sub3c(z) bind(C) ! { dg-error "cannot have both the OPTIONAL and the VALUE attribute" } + use iso_c_binding + value :: z + integer(c_int) :: z + optional :: z +end subroutine sub3c diff --git a/Fortran/gfortran/regression/bind_c_usage_24.f90 b/Fortran/gfortran/regression/bind_c_usage_24.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_24.f90 @@ -0,0 +1,41 @@ +! { dg-do run } +! { dg-additional-sources bind_c_usage_24_c.c } +! +! PR fortran/48858 +! PR fortran/48820 +! +! TS 29113: BIND(C) with OPTIONAL +! +module m + use iso_c_binding + interface + subroutine c_proc (is_present, var) bind(C) + import + logical(c_bool), value :: is_present + integer(c_int), optional :: var + end subroutine + end interface +contains + subroutine subtest (is_present, var) bind(C) + logical(c_bool), intent(in), value :: is_present + integer(c_int), intent(inout), optional :: var + if (is_present) then + if (.not. present (var)) STOP 1 + if (var /= 43) STOP 2 + var = -45 + else + if (present (var)) STOP 3 + end if + end subroutine subtest +end module m + +program test + use m + implicit none + integer :: val + + val = 4 + call c_proc (.false._c_bool) + call c_proc (.true._c_bool, val) + if (val /= 7) STOP 4 +end program test diff --git a/Fortran/gfortran/regression/bind_c_usage_24_c.c b/Fortran/gfortran/regression/bind_c_usage_24_c.c --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_24_c.c @@ -0,0 +1,25 @@ +/* Compiled and linked by bind_c.f90. */ + +#include +#include + +void subtest (bool, int *); + +void +c_proc (bool present, int *val) +{ + int val2; + if (!present && val) + abort (); + else if (present) + { + if (!val) abort (); + if (*val != 4) abort (); + *val = 7; + } + + val2 = 43; + subtest (1, &val2); + subtest (0, NULL); + if (val2 != -45) abort (); +} diff --git a/Fortran/gfortran/regression/bind_c_usage_25.f90 b/Fortran/gfortran/regression/bind_c_usage_25.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_25.f90 @@ -0,0 +1,59 @@ +! { dg-do compile } +! { dg-options "-Wno-c-binding-type" } +! { dg-require-visibility "" } +! +! That's a copy of "bind_c_usage_8.f03", "bind_c_dts_4.f03", +! "bind_c_implicit_vars.f03" and "c_kind_tests_2.f03" +! to check that with -Wno-c-binding-type no warning is printed. +! + +MODULE ISO_C_UTILITIES + USE ISO_C_BINDING + implicit none + CHARACTER(C_CHAR), DIMENSION(1), SAVE, TARGET, PRIVATE :: dummy_string="?" +CONTAINS + FUNCTION C_F_STRING(CPTR) RESULT(FPTR) + use, intrinsic :: iso_c_binding + TYPE(C_PTR), INTENT(IN) :: CPTR ! The C address + CHARACTER(KIND=C_CHAR), DIMENSION(:), POINTER :: FPTR + INTERFACE + FUNCTION strlen(string) RESULT(len) BIND(C,NAME="strlen") + USE ISO_C_BINDING + TYPE(C_PTR), VALUE :: string ! A C pointer + END FUNCTION + END INTERFACE + CALL C_F_POINTER(FPTR=FPTR, CPTR=CPTR, SHAPE=[strlen(CPTR)]) + END FUNCTION +END MODULE ISO_C_UTILITIES + +module test +use iso_c_binding, only: c_int + type, bind(c) :: foo + integer :: p + end type + type(foo), bind(c) :: cp +end module test + +module bind_c_implicit_vars + +bind(c) :: j + +contains + subroutine sub0(i) bind(c) + i = 0 + end subroutine sub0 +end module bind_c_implicit_vars + +module c_kind_tests_2 + use, intrinsic :: iso_c_binding + + integer, parameter :: myF = c_float + real(myF), bind(c) :: myCFloat + integer(myF), bind(c) :: myCInt ! { dg-warning "is for type REAL" } + integer(c_double), bind(c) :: myCInt2 ! { dg-warning "is for type REAL" } + + integer, parameter :: myI = c_int + real(myI) :: myReal ! { dg-warning "is for type INTEGER" } + real(myI), bind(c) :: myCFloat2 ! { dg-warning "is for type INTEGER" } + real(4), bind(c) :: myFloat +end module c_kind_tests_2 diff --git a/Fortran/gfortran/regression/bind_c_usage_26.f90 b/Fortran/gfortran/regression/bind_c_usage_26.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_26.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! PR fortran/53985 +! +! Check that the (default) -Wno-c-binding-type works +! and no warning is printed. +! +! With -Wc-binding-type, one gets: +! Warning: Variable 'x' at (1) is a dummy argument to the BIND(C) procedure +! 'test' but may not be C interoperable ) +! +subroutine test(x) bind(C) + integer :: x +end subroutine test diff --git a/Fortran/gfortran/regression/bind_c_usage_27.f90 b/Fortran/gfortran/regression/bind_c_usage_27.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_27.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-std=f2008ts" } +! +! Contributed by Reinhold Bader +! +use iso_c_binding +type, bind(C) :: cstruct + integer :: i +end type +interface + subroutine psub(this, that) bind(c, name='Psub') + import :: c_float, cstruct + real(c_float), pointer :: this(:) + type(cstruct), allocatable :: that(:) + end subroutine psub + end interface +end diff --git a/Fortran/gfortran/regression/bind_c_usage_28.f90 b/Fortran/gfortran/regression/bind_c_usage_28.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_28.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +! Contributed by Reinhold Bader +! +use iso_c_binding +type, bind(C) :: cstruct + integer :: i +end type +interface + subroutine psub(this) bind(c, name='Psub') ! { dg-error "Fortran 2018: Variable 'this' at .1. with POINTER attribute in procedure 'psub' with BIND.C." } + import :: c_float, cstruct + real(c_float), pointer :: this(:) + end subroutine psub + subroutine psub2(that) bind(c, name='Psub2') ! { dg-error "Fortran 2018: Variable 'that' at .1. with ALLOCATABLE attribute in procedure 'psub2' with BIND.C." } + import :: c_float, cstruct + type(cstruct), allocatable :: that(:) + end subroutine psub2 + end interface +end diff --git a/Fortran/gfortran/regression/bind_c_usage_29.f90 b/Fortran/gfortran/regression/bind_c_usage_29.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_29.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! PR fortran/38829 +! +MODULE mExample +CONTAINS + SUBROUTINE wrapper(y_c) bind(c) + USE iso_c_binding + type, bind(c) :: ty_c + type(c_ptr) :: y_cptr + Integer(c_int) ny + end type + type(ty_c) :: y_c + END SUBROUTINE +END MODULE diff --git a/Fortran/gfortran/regression/bind_c_usage_3.f03 b/Fortran/gfortran/regression/bind_c_usage_3.f03 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_3.f03 @@ -0,0 +1,19 @@ +! { dg-do compile } +module test + use, intrinsic :: iso_c_binding + + type, bind(c) :: my_c_type ! { dg-error "BIND.C. derived type" } + integer(c_int), pointer :: ptr ! { dg-error "cannot have the POINTER attribute" } + end type my_c_type + + type, bind(c) :: my_type ! { dg-error "BIND.C. derived type" } + integer(c_int), allocatable :: ptr(:) ! { dg-error "cannot have the ALLOCATABLE attribute" } + end type my_type + + type foo ! { dg-error "must have the BIND attribute" } + integer(c_int) :: p + end type foo + + type(foo), bind(c) :: cp ! { dg-error "is not C interoperable" } + real(c_double), pointer,bind(c) :: p ! { dg-error "cannot have both the POINTER and BIND.C." } +end module test diff --git a/Fortran/gfortran/regression/bind_c_usage_30.f90 b/Fortran/gfortran/regression/bind_c_usage_30.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_30.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR 60355 - there was no error message for implicitly typed variables +! Test case contributed by Vladimir Fuka +program main + bind(c) test_BIND ! { dg-error "cannot be BIND" } +END diff --git a/Fortran/gfortran/regression/bind_c_usage_31.f90 b/Fortran/gfortran/regression/bind_c_usage_31.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_31.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/84073 - this was accepted before. +module mod + use iso_c_binding + type, bind(c) :: a + character(len=2,kind=c_char) :: b ! { dg-error "must have length one" } + end type a + character(len=2), bind(C) :: c ! { dg-error "must have length one" } +end module mod diff --git a/Fortran/gfortran/regression/bind_c_usage_32.f90 b/Fortran/gfortran/regression/bind_c_usage_32.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_32.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR 46020 - check for clear error message +! { dg-options "" } +FUNCTION F_X(A) bind(c,name='F_X') ! { dg-error "must have length 1" } + CHARACTER*(*) F_X +END FUNCTION + + +FUNCTION F_Y(A) bind(c,name='F_Y') ! { dg-error "must have length 1" } + CHARACTER*(2) F_Y +END FUNCTION + + diff --git a/Fortran/gfortran/regression/bind_c_usage_33.f90 b/Fortran/gfortran/regression/bind_c_usage_33.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_33.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! { dg-additional-sources bind_c_usage_33_c.c } +module m1 + implicit none + contains + subroutine odopen(unit) + integer,intent(out) :: unit + unit=8 + end subroutine +end module + +module m2 + use iso_c_binding + use m1 + implicit none + contains + subroutine c_odopen(unit) bind(c,name="odopen") + integer(c_int),intent(out) :: unit + call odopen(unit) + end subroutine +end module diff --git a/Fortran/gfortran/regression/bind_c_usage_33_c.c b/Fortran/gfortran/regression/bind_c_usage_33_c.c --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_33_c.c @@ -0,0 +1,15 @@ +#include + +void odopen(int*); + +int main() +{ + int unit = 42; + odopen(&unit); + if (unit != 8) + { + fprintf(stderr,"wrong result"); + return 1; + } + return 0; +} diff --git a/Fortran/gfortran/regression/bind_c_usage_5.f03 b/Fortran/gfortran/regression/bind_c_usage_5.f03 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_5.f03 @@ -0,0 +1,8 @@ +! { dg-do compile } +module bind_c_usage_5 +use, intrinsic :: iso_c_binding + +bind(c) c3, c4 +integer(c_int), bind(c) :: c3 ! { dg-error "Duplicate BIND attribute" } +integer(c_int) :: c4 +end module bind_c_usage_5 diff --git a/Fortran/gfortran/regression/bind_c_usage_6.f03 b/Fortran/gfortran/regression/bind_c_usage_6.f03 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_6.f03 @@ -0,0 +1,48 @@ +! { dg-do compile } +module x + use iso_c_binding + bind(c) :: test, sub1 ! { dg-error "only be used for variables or common blocks" } + bind(c) :: sub2 ! { dg-error "only be used for variables or common blocks" } +contains + function foo() bind(c,name="xx") + integer(c_int),bind(c,name="xy") :: foo ! { dg-error "only be used for variables or common blocks" } + ! NAG f95: "BIND(C) for non-variable FOO" + ! g95: "Duplicate BIND attribute specified" + ! gfortran: Accepted + foo = 5_c_int + end function foo + + function test() + integer(c_int) :: test + bind(c,name="kk") :: test ! { dg-error "only be used for variables or common blocks" } + ! NAG f95: "BIND(C) for non-variable TEST" + ! gfortran, g95: Accepted + test = 5_c_int + end function test + + function bar() bind(c) + integer(c_int) :: bar + bind(c,name="zx") :: bar ! { dg-error "only be used for variables or common blocks" } + bar = 5_c_int + end function bar + + subroutine sub0() bind(c) + bind(c) :: sub0 ! { dg-error "only be used for variables or common blocks" } + end subroutine sub0 + + subroutine sub1(i) bind(c) + use, intrinsic :: iso_c_binding, only: c_int + integer(c_int), value :: i + end subroutine sub1 + + subroutine sub2(i) + use, intrinsic :: iso_c_binding, only: c_int + integer(c_int), value :: i + end subroutine sub2 + + subroutine sub3(i) + use, intrinsic :: iso_c_binding, only: c_int + integer(c_int), value :: i + bind(c) :: sub3 ! { dg-error "only be used for variables or common blocks" } + end subroutine sub3 +end module x diff --git a/Fortran/gfortran/regression/bind_c_usage_7.f03 b/Fortran/gfortran/regression/bind_c_usage_7.f03 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_7.f03 @@ -0,0 +1,14 @@ +! { dg-do compile } +module x + use iso_c_binding + implicit none +contains + function bar() bind(c) ! { dg-error "cannot be an array" } + integer(c_int) :: bar(5) + end function bar + + function my_string_func() bind(c) ! { dg-error "must have length 1" } + character(kind=c_char, len=10) :: my_string_func + my_string_func = 'my_string' // C_NULL_CHAR + end function my_string_func +end module x diff --git a/Fortran/gfortran/regression/bind_c_usage_8.f03 b/Fortran/gfortran/regression/bind_c_usage_8.f03 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_8.f03 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-Wc-binding-type" } +! { dg-require-visibility "" } +! This should compile, though there is a warning about the type of len +! (return variable of strlen()) for being implicit. +! PR fortran/32797 +! +MODULE ISO_C_UTILITIES + USE ISO_C_BINDING + implicit none + CHARACTER(C_CHAR), DIMENSION(1), SAVE, TARGET, PRIVATE :: dummy_string="?" +CONTAINS + FUNCTION C_F_STRING(CPTR) RESULT(FPTR) + use, intrinsic :: iso_c_binding + TYPE(C_PTR), INTENT(IN) :: CPTR ! The C address + CHARACTER(KIND=C_CHAR), DIMENSION(:), POINTER :: FPTR + INTERFACE + FUNCTION strlen(string) RESULT(len) BIND(C,NAME="strlen") ! { dg-warning "Implicitly declared" } + USE ISO_C_BINDING + TYPE(C_PTR), VALUE :: string ! A C pointer + END FUNCTION + END INTERFACE + CALL C_F_POINTER(FPTR=FPTR, CPTR=CPTR, SHAPE=[strlen(CPTR)]) + END FUNCTION +END MODULE ISO_C_UTILITIES diff --git a/Fortran/gfortran/regression/bind_c_usage_9.f03 b/Fortran/gfortran/regression/bind_c_usage_9.f03 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_usage_9.f03 @@ -0,0 +1,47 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! PR fortran/34133 +! +! The compiler should reject internal procedures with BIND(c) attribute +! for Fortran 2003. +! +subroutine foo() bind(c) +contains ! { dg-error "Fortran 2008: CONTAINS statement" } + subroutine bar() bind (c) ! { dg-error "may not be specified for an internal" } + end subroutine bar ! { dg-error "Expected label" } +end subroutine foo + +subroutine foo2() bind(c) + use iso_c_binding +contains ! { dg-error "Fortran 2008: CONTAINS statement" } + integer(c_int) function barbar() bind (c) ! { dg-error "may not be specified for an internal" } + end function barbar ! { dg-error "Expecting END SUBROUTINE" } +end subroutine foo2 + +function one() bind(c) + use iso_c_binding + integer(c_int) :: one + one = 1 +contains ! { dg-error "Fortran 2008: CONTAINS statement" } + integer(c_int) function two() bind (c) ! { dg-error "may not be specified for an internal" } + end function two ! { dg-error "Expected label" } +end function one + +function one2() bind(c) + use iso_c_binding + integer(c_int) :: one2 + one2 = 1 +contains ! { dg-error "Fortran 2008: CONTAINS statement" } + subroutine three() bind (c) ! { dg-error "may not be specified for an internal" } + end subroutine three ! { dg-error "Expecting END FUNCTION statement" } +end function one2 + +program main + use iso_c_binding + implicit none +contains ! { dg-error "Fortran 2008: CONTAINS statement" } + subroutine test() bind(c) ! { dg-error "may not be specified for an internal" } + end subroutine test ! { dg-error "Expecting END PROGRAM" } + integer(c_int) function test2() bind (c) ! { dg-error "may not be specified for an internal" } + end function test2 ! { dg-error "Expecting END PROGRAM" } +end program main diff --git a/Fortran/gfortran/regression/bind_c_vars.f90 b/Fortran/gfortran/regression/bind_c_vars.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_vars.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! { dg-additional-sources bind_c_vars_driver.c } +module bind_c_vars + use, intrinsic :: iso_c_binding + implicit none + + integer(c_int), bind(c) :: myF90Int + real(c_float), bind(c, name="myF90Real") :: f90_real + integer(c_int) :: c2 + integer(c_int) :: c3 + integer(c_int) :: c4 + bind(c, name="myVariable") :: c2 + bind(c) c3, c4 + + integer(c_int), bind(c, name="myF90Array3D") :: A(18, 3:7, 10) + integer(c_int), bind(c, name="myF90Array2D") :: B(3, 2) + +contains + + subroutine changeF90Globals() bind(c, name='changeF90Globals') + implicit none + ! should make it 2 + myF90Int = myF90Int + 1 + ! should make it 3.0 + f90_real = f90_real * 3.0; + ! should make it 4 + c2 = c2 * 2; + ! should make it 6 + c3 = c3 + 3; + ! should make it 2 + c4 = c4 / 2; + ! should make it 2 + A(5, 6, 3) = A(5, 6, 3) + 1 + ! should make it 3 + B(3, 2) = B(3, 2) + 1 + end subroutine changeF90Globals + +end module bind_c_vars diff --git a/Fortran/gfortran/regression/bind_c_vars_driver.c b/Fortran/gfortran/regression/bind_c_vars_driver.c --- /dev/null +++ b/Fortran/gfortran/regression/bind_c_vars_driver.c @@ -0,0 +1,46 @@ +double fabs (double); + +/* defined in fortran module bind_c_vars */ +void changeF90Globals(void); + +extern void abort(void); + +/* module level scope in bind_c_vars */ +extern int myf90int; /* myf90int in bind_c_vars */ +float myF90Real; /* f90_real in bind_c_vars */ +int myF90Array3D[10][5][18]; /* A in bind_c_vars */ +int myF90Array2D[2][3]; /* B in bind_c_vars */ +int myVariable; /* c2 in bind_c_vars */ +int c3; /* c3 in bind_c_vars */ +int c4; /* c4 in bind_c_vars */ + +int main(int argc, char **argv) +{ + myf90int = 1; + myF90Real = 1.0; + myVariable = 2; + c3 = 3; + c4 = 4; + myF90Array3D[2][3][4] = 1; + myF90Array2D[1][2] = 2; + + /* will change the global vars initialized above */ + changeF90Globals(); + + if(myf90int != 2) + abort(); + if(fabs(myF90Real-3.0) > 0.00000000) + abort(); + if(myVariable != 4) + abort(); + if(c3 != 6) + abort(); + if(c4 != 2) + abort(); + if(myF90Array3D[2][3][4] != 2) + abort(); + if(myF90Array2D[1][2] != 3) + abort(); + + return 0; +}/* end main() */ diff --git a/Fortran/gfortran/regression/binding_c_table_15_1.f03 b/Fortran/gfortran/regression/binding_c_table_15_1.f03 --- /dev/null +++ b/Fortran/gfortran/regression/binding_c_table_15_1.f03 @@ -0,0 +1,14 @@ +! { dg-do run } +! Test the named constants in Table 15.1. +program a + use, intrinsic :: iso_c_binding + implicit none + if (C_NULL_CHAR /= CHAR(0) ) STOP 1 + if (C_ALERT /= ACHAR(7) ) STOP 2 + if (C_BACKSPACE /= ACHAR(8) ) STOP 3 + if (C_FORM_FEED /= ACHAR(12)) STOP 4 + if (C_NEW_LINE /= ACHAR(10)) STOP 5 + if (C_CARRIAGE_RETURN /= ACHAR(13)) STOP 6 + if (C_HORIZONTAL_TAB /= ACHAR(9) ) STOP 7 + if (C_VERTICAL_TAB /= ACHAR(11)) STOP 8 +end program a diff --git a/Fortran/gfortran/regression/binding_label_tests.f03 b/Fortran/gfortran/regression/binding_label_tests.f03 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests.f03 @@ -0,0 +1,75 @@ +! { dg-do compile } +module binding_label_tests + use, intrinsic :: iso_c_binding + implicit none + + contains + + subroutine c_sub() BIND(c, name = "C_Sub") + print *, 'hello from c_sub' + end subroutine c_sub + + integer(c_int) function c_func() bind(C, name="__C_funC") + print *, 'hello from c_func' + c_func = 1 + end function c_func + + real(c_float) function f90_func() + print *, 'hello from f90_func' + f90_func = 1.0 + end function f90_func + + real(c_float) function c_real_func() bind(c) + print *, 'hello from c_real_func' + c_real_func = 1.5 + end function c_real_func + + integer function f90_func_0() result ( f90_func_0_result ) + print *, 'hello from f90_func_0' + f90_func_0_result = 0 + end function f90_func_0 + + integer(c_int) function f90_func_1() result ( f90_func_1_result ) bind(c, name="__F90_Func_1__") + print *, 'hello from f90_func_1' + f90_func_1_result = 1 + end function f90_func_1 + + integer(c_int) function f90_func_3() result ( f90_func_3_result ) bind(c) + print *, 'hello from f90_func_3' + f90_func_3_result = 3 + end function f90_func_3 + + integer(c_int) function F90_func_2() bind(c) result ( f90_func_2_result ) + print *, 'hello from f90_func_2' + f90_func_2_result = 2 + end function f90_func_2 + + integer(c_int) function F90_func_4() bind(c, name="F90_func_4") result ( f90_func_4_result ) + print *, 'hello from f90_func_4' + f90_func_4_result = 4 + end function f90_func_4 + + integer(c_int) function F90_func_5() bind(c, name="F90_func_5") result ( f90_func_5_result ) + print *, 'hello from f90_func_5' + f90_func_5_result = 5 + end function f90_func_5 + + subroutine c_sub_2() bind(c, name='c_sub_2') + print *, 'hello from c_sub_2' + end subroutine c_sub_2 + + subroutine c_sub_3() BIND(c, name = " C_Sub_3 ") + print *, 'hello from c_sub_3' + end subroutine c_sub_3 + + subroutine c_sub_5() BIND(c, name = "C_Sub_5 ") + print *, 'hello from c_sub_5' + end subroutine c_sub_5 + + ! nothing between the quotes except spaces, so name="". + ! the name will get set to the regularly mangled version of the name. + ! perhaps it should be marked with some characters that are invalid for + ! C names so C can not call it? + subroutine sub4() BIND(c, name = " ") + end subroutine sub4 +end module binding_label_tests diff --git a/Fortran/gfortran/regression/binding_label_tests_10.f03 b/Fortran/gfortran/regression/binding_label_tests_10.f03 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_10.f03 @@ -0,0 +1,6 @@ +! { dg-do compile } +module binding_label_tests_10 + use iso_c_binding + implicit none + integer(c_int), bind(c,name="c_one") :: one +end module binding_label_tests_10 diff --git a/Fortran/gfortran/regression/binding_label_tests_10_main.f03 b/Fortran/gfortran/regression/binding_label_tests_10_main.f03 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_10_main.f03 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-compile-aux-modules "binding_label_tests_10.f03" } +module binding_label_tests_10_main + use iso_c_binding + implicit none + integer(c_int), bind(c,name="c_one") :: one ! { dg-error "Variable 'one' from module 'binding_label_tests_10' with binding label 'c_one' at .1. uses the same global identifier as entity at .2. from module 'binding_label_tests_10_main'" } +end module binding_label_tests_10_main + +program main + use binding_label_tests_10 ! { dg-error "Variable 'one' from module 'binding_label_tests_10' with binding label 'c_one' at .1. uses the same global identifier as entity at .2. from module 'binding_label_tests_10_main'" } + use binding_label_tests_10_main +end program main diff --git a/Fortran/gfortran/regression/binding_label_tests_11.f03 b/Fortran/gfortran/regression/binding_label_tests_11.f03 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_11.f03 @@ -0,0 +1,10 @@ +! { dg-do compile } +module binding_label_tests_11 + use iso_c_binding, only: c_int + implicit none +contains + function one() bind(c, name="c_one") + integer(c_int) one + one = 1 + end function one +end module binding_label_tests_11 diff --git a/Fortran/gfortran/regression/binding_label_tests_11_main.f03 b/Fortran/gfortran/regression/binding_label_tests_11_main.f03 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_11_main.f03 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-compile-aux-modules "binding_label_tests_11.f03" } +module binding_label_tests_11_main + use iso_c_binding, only: c_int + implicit none +contains + function one() bind(c, name="c_one") ! { dg-error "Procedure 'one' with binding label 'c_one' at .1. uses the same global identifier as entity at .2." } + integer(c_int) one + one = 1 + end function one +end module binding_label_tests_11_main + +program main + use binding_label_tests_11 ! { dg-error "Procedure 'one' with binding label 'c_one' at .1. uses the same global identifier as entity at .2." } + use binding_label_tests_11_main +end program main diff --git a/Fortran/gfortran/regression/binding_label_tests_12.f03 b/Fortran/gfortran/regression/binding_label_tests_12.f03 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_12.f03 @@ -0,0 +1,22 @@ +! { dg-do run } +! This verifies that the compiler will correctly accpet the name="", write out +! an empty string for the binding label to the module file, and then read it +! back in. Also, during gfc_verify_binding_labels, the name="" will prevent +! any verification (since there is no label to verify). +module one +contains + subroutine foo() bind(c) + end subroutine foo +end module one + +module two +contains + ! This procedure is only used accessed in C + ! as procedural pointer + subroutine foo() bind(c, name="") + end subroutine foo +end module two + +use one, only: foo_one => foo +use two, only: foo_two => foo +end diff --git a/Fortran/gfortran/regression/binding_label_tests_13.f03 b/Fortran/gfortran/regression/binding_label_tests_13.f03 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_13.f03 @@ -0,0 +1,6 @@ +! { dg-do compile } +module binding_label_tests_13 + use, intrinsic :: iso_c_binding, only: c_int + integer(c_int) :: c3 + bind(c) c3 +end module binding_label_tests_13 diff --git a/Fortran/gfortran/regression/binding_label_tests_13_main.f03 b/Fortran/gfortran/regression/binding_label_tests_13_main.f03 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_13_main.f03 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-compile-aux-modules "binding_label_tests_13.f03" } +module binding_label_tests_13_main + use, intrinsic :: iso_c_binding, only: c_int + integer(c_int) :: c3 ! { dg-error "Variable 'c3' from module 'binding_label_tests_13_main' with binding label 'c3' at .1. uses the same global identifier as entity at .2. from module 'binding_label_tests_13'" } + bind(c) c3 + +contains + subroutine c_sub() BIND(c, name = "C_Sub") + use binding_label_tests_13 ! { dg-error "Variable 'c3' from module 'binding_label_tests_13_main' with binding label 'c3' at .1. uses the same global identifier as entity at .2. from module 'binding_label_tests_13'" } + end subroutine c_sub +end module binding_label_tests_13_main diff --git a/Fortran/gfortran/regression/binding_label_tests_14.f03 b/Fortran/gfortran/regression/binding_label_tests_14.f03 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_14.f03 @@ -0,0 +1,12 @@ +! { dg-do run } +subroutine display() bind(c) + implicit none +end subroutine display + +program main + implicit none + interface + subroutine display() bind(c) + end subroutine display + end interface +end program main diff --git a/Fortran/gfortran/regression/binding_label_tests_15.f03 b/Fortran/gfortran/regression/binding_label_tests_15.f03 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_15.f03 @@ -0,0 +1,12 @@ +! { dg-do compile } +! Verify that an error is correctly reported if multiple identifiers are given +! with a bind(c) statement that has a NAME= specifier. +module m + use iso_c_binding + implicit none + integer(c_int), bind(C, name="") :: a,b ! { dg-error "Multiple identifiers" } + integer(c_int), bind(C, name="bob") :: c,d ! { dg-error "Multiple identifiers" } + integer(c_int) :: e,f + bind(c, name="foo") :: e,f ! { dg-error "Multiple identifiers" } +end module m + diff --git a/Fortran/gfortran/regression/binding_label_tests_16.f03 b/Fortran/gfortran/regression/binding_label_tests_16.f03 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_16.f03 @@ -0,0 +1,21 @@ +! { dg-do run } +! Verify that the variables 'a' in both modules don't collide. +module m + use iso_c_binding + implicit none + integer(c_int), save, bind(C, name="") :: a = 5 +end module m + +module n + use iso_c_binding + implicit none + integer(c_int), save, bind(C,name="") :: a = -5 +end module n + +program prog +use m +use n, b=>a +implicit none + print *, a, b + if (a /= 5 .or. b /= -5) STOP 1 +end program prog diff --git a/Fortran/gfortran/regression/binding_label_tests_17.f90 b/Fortran/gfortran/regression/binding_label_tests_17.f90 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_17.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! PR fortran/48858 +! +subroutine foo() bind(C, name="bar") ! { dg-error "Global binding name 'bar' at .1. is already being used as a SUBROUTINE at .2." } +end subroutine foo + +subroutine sub() bind(C, name="bar") ! { dg-error "Global binding name 'bar' at .1. is already being used as a SUBROUTINE at .2." } +end subroutine sub + diff --git a/Fortran/gfortran/regression/binding_label_tests_18.f90 b/Fortran/gfortran/regression/binding_label_tests_18.f90 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_18.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! PR fortran/48858 +! +subroutine foo() ! { dg-error "Global name 'foo' at .1. is already being used as a SUBROUTINE at .2." } +end subroutine foo + +subroutine foo() ! { dg-error "Global name 'foo' at .1. is already being used as a SUBROUTINE at .2." } +end subroutine foo + diff --git a/Fortran/gfortran/regression/binding_label_tests_19.f90 b/Fortran/gfortran/regression/binding_label_tests_19.f90 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_19.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! PR fortran/48858 +! +subroutine foo() bind(C,name="bar") +end subroutine foo + +subroutine foo() bind(C,name="sub") +end subroutine foo + diff --git a/Fortran/gfortran/regression/binding_label_tests_2.f03 b/Fortran/gfortran/regression/binding_label_tests_2.f03 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_2.f03 @@ -0,0 +1,36 @@ +! { dg-do compile } +module binding_label_tests_2 + +contains + ! this is just here so at least one of the subroutines will be accepted so + ! gfortran doesn't give an Extension warning when using -pedantic-errors + subroutine ok() + end subroutine ok + + subroutine sub0() bind(c, name=" 1") ! { dg-error "Invalid C identifier" } + end subroutine sub0 ! { dg-error "Expecting END MODULE" } + + subroutine sub1() bind(c, name="$") + end subroutine sub1 + + subroutine sub2() bind(c, name="abc$") + end subroutine sub2 + + subroutine sub3() bind(c, name="abc d") ! { dg-error "Invalid C identifier" } + end subroutine sub3 ! { dg-error "Expecting END MODULE" } + + subroutine sub4() bind(c, name="2foo") ! { dg-error "Invalid C identifier" } + end subroutine sub4 ! { dg-error "Expecting END MODULE" } + + subroutine sub5() BIND(C, name=" myvar 2 ") ! { dg-error "Invalid C identifier" } + end subroutine sub5 ! { dg-error "Expecting END MODULE" } + + subroutine sub6() bind(c, name=" ) ! { dg-error "Invalid C identifier" } + end subroutine sub6 ! { dg-error "Expecting END MODULE" } + + subroutine sub7() bind(c, name=) ! { dg-error "Invalid character" } + end subroutine sub7 ! { dg-error "Expecting END MODULE" } + + subroutine sub8() bind(c, name) ! { dg-error "Syntax error" } + end subroutine sub8 ! { dg-error "Expecting END MODULE" } +end module binding_label_tests_2 diff --git a/Fortran/gfortran/regression/binding_label_tests_20.f90 b/Fortran/gfortran/regression/binding_label_tests_20.f90 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_20.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/48858 +! +subroutine foo() bind(C,name="bar") ! { dg-error "Global name 'foo' at .1. is already being used as a SUBROUTINE at .2." } +end subroutine foo + +subroutine foo() bind(C,name="sub") ! { dg-error "Global name 'foo' at .1. is already being used as a SUBROUTINE at .2." } +end subroutine foo + diff --git a/Fortran/gfortran/regression/binding_label_tests_21.f90 b/Fortran/gfortran/regression/binding_label_tests_21.f90 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_21.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! +! PR fortran/48858 +! +subroutine foo() bind(C, name="bar") ! { dg-error "Global binding name 'bar' at .1. is already being used as a SUBROUTINE at .2." } +entry sub() bind(C, name="bar") ! { dg-error "Global binding name 'bar' at .1. is already being used as a SUBROUTINE at .2." } +end subroutine foo + diff --git a/Fortran/gfortran/regression/binding_label_tests_22.f90 b/Fortran/gfortran/regression/binding_label_tests_22.f90 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_22.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! +! PR fortran/48858 +! +subroutine foo() ! { dg-error "Global name 'foo' at .1. is already being used as a SUBROUTINE at .2." } +entry foo() ! { dg-error "Global name 'foo' at .1. is already being used as a SUBROUTINE at .2." } +end subroutine foo + diff --git a/Fortran/gfortran/regression/binding_label_tests_23.f90 b/Fortran/gfortran/regression/binding_label_tests_23.f90 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_23.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! +! PR fortran/48858 +! +integer function foo(x) + integer :: x + STOP 1 + foo = 99 +end function foo + +integer function other() bind(C, name="bar") + other = 42 +end function other + +program test + interface + integer function foo() bind(C, name="bar") + end function foo + end interface + if (foo() /= 42) STOP 2 ! Ensure that the binding name is all what counts +end program test diff --git a/Fortran/gfortran/regression/binding_label_tests_24.f90 b/Fortran/gfortran/regression/binding_label_tests_24.f90 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_24.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR fortran/48858 +! PR fortran/55465 +! +! Was rejected before but it perfectly valid +! +module m + interface + subroutine f() bind(C, name="func") + end subroutine + end interface +contains + subroutine sub() + call f() + end subroutine +end module m + +module m2 + interface + subroutine g() bind(C, name="func") + end subroutine + end interface +contains + subroutine sub2() + call g() + end subroutine +end module m2 diff --git a/Fortran/gfortran/regression/binding_label_tests_25.f90 b/Fortran/gfortran/regression/binding_label_tests_25.f90 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_25.f90 @@ -0,0 +1,61 @@ +! { dg-do compile } +! +! PR fortran/48858 +! PR fortran/55465 +! +! Seems to be regarded as valid, even if it is doubtful +! + + +module m_odbc_if + implicit none + + interface sql_set_env_attr + function sql_set_env_attr_int( input_handle,attribute,value,length ) & + result(res) bind(C,name="SQLSetEnvAttr") + use, intrinsic :: iso_c_binding + implicit none + type(c_ptr), value :: input_handle + integer(c_int), value :: attribute + integer(c_int), value :: value ! <<<< HERE: int passed by value (int with ptr address) + integer(c_int), value :: length + integer(c_short) :: res + end function + function sql_set_env_attr_ptr( input_handle,attribute,value,length ) & + result(res) bind(C,name="SQLSetEnvAttr") + use, intrinsic :: iso_c_binding + implicit none + type(c_ptr), value :: input_handle + integer(c_int), value :: attribute + type(c_ptr), value :: value ! <<< HERE: "void *" (pointer address) + integer(c_int), value :: length + integer(c_short) :: res + end function + end interface +end module + +module graph_partitions + use,intrinsic :: iso_c_binding + + interface Cfun + subroutine cfunc1 (num, array) bind(c, name="Cfun") + import :: c_int + integer(c_int),value :: num + integer(c_int) :: array(*) ! <<< HERE: int[] + end subroutine cfunc1 + + subroutine cfunf2 (num, array) bind(c, name="Cfun") + import :: c_int, c_ptr + integer(c_int),value :: num + type(c_ptr),value :: array ! <<< HERE: void* + end subroutine cfunf2 + end interface +end module graph_partitions + +program test + use graph_partitions + integer(c_int) :: a(100) + + call Cfun (1, a) + call Cfun (2, C_NULL_PTR) +end program test diff --git a/Fortran/gfortran/regression/binding_label_tests_26a.f90 b/Fortran/gfortran/regression/binding_label_tests_26a.f90 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_26a.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR 58182: [4.9 Regression] ICE with global binding name used as a FUNCTION +! +! Contributed by Andrew Bensons +! + +module fg +contains + function fffi(f) + interface + function f() bind(c) + end function + end interface + end function +end module diff --git a/Fortran/gfortran/regression/binding_label_tests_26b.f90 b/Fortran/gfortran/regression/binding_label_tests_26b.f90 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_26b.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-compile-aux-modules "binding_label_tests_26a.f90" } +! +! PR 58182: [4.9 Regression] ICE with global binding name used as a FUNCTION +! +! Contributed by Andrew Bensons + +module f ! { dg-error "uses the same global identifier" } + use fg ! { dg-error "uses the same global identifier" } +end module + +! { dg-final { cleanup-modules "fg f" } } diff --git a/Fortran/gfortran/regression/binding_label_tests_27.f90 b/Fortran/gfortran/regression/binding_label_tests_27.f90 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_27.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } + +module p + + implicit none + integer i1, i2, i3, i4, i5, i6, i7, i8, i9, i10 + + character(len=*), parameter :: s = "toto" + character(len=*), parameter :: t(2) = ["x", "y"] + + bind(c,name=" foo ") :: i1 + bind(c, name=trim("Hello ") // "There") :: i2 + bind(c, name=1_"name") :: i3 + bind(c, name=4_"") :: i4 ! { dg-error "scalar of default character kind" } + bind(c, name=1) :: i5 ! { dg-error "scalar of default character kind" } + bind(c, name=1.0) :: i6 ! { dg-error "scalar of default character kind" } + bind(c, name=["","",""]) :: i7 ! { dg-error "scalar of default character kind" } + bind(c, name=s) :: i8 + bind(c, name=t(2)) :: i9 + +end module + +subroutine foobar(s) + character(len=*) :: s + integer :: i + bind(c, name=s) :: i ! { dg-error "constant expression" } +end subroutine diff --git a/Fortran/gfortran/regression/binding_label_tests_28.f90 b/Fortran/gfortran/regression/binding_label_tests_28.f90 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_28.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! +! PR fortran/61450 +! Contributed by Francois-Xavier Coudert +! +module p + integer i1 ! { dg-error "Global binding name 'foo' at .1. is already being used at .2." } + bind(c,name="foo") :: i1 +end module + +subroutine truc() bind(c,name="foo") ! { dg-error "Global binding name 'foo' at .1. is already being used at .2." } +end diff --git a/Fortran/gfortran/regression/binding_label_tests_29.f90 b/Fortran/gfortran/regression/binding_label_tests_29.f90 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_29.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR53478 + +module test_bug ! { dg-error "Procedure 'test' with binding label 'Test_Bug' at .1. uses the same global identifier as entity at .2." } + +use, intrinsic :: ISO_C_BINDING + +contains + + subroutine test() bind (C, name = "Test_Bug") ! { dg-error "Procedure 'test' with binding label 'Test_Bug' at .1. uses the same global identifier as entity at .2." } + end subroutine + +end module diff --git a/Fortran/gfortran/regression/binding_label_tests_3.f03 b/Fortran/gfortran/regression/binding_label_tests_3.f03 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_3.f03 @@ -0,0 +1,30 @@ +! { dg-do compile } +program main +use iso_c_binding + interface + subroutine p1(f, a1, a2, a3, a4) bind(c, name='printf') ! Doubtful use ... + import :: c_ptr, c_int, c_double + type(c_ptr), value :: f + integer(c_int), value :: a1, a3 + real(c_double), value :: a2, a4 + end subroutine p1 + + subroutine p2(f, a1, a2, a3, a4) bind(c, name='printf') ! ... with incompatible interfaces + import :: c_ptr, c_int, c_double + type(c_ptr), value :: f + real(c_double), value :: a1, a3 + integer(c_int), value :: a2, a4 + end subroutine p2 + end interface + + type(c_ptr) :: f_ptr + character(len=20), target :: format + + f_ptr = c_loc(format(1:1)) + + format = 'Hello %d %f %d %f\n' // char(0) + call p1(f_ptr, 10, 1.23d0, 20, 2.46d0) + + format = 'World %f %d %f %d\n' // char(0) + call p2(f_ptr, 1.23d0, 10, 2.46d0, 20) +end program main diff --git a/Fortran/gfortran/regression/binding_label_tests_30.f90 b/Fortran/gfortran/regression/binding_label_tests_30.f90 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_30.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! Make sure this error is flagged. +subroutine foo() ! { dg-error "is already being used as a SUBROUTINE" } +end subroutine foo + +subroutine bar() bind(C,name="foo") ! { dg-error "is already being used as a SUBROUTINE" } +end subroutine bar diff --git a/Fortran/gfortran/regression/binding_label_tests_31.f90 b/Fortran/gfortran/regression/binding_label_tests_31.f90 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_31.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! PR fortran/66695 - this used to ICE. +! Original test case by Vladimir Fuka. +module mod + implicit none +contains + integer function F() + end function +end module + +module mod_C + use mod + implicit none +contains + subroutine s() bind(C, name="f") + integer :: x + x = F() + end subroutine +end module diff --git a/Fortran/gfortran/regression/binding_label_tests_32.f90 b/Fortran/gfortran/regression/binding_label_tests_32.f90 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_32.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! PR 77746 - this used to crash during execution. +! Original test case by Vladimir Fuka. +module first + private + public execute + + interface execute + module procedure random_name + end interface + +contains + + subroutine random_name() + end subroutine +end module + +module test + use first + + implicit none + +contains + + subroutine p_execute(i) bind(C, name="random_name") + integer :: i + + call execute() + end subroutine + +end module + + use test + call p_execute(1) +end diff --git a/Fortran/gfortran/regression/binding_label_tests_33.f90 b/Fortran/gfortran/regression/binding_label_tests_33.f90 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_33.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! PR 79485 - used to crash because the wrong routine was called. +module fmod1 + + contains + + subroutine foo(i) + implicit none + + integer, intent(inout) :: i + + i=i+1 + + end subroutine foo + +end module fmod1 + +module fmod2 + use iso_c_binding + use fmod1, only : foo_first => foo + + contains + + subroutine foo(i) bind(c) + implicit none + + integer, intent(inout) :: i + + i=i+2 + call foo_first(i) + + end subroutine foo + +end module fmod2 + + use fmod2 + + call foo(i) +end diff --git a/Fortran/gfortran/regression/binding_label_tests_34.f90 b/Fortran/gfortran/regression/binding_label_tests_34.f90 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_34.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! PR 94737 - global symbols are case-insensitive; an error should be +! reported if they match (see F2018, 9.2, paragraph 2). Original +! test case by Lee Busby. + +module foo + +interface +function func1(ii) result (k) bind(c, name="c_func") + integer :: ii + integer :: k +end function func1 +subroutine sub1(ii,jj) bind(c, name="c_Func") ! { dg-error "Global binding name" } + integer :: ii,jj +end subroutine sub1 +end interface + +contains + +function func2(ii) result (k) + integer :: ii + integer :: k + k = func1(ii) ! { dg-error "Global binding name" } +end function func2 +end module foo diff --git a/Fortran/gfortran/regression/binding_label_tests_4.f03 b/Fortran/gfortran/regression/binding_label_tests_4.f03 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_4.f03 @@ -0,0 +1,23 @@ +! { dg-do compile } +module A + use, intrinsic :: iso_c_binding +contains + subroutine pA() bind(c, name='printf') ! { dg-error "Procedure 'pb' with binding label 'printf' at .1. uses the same global identifier as entity at .2." } + print *, 'hello from pA' + end subroutine pA +end module A + +module B + use, intrinsic :: iso_c_binding + +contains + subroutine pB() bind(c, name='printf') ! { dg-error "Procedure 'pb' with binding label 'printf' at .1. uses the same global identifier as entity at .2." } + print *, 'hello from pB' + end subroutine pB +end module B + +module C +use A +use B ! { dg-error "Cannot open module file" } +end module C +! { dg-prune-output "compilation terminated" } diff --git a/Fortran/gfortran/regression/binding_label_tests_5.f03 b/Fortran/gfortran/regression/binding_label_tests_5.f03 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_5.f03 @@ -0,0 +1,12 @@ +! { dg-do compile } +module binding_label_tests_5 + use, intrinsic :: iso_c_binding + + interface + subroutine sub0() bind(c, name='c_sub') ! Odd declaration but perfectly valid + end subroutine sub0 + + subroutine sub1() bind(c, name='c_sub') ! Ditto. + end subroutine sub1 + end interface +end module binding_label_tests_5 diff --git a/Fortran/gfortran/regression/binding_label_tests_6.f03 b/Fortran/gfortran/regression/binding_label_tests_6.f03 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_6.f03 @@ -0,0 +1,6 @@ +! { dg-do compile } +module binding_label_tests_6 + use, intrinsic :: iso_c_binding + integer(c_int), bind(c, name='my_int') :: my_f90_int_1 ! { dg-error "Variable 'my_f90_int_2' from module 'binding_label_tests_6' with binding label 'my_int' at .1. uses the same global identifier as entity at .2. from module 'binding_label_tests_6'" } + integer(c_int), bind(c, name='my_int') :: my_f90_int_2 ! { dg-error "Variable 'my_f90_int_2' from module 'binding_label_tests_6' with binding label 'my_int' at .1. uses the same global identifier as entity at .2. from module 'binding_label_tests_6'" } +end module binding_label_tests_6 diff --git a/Fortran/gfortran/regression/binding_label_tests_7.f03 b/Fortran/gfortran/regression/binding_label_tests_7.f03 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_7.f03 @@ -0,0 +1,15 @@ +! { dg-do compile } +module A + use, intrinsic :: iso_c_binding, only: c_int + integer(c_int), bind(c, name='my_c_print') :: my_int ! { dg-error "Procedure 'my_c_print' with binding label 'my_c_print' at .1. uses the same global identifier as entity at .2." } +end module A + +program main +use A +interface + subroutine my_c_print() bind(c) ! { dg-error "Procedure 'my_c_print' with binding label 'my_c_print' at .1. uses the same global identifier as entity at .2." } + end subroutine my_c_print +end interface + +call my_c_print() +end program main diff --git a/Fortran/gfortran/regression/binding_label_tests_8.f03 b/Fortran/gfortran/regression/binding_label_tests_8.f03 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_8.f03 @@ -0,0 +1,9 @@ +! { dg-do compile } +module binding_label_tests_8 + use, intrinsic :: iso_c_binding, only: c_int + integer(c_int), bind(c, name='my_f90_sub') :: my_c_int ! { dg-error "Variable 'my_c_int' with binding label 'my_f90_sub' at .1. uses the same global identifier as entity at .2." } + +contains + subroutine my_f90_sub() bind(c) ! { dg-error "Variable 'my_c_int' with binding label 'my_f90_sub' at .1. uses the same global identifier as entity at .2." } + end subroutine my_f90_sub +end module binding_label_tests_8 diff --git a/Fortran/gfortran/regression/binding_label_tests_9.f03 b/Fortran/gfortran/regression/binding_label_tests_9.f03 --- /dev/null +++ b/Fortran/gfortran/regression/binding_label_tests_9.f03 @@ -0,0 +1,21 @@ +! { dg-do compile } +module x + use iso_c_binding + implicit none + private :: bar + private :: my_private_sub + private :: my_private_sub_2 + public :: my_public_sub +contains + subroutine bar() bind(c,name="foo") ! { dg-warning "PRIVATE but has been given the binding label" } + end subroutine bar + + subroutine my_private_sub() bind(c, name="") + end subroutine my_private_sub + + subroutine my_private_sub_2() bind(c) ! { dg-warning "PRIVATE but has been given the binding label" } + end subroutine my_private_sub_2 + + subroutine my_public_sub() bind(c, name="my_sub") + end subroutine my_public_sub +end module x diff --git a/Fortran/gfortran/regression/bit_comparison_1.F90 b/Fortran/gfortran/regression/bit_comparison_1.F90 --- /dev/null +++ b/Fortran/gfortran/regression/bit_comparison_1.F90 @@ -0,0 +1,153 @@ +! Test the BGE, BGT, BLE and BLT intrinsics. +! +! { dg-do run } +! { dg-options "-ffree-line-length-none" } + + interface run_bge + procedure run_bge1 + procedure run_bge2 + procedure run_bge4 + procedure run_bge8 + end interface + + interface run_bgt + procedure run_bgt1 + procedure run_bgt2 + procedure run_bgt4 + procedure run_bgt8 + end interface + + interface run_ble + procedure run_ble1 + procedure run_ble2 + procedure run_ble4 + procedure run_ble8 + end interface + + interface run_blt + procedure run_blt1 + procedure run_blt2 + procedure run_blt4 + procedure run_blt8 + end interface + +#define CHECK(I,J,RES) \ + if (bge(I,J) .neqv. RES) STOP 1; \ + if (run_bge(I,J) .neqv. RES) STOP 2; \ + if (bgt(I,J) .neqv. (RES .and. (I/=J))) STOP 3; \ + if (run_bgt(I,J) .neqv. (RES .and. (I/=J))) STOP 4; \ + if (ble(J,I) .neqv. RES) STOP 5; \ + if (run_ble(J,I) .neqv. RES) STOP 6; \ + if (blt(J,I) .neqv. (RES .and. (I/=J))) STOP 7; \ + if (run_blt(J,I) .neqv. (RES .and. (I/=J))) STOP 8 + +#define T .true. +#define F .false. + + CHECK(0_1, 0_1, T) + CHECK(1_1, 0_1, T) + CHECK(0_1, 107_1, F) + CHECK(5_1, huge(0_1) / 2_1, F) + CHECK(5_1, huge(0_1), F) + CHECK(-1_1, 0_1, T) + CHECK(0_1, -19_1, F) + CHECK(huge(0_1), -19_1, F) + + CHECK(0_2, 0_2, T) + CHECK(1_2, 0_2, T) + CHECK(0_2, 107_2, F) + CHECK(5_2, huge(0_2) / 2_2, F) + CHECK(5_2, huge(0_2), F) + CHECK(-1_2, 0_2, T) + CHECK(0_2, -19_2, F) + CHECK(huge(0_2), -19_2, F) + + CHECK(0_4, 0_4, T) + CHECK(1_4, 0_4, T) + CHECK(0_4, 107_4, F) + CHECK(5_4, huge(0_4) / 2_4, F) + CHECK(5_4, huge(0_4), F) + CHECK(-1_4, 0_4, T) + CHECK(0_4, -19_4, F) + CHECK(huge(0_4), -19_4, F) + + CHECK(0_8, 0_8, T) + CHECK(1_8, 0_8, T) + CHECK(0_8, 107_8, F) + CHECK(5_8, huge(0_8) / 2_8, F) + CHECK(5_8, huge(0_8), F) + CHECK(-1_8, 0_8, T) + CHECK(0_8, -19_8, F) + CHECK(huge(0_8), -19_8, F) + +contains + + pure logical function run_bge1 (i, j) result(res) + integer(kind=1), intent(in) :: i, j + res = bge(i,j) + end function + pure logical function run_bgt1 (i, j) result(res) + integer(kind=1), intent(in) :: i, j + res = bgt(i,j) + end function + pure logical function run_ble1 (i, j) result(res) + integer(kind=1), intent(in) :: i, j + res = ble(i,j) + end function + pure logical function run_blt1 (i, j) result(res) + integer(kind=1), intent(in) :: i, j + res = blt(i,j) + end function + + pure logical function run_bge2 (i, j) result(res) + integer(kind=2), intent(in) :: i, j + res = bge(i,j) + end function + pure logical function run_bgt2 (i, j) result(res) + integer(kind=2), intent(in) :: i, j + res = bgt(i,j) + end function + pure logical function run_ble2 (i, j) result(res) + integer(kind=2), intent(in) :: i, j + res = ble(i,j) + end function + pure logical function run_blt2 (i, j) result(res) + integer(kind=2), intent(in) :: i, j + res = blt(i,j) + end function + + pure logical function run_bge4 (i, j) result(res) + integer(kind=4), intent(in) :: i, j + res = bge(i,j) + end function + pure logical function run_bgt4 (i, j) result(res) + integer(kind=4), intent(in) :: i, j + res = bgt(i,j) + end function + pure logical function run_ble4 (i, j) result(res) + integer(kind=4), intent(in) :: i, j + res = ble(i,j) + end function + pure logical function run_blt4 (i, j) result(res) + integer(kind=4), intent(in) :: i, j + res = blt(i,j) + end function + + pure logical function run_bge8 (i, j) result(res) + integer(kind=8), intent(in) :: i, j + res = bge(i,j) + end function + pure logical function run_bgt8 (i, j) result(res) + integer(kind=8), intent(in) :: i, j + res = bgt(i,j) + end function + pure logical function run_ble8 (i, j) result(res) + integer(kind=8), intent(in) :: i, j + res = ble(i,j) + end function + pure logical function run_blt8 (i, j) result(res) + integer(kind=8), intent(in) :: i, j + res = blt(i,j) + end function + +end diff --git a/Fortran/gfortran/regression/bit_comparison_2.F90 b/Fortran/gfortran/regression/bit_comparison_2.F90 --- /dev/null +++ b/Fortran/gfortran/regression/bit_comparison_2.F90 @@ -0,0 +1,48 @@ +! Test the BGE, BGT, BLE and BLT intrinsics. +! +! { dg-do run } +! { dg-options "-ffree-line-length-none" } +! { dg-require-effective-target fortran_integer_16 } + +#define CHECK(I,J,RES) \ + if (bge(I,J) .neqv. RES) STOP 1; \ + if (run_bge(I,J) .neqv. RES) STOP 2; \ + if (bgt(I,J) .neqv. (RES .and. (I/=J))) STOP 3; \ + if (run_bgt(I,J) .neqv. (RES .and. (I/=J))) STOP 4; \ + if (ble(J,I) .neqv. RES) STOP 5; \ + if (run_ble(J,I) .neqv. RES) STOP 6; \ + if (blt(J,I) .neqv. (RES .and. (I/=J))) STOP 7; \ + if (run_blt(J,I) .neqv. (RES .and. (I/=J))) STOP 8 + +#define T .true. +#define F .false. + + CHECK(0_16, 0_16, T) + CHECK(1_16, 0_16, T) + CHECK(0_16, 107_16, F) + CHECK(5_16, huge(0_16) / 2_16, F) + CHECK(5_16, huge(0_16), F) + CHECK(-1_16, 0_16, T) + CHECK(0_16, -19_16, F) + CHECK(huge(0_16), -19_16, F) + +contains + + pure logical function run_bge (i, j) result(res) + integer(kind=16), intent(in) :: i, j + res = bge(i,j) + end function + pure logical function run_bgt (i, j) result(res) + integer(kind=16), intent(in) :: i, j + res = bgt(i,j) + end function + pure logical function run_ble (i, j) result(res) + integer(kind=16), intent(in) :: i, j + res = ble(i,j) + end function + pure logical function run_blt (i, j) result(res) + integer(kind=16), intent(in) :: i, j + res = blt(i,j) + end function + +end diff --git a/Fortran/gfortran/regression/blas_gemm_routines.f b/Fortran/gfortran/regression/blas_gemm_routines.f --- /dev/null +++ b/Fortran/gfortran/regression/blas_gemm_routines.f @@ -0,0 +1,1955 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +*> \brief \b CGEMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,M,N +* CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. +* COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CGEMM performs one of the matrix-matrix operations +*> +*> C := alpha*op( A )*op( B ) + beta*C, +*> +*> where op( X ) is one of +*> +*> op( X ) = X or op( X ) = X**T or op( X ) = X**H, +*> +*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) +*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n', op( A ) = A. +*> +*> TRANSA = 'T' or 't', op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c', op( A ) = A**H. +*> \endverbatim +*> +*> \param[in] TRANSB +*> \verbatim +*> TRANSB is CHARACTER*1 +*> On entry, TRANSB specifies the form of op( B ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSB = 'N' or 'n', op( B ) = B. +*> +*> TRANSB = 'T' or 't', op( B ) = B**T. +*> +*> TRANSB = 'C' or 'c', op( B ) = B**H. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix +*> op( A ) and of the matrix C. M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix +*> op( B ) and the number of columns of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry, K specifies the number of columns of the matrix +*> op( A ) and the number of rows of the matrix op( B ). K must +*> be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension ( LDA, ka ), where ka is +*> k when TRANSA = 'N' or 'n', and is m otherwise. +*> Before entry with TRANSA = 'N' or 'n', the leading m by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by m part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANSA = 'N' or 'n' then +*> LDA must be at least max( 1, m ), otherwise LDA must be at +*> least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is COMPLEX array, dimension ( LDB, kb ), where kb is +*> n when TRANSB = 'N' or 'n', and is k otherwise. +*> Before entry with TRANSB = 'N' or 'n', the leading k by n +*> part of the array B must contain the matrix B, otherwise +*> the leading n by k part of the array B must contain the +*> matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. When TRANSB = 'N' or 'n' then +*> LDB must be at least max( 1, k ), otherwise LDB must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX array, dimension ( LDC, N ) +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n matrix +*> ( alpha*op( A )*op( B ) + beta*C ). +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex_blas_level3 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE CGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* -- Reference BLAS level3 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + COMPLEX ALPHA,BETA + INTEGER K,LDA,LDB,LDC,M,N + CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. + COMPLEX A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX TEMP + INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB + LOGICAL CONJA,CONJB,NOTA,NOTB +* .. +* .. Parameters .. + COMPLEX ONE + PARAMETER (ONE= (1.0E+0,0.0E+0)) + COMPLEX ZERO + PARAMETER (ZERO= (0.0E+0,0.0E+0)) +* .. +* +* Set NOTA and NOTB as true if A and B respectively are not +* conjugated or transposed, set CONJA and CONJB as true if A and +* B respectively are to be transposed but not conjugated and set +* NROWA, NCOLA and NROWB as the number of rows and columns of A +* and the number of rows of B respectively. +* + NOTA = LSAME(TRANSA,'N') + NOTB = LSAME(TRANSB,'N') + CONJA = LSAME(TRANSA,'C') + CONJB = LSAME(TRANSB,'C') + IF (NOTA) THEN + NROWA = M + NCOLA = K + ELSE + NROWA = K + NCOLA = M + END IF + IF (NOTB) THEN + NROWB = K + ELSE + NROWB = N + END IF +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT.NOTA) .AND. (.NOT.CONJA) .AND. + + (.NOT.LSAME(TRANSA,'T'))) THEN + INFO = 1 + ELSE IF ((.NOT.NOTB) .AND. (.NOT.CONJB) .AND. + + (.NOT.LSAME(TRANSB,'T'))) THEN + INFO = 2 + ELSE IF (M.LT.0) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 8 + ELSE IF (LDB.LT.MAX(1,NROWB)) THEN + INFO = 10 + ELSE IF (LDC.LT.MAX(1,M)) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('CGEMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,M + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (NOTB) THEN + IF (NOTA) THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 50 I = 1,M + C(I,J) = ZERO + 50 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 60 I = 1,M + C(I,J) = BETA*C(I,J) + 60 CONTINUE + END IF + DO 80 L = 1,K + TEMP = ALPHA*B(L,J) + DO 70 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + ELSE IF (CONJA) THEN +* +* Form C := alpha*A**H*B + beta*C. +* + DO 120 J = 1,N + DO 110 I = 1,M + TEMP = ZERO + DO 100 L = 1,K + TEMP = TEMP + CONJG(A(L,I))*B(L,J) + 100 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 110 CONTINUE + 120 CONTINUE + ELSE +* +* Form C := alpha*A**T*B + beta*C +* + DO 150 J = 1,N + DO 140 I = 1,M + TEMP = ZERO + DO 130 L = 1,K + TEMP = TEMP + A(L,I)*B(L,J) + 130 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 140 CONTINUE + 150 CONTINUE + END IF + ELSE IF (NOTA) THEN + IF (CONJB) THEN +* +* Form C := alpha*A*B**H + beta*C. +* + DO 200 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 160 I = 1,M + C(I,J) = ZERO + 160 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 170 I = 1,M + C(I,J) = BETA*C(I,J) + 170 CONTINUE + END IF + DO 190 L = 1,K + TEMP = ALPHA*CONJG(B(J,L)) + DO 180 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE + ELSE +* +* Form C := alpha*A*B**T + beta*C +* + DO 250 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 210 I = 1,M + C(I,J) = ZERO + 210 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 220 I = 1,M + C(I,J) = BETA*C(I,J) + 220 CONTINUE + END IF + DO 240 L = 1,K + TEMP = ALPHA*B(J,L) + DO 230 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + END IF + ELSE IF (CONJA) THEN + IF (CONJB) THEN +* +* Form C := alpha*A**H*B**H + beta*C. +* + DO 280 J = 1,N + DO 270 I = 1,M + TEMP = ZERO + DO 260 L = 1,K + TEMP = TEMP + CONJG(A(L,I))*CONJG(B(J,L)) + 260 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 270 CONTINUE + 280 CONTINUE + ELSE +* +* Form C := alpha*A**H*B**T + beta*C +* + DO 310 J = 1,N + DO 300 I = 1,M + TEMP = ZERO + DO 290 L = 1,K + TEMP = TEMP + CONJG(A(L,I))*B(J,L) + 290 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 300 CONTINUE + 310 CONTINUE + END IF + ELSE + IF (CONJB) THEN +* +* Form C := alpha*A**T*B**H + beta*C +* + DO 340 J = 1,N + DO 330 I = 1,M + TEMP = ZERO + DO 320 L = 1,K + TEMP = TEMP + A(L,I)*CONJG(B(J,L)) + 320 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 330 CONTINUE + 340 CONTINUE + ELSE +* +* Form C := alpha*A**T*B**T + beta*C +* + DO 370 J = 1,N + DO 360 I = 1,M + TEMP = ZERO + DO 350 L = 1,K + TEMP = TEMP + A(L,I)*B(J,L) + 350 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 360 CONTINUE + 370 CONTINUE + END IF + END IF +* + RETURN +* +* End of CGEMM . +* + END + +*> \brief \b LSAME +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* LOGICAL FUNCTION LSAME(CA,CB) +* +* .. Scalar Arguments .. +* CHARACTER CA,CB +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> LSAME returns .TRUE. if CA is the same letter as CB regardless of +*> case. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] CA +*> \verbatim +*> CA is CHARACTER*1 +*> \endverbatim +*> +*> \param[in] CB +*> \verbatim +*> CB is CHARACTER*1 +*> CA and CB specify the single characters to be compared. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup aux_blas +* +* ===================================================================== + LOGICAL FUNCTION LSAME(CA,CB) +* +* -- Reference BLAS level1 routine (version 3.1) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER CA,CB +* .. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC ICHAR +* .. +* .. Local Scalars .. + INTEGER INTA,INTB,ZCODE +* .. +* +* Test if the characters are equal +* + LSAME = CA .EQ. CB + IF (LSAME) RETURN +* +* Now test for equivalence if both characters are alphabetic. +* + ZCODE = ICHAR('Z') +* +* Use 'Z' rather than 'A' so that ASCII can be detected on Prime +* machines, on which ICHAR returns a value with bit 8 set. +* ICHAR('A') on Prime machines returns 193 which is the same as +* ICHAR('A') on an EBCDIC machine. +* + INTA = ICHAR(CA) + INTB = ICHAR(CB) +* + IF (ZCODE.EQ.90 .OR. ZCODE.EQ.122) THEN +* +* ASCII is assumed - ZCODE is the ASCII code of either lower or +* upper case 'Z'. +* + IF (INTA.GE.97 .AND. INTA.LE.122) INTA = INTA - 32 + IF (INTB.GE.97 .AND. INTB.LE.122) INTB = INTB - 32 +* + ELSE IF (ZCODE.EQ.233 .OR. ZCODE.EQ.169) THEN +* +* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or +* upper case 'Z'. +* + IF (INTA.GE.129 .AND. INTA.LE.137 .OR. + + INTA.GE.145 .AND. INTA.LE.153 .OR. + + INTA.GE.162 .AND. INTA.LE.169) INTA = INTA + 64 + IF (INTB.GE.129 .AND. INTB.LE.137 .OR. + + INTB.GE.145 .AND. INTB.LE.153 .OR. + + INTB.GE.162 .AND. INTB.LE.169) INTB = INTB + 64 +* + ELSE IF (ZCODE.EQ.218 .OR. ZCODE.EQ.250) THEN +* +* ASCII is assumed, on Prime machines - ZCODE is the ASCII code +* plus 128 of either lower or upper case 'Z'. +* + IF (INTA.GE.225 .AND. INTA.LE.250) INTA = INTA - 32 + IF (INTB.GE.225 .AND. INTB.LE.250) INTB = INTB - 32 + END IF + LSAME = INTA .EQ. INTB +* +* RETURN +* +* End of LSAME +* + END + +*> \brief \b XERBLA +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE XERBLA( SRNAME, INFO ) +* +* .. Scalar Arguments .. +* CHARACTER*(*) SRNAME +* INTEGER INFO +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> XERBLA is an error handler for the LAPACK routines. +*> It is called by an LAPACK routine if an input parameter has an +*> invalid value. A message is printed and execution stops. +*> +*> Installers may consider modifying the STOP statement in order to +*> call system-specific exception-handling facilities. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] SRNAME +*> \verbatim +*> SRNAME is CHARACTER*(*) +*> The name of the routine which called XERBLA. +*> \endverbatim +*> +*> \param[in] INFO +*> \verbatim +*> INFO is INTEGER +*> The position of the invalid parameter in the parameter list +*> of the calling routine. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup aux_blas +* +* ===================================================================== + SUBROUTINE XERBLA( SRNAME, INFO ) +* +* -- Reference BLAS level1 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + CHARACTER*(*) SRNAME + INTEGER INFO +* .. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC LEN_TRIM +* .. +* .. Executable Statements .. +* + WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO +* + STOP +* + 9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ', + $ 'an illegal value' ) +* +* End of XERBLA +* + END + +*> \brief \b SGEMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* REAL ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,M,N +* CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. +* REAL A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SGEMM performs one of the matrix-matrix operations +*> +*> C := alpha*op( A )*op( B ) + beta*C, +*> +*> where op( X ) is one of +*> +*> op( X ) = X or op( X ) = X**T, +*> +*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) +*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n', op( A ) = A. +*> +*> TRANSA = 'T' or 't', op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c', op( A ) = A**T. +*> \endverbatim +*> +*> \param[in] TRANSB +*> \verbatim +*> TRANSB is CHARACTER*1 +*> On entry, TRANSB specifies the form of op( B ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSB = 'N' or 'n', op( B ) = B. +*> +*> TRANSB = 'T' or 't', op( B ) = B**T. +*> +*> TRANSB = 'C' or 'c', op( B ) = B**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix +*> op( A ) and of the matrix C. M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix +*> op( B ) and the number of columns of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry, K specifies the number of columns of the matrix +*> op( A ) and the number of rows of the matrix op( B ). K must +*> be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is REAL +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is REAL array, dimension ( LDA, ka ), where ka is +*> k when TRANSA = 'N' or 'n', and is m otherwise. +*> Before entry with TRANSA = 'N' or 'n', the leading m by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by m part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANSA = 'N' or 'n' then +*> LDA must be at least max( 1, m ), otherwise LDA must be at +*> least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is REAL array, dimension ( LDB, kb ), where kb is +*> n when TRANSB = 'N' or 'n', and is k otherwise. +*> Before entry with TRANSB = 'N' or 'n', the leading k by n +*> part of the array B must contain the matrix B, otherwise +*> the leading n by k part of the array B must contain the +*> matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. When TRANSB = 'N' or 'n' then +*> LDB must be at least max( 1, k ), otherwise LDB must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is REAL +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is REAL array, dimension ( LDC, N ) +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n matrix +*> ( alpha*op( A )*op( B ) + beta*C ). +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup single_blas_level3 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE SGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* -- Reference BLAS level3 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + REAL ALPHA,BETA + INTEGER K,LDA,LDB,LDC,M,N + CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. + REAL A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + REAL TEMP + INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB + LOGICAL NOTA,NOTB +* .. +* .. Parameters .. + REAL ONE,ZERO + PARAMETER (ONE=1.0E+0,ZERO=0.0E+0) +* .. +* +* Set NOTA and NOTB as true if A and B respectively are not +* transposed and set NROWA, NCOLA and NROWB as the number of rows +* and columns of A and the number of rows of B respectively. +* + NOTA = LSAME(TRANSA,'N') + NOTB = LSAME(TRANSB,'N') + IF (NOTA) THEN + NROWA = M + NCOLA = K + ELSE + NROWA = K + NCOLA = M + END IF + IF (NOTB) THEN + NROWB = K + ELSE + NROWB = N + END IF +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND. + + (.NOT.LSAME(TRANSA,'T'))) THEN + INFO = 1 + ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND. + + (.NOT.LSAME(TRANSB,'T'))) THEN + INFO = 2 + ELSE IF (M.LT.0) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 8 + ELSE IF (LDB.LT.MAX(1,NROWB)) THEN + INFO = 10 + ELSE IF (LDC.LT.MAX(1,M)) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('SGEMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And if alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,M + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (NOTB) THEN + IF (NOTA) THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 50 I = 1,M + C(I,J) = ZERO + 50 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 60 I = 1,M + C(I,J) = BETA*C(I,J) + 60 CONTINUE + END IF + DO 80 L = 1,K + TEMP = ALPHA*B(L,J) + DO 70 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + ELSE +* +* Form C := alpha*A**T*B + beta*C +* + DO 120 J = 1,N + DO 110 I = 1,M + TEMP = ZERO + DO 100 L = 1,K + TEMP = TEMP + A(L,I)*B(L,J) + 100 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 110 CONTINUE + 120 CONTINUE + END IF + ELSE + IF (NOTA) THEN +* +* Form C := alpha*A*B**T + beta*C +* + DO 170 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 130 I = 1,M + C(I,J) = ZERO + 130 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 140 I = 1,M + C(I,J) = BETA*C(I,J) + 140 CONTINUE + END IF + DO 160 L = 1,K + TEMP = ALPHA*B(J,L) + DO 150 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + ELSE +* +* Form C := alpha*A**T*B**T + beta*C +* + DO 200 J = 1,N + DO 190 I = 1,M + TEMP = ZERO + DO 180 L = 1,K + TEMP = TEMP + A(L,I)*B(J,L) + 180 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 190 CONTINUE + 200 CONTINUE + END IF + END IF +* + RETURN +* +* End of SGEMM . +* + END + +*> \brief \b DGEMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* DOUBLE PRECISION ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,M,N +* CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. +* DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGEMM performs one of the matrix-matrix operations +*> +*> C := alpha*op( A )*op( B ) + beta*C, +*> +*> where op( X ) is one of +*> +*> op( X ) = X or op( X ) = X**T, +*> +*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) +*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n', op( A ) = A. +*> +*> TRANSA = 'T' or 't', op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c', op( A ) = A**T. +*> \endverbatim +*> +*> \param[in] TRANSB +*> \verbatim +*> TRANSB is CHARACTER*1 +*> On entry, TRANSB specifies the form of op( B ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSB = 'N' or 'n', op( B ) = B. +*> +*> TRANSB = 'T' or 't', op( B ) = B**T. +*> +*> TRANSB = 'C' or 'c', op( B ) = B**T. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix +*> op( A ) and of the matrix C. M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix +*> op( B ) and the number of columns of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry, K specifies the number of columns of the matrix +*> op( A ) and the number of rows of the matrix op( B ). K must +*> be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is DOUBLE PRECISION. +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension ( LDA, ka ), where ka is +*> k when TRANSA = 'N' or 'n', and is m otherwise. +*> Before entry with TRANSA = 'N' or 'n', the leading m by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by m part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANSA = 'N' or 'n' then +*> LDA must be at least max( 1, m ), otherwise LDA must be at +*> least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension ( LDB, kb ), where kb is +*> n when TRANSB = 'N' or 'n', and is k otherwise. +*> Before entry with TRANSB = 'N' or 'n', the leading k by n +*> part of the array B must contain the matrix B, otherwise +*> the leading n by k part of the array B must contain the +*> matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. When TRANSB = 'N' or 'n' then +*> LDB must be at least max( 1, k ), otherwise LDB must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is DOUBLE PRECISION. +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension ( LDC, N ) +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n matrix +*> ( alpha*op( A )*op( B ) + beta*C ). +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup double_blas_level3 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* -- Reference BLAS level3 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA,BETA + INTEGER K,LDA,LDB,LDC,M,N + CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB + LOGICAL NOTA,NOTB +* .. +* .. Parameters .. + DOUBLE PRECISION ONE,ZERO + PARAMETER (ONE=1.0D+0,ZERO=0.0D+0) +* .. +* +* Set NOTA and NOTB as true if A and B respectively are not +* transposed and set NROWA, NCOLA and NROWB as the number of rows +* and columns of A and the number of rows of B respectively. +* + NOTA = LSAME(TRANSA,'N') + NOTB = LSAME(TRANSB,'N') + IF (NOTA) THEN + NROWA = M + NCOLA = K + ELSE + NROWA = K + NCOLA = M + END IF + IF (NOTB) THEN + NROWB = K + ELSE + NROWB = N + END IF +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND. + + (.NOT.LSAME(TRANSA,'T'))) THEN + INFO = 1 + ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND. + + (.NOT.LSAME(TRANSB,'T'))) THEN + INFO = 2 + ELSE IF (M.LT.0) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 8 + ELSE IF (LDB.LT.MAX(1,NROWB)) THEN + INFO = 10 + ELSE IF (LDC.LT.MAX(1,M)) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('DGEMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And if alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,M + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (NOTB) THEN + IF (NOTA) THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 50 I = 1,M + C(I,J) = ZERO + 50 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 60 I = 1,M + C(I,J) = BETA*C(I,J) + 60 CONTINUE + END IF + DO 80 L = 1,K + TEMP = ALPHA*B(L,J) + DO 70 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + ELSE +* +* Form C := alpha*A**T*B + beta*C +* + DO 120 J = 1,N + DO 110 I = 1,M + TEMP = ZERO + DO 100 L = 1,K + TEMP = TEMP + A(L,I)*B(L,J) + 100 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 110 CONTINUE + 120 CONTINUE + END IF + ELSE + IF (NOTA) THEN +* +* Form C := alpha*A*B**T + beta*C +* + DO 170 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 130 I = 1,M + C(I,J) = ZERO + 130 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 140 I = 1,M + C(I,J) = BETA*C(I,J) + 140 CONTINUE + END IF + DO 160 L = 1,K + TEMP = ALPHA*B(J,L) + DO 150 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + ELSE +* +* Form C := alpha*A**T*B**T + beta*C +* + DO 200 J = 1,N + DO 190 I = 1,M + TEMP = ZERO + DO 180 L = 1,K + TEMP = TEMP + A(L,I)*B(J,L) + 180 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 190 CONTINUE + 200 CONTINUE + END IF + END IF +* + RETURN +* +* End of DGEMM . +* + END + +*> \brief \b ZGEMM +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* .. Scalar Arguments .. +* COMPLEX*16 ALPHA,BETA +* INTEGER K,LDA,LDB,LDC,M,N +* CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. +* COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGEMM performs one of the matrix-matrix operations +*> +*> C := alpha*op( A )*op( B ) + beta*C, +*> +*> where op( X ) is one of +*> +*> op( X ) = X or op( X ) = X**T or op( X ) = X**H, +*> +*> alpha and beta are scalars, and A, B and C are matrices, with op( A ) +*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] TRANSA +*> \verbatim +*> TRANSA is CHARACTER*1 +*> On entry, TRANSA specifies the form of op( A ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSA = 'N' or 'n', op( A ) = A. +*> +*> TRANSA = 'T' or 't', op( A ) = A**T. +*> +*> TRANSA = 'C' or 'c', op( A ) = A**H. +*> \endverbatim +*> +*> \param[in] TRANSB +*> \verbatim +*> TRANSB is CHARACTER*1 +*> On entry, TRANSB specifies the form of op( B ) to be used in +*> the matrix multiplication as follows: +*> +*> TRANSB = 'N' or 'n', op( B ) = B. +*> +*> TRANSB = 'T' or 't', op( B ) = B**T. +*> +*> TRANSB = 'C' or 'c', op( B ) = B**H. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> On entry, M specifies the number of rows of the matrix +*> op( A ) and of the matrix C. M must be at least zero. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> On entry, N specifies the number of columns of the matrix +*> op( B ) and the number of columns of the matrix C. N must be +*> at least zero. +*> \endverbatim +*> +*> \param[in] K +*> \verbatim +*> K is INTEGER +*> On entry, K specifies the number of columns of the matrix +*> op( A ) and the number of rows of the matrix op( B ). K must +*> be at least zero. +*> \endverbatim +*> +*> \param[in] ALPHA +*> \verbatim +*> ALPHA is COMPLEX*16 +*> On entry, ALPHA specifies the scalar alpha. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension ( LDA, ka ), where ka is +*> k when TRANSA = 'N' or 'n', and is m otherwise. +*> Before entry with TRANSA = 'N' or 'n', the leading m by k +*> part of the array A must contain the matrix A, otherwise +*> the leading k by m part of the array A must contain the +*> matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> On entry, LDA specifies the first dimension of A as declared +*> in the calling (sub) program. When TRANSA = 'N' or 'n' then +*> LDA must be at least max( 1, m ), otherwise LDA must be at +*> least max( 1, k ). +*> \endverbatim +*> +*> \param[in] B +*> \verbatim +*> B is COMPLEX*16 array, dimension ( LDB, kb ), where kb is +*> n when TRANSB = 'N' or 'n', and is k otherwise. +*> Before entry with TRANSB = 'N' or 'n', the leading k by n +*> part of the array B must contain the matrix B, otherwise +*> the leading n by k part of the array B must contain the +*> matrix B. +*> \endverbatim +*> +*> \param[in] LDB +*> \verbatim +*> LDB is INTEGER +*> On entry, LDB specifies the first dimension of B as declared +*> in the calling (sub) program. When TRANSB = 'N' or 'n' then +*> LDB must be at least max( 1, k ), otherwise LDB must be at +*> least max( 1, n ). +*> \endverbatim +*> +*> \param[in] BETA +*> \verbatim +*> BETA is COMPLEX*16 +*> On entry, BETA specifies the scalar beta. When BETA is +*> supplied as zero then C need not be set on input. +*> \endverbatim +*> +*> \param[in,out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension ( LDC, N ) +*> Before entry, the leading m by n part of the array C must +*> contain the matrix C, except when beta is zero, in which +*> case C need not be set on entry. +*> On exit, the array C is overwritten by the m by n matrix +*> ( alpha*op( A )*op( B ) + beta*C ). +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> On entry, LDC specifies the first dimension of C as declared +*> in the calling (sub) program. LDC must be at least +*> max( 1, m ). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date December 2016 +* +*> \ingroup complex16_blas_level3 +* +*> \par Further Details: +* ===================== +*> +*> \verbatim +*> +*> Level 3 Blas routine. +*> +*> -- Written on 8-February-1989. +*> Jack Dongarra, Argonne National Laboratory. +*> Iain Duff, AERE Harwell. +*> Jeremy Du Croz, Numerical Algorithms Group Ltd. +*> Sven Hammarling, Numerical Algorithms Group Ltd. +*> \endverbatim +*> +* ===================================================================== + SUBROUTINE ZGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC) +* +* -- Reference BLAS level3 routine (version 3.7.0) -- +* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* December 2016 +* +* .. Scalar Arguments .. + COMPLEX*16 ALPHA,BETA + INTEGER K,LDA,LDB,LDC,M,N + CHARACTER TRANSA,TRANSB +* .. +* .. Array Arguments .. + COMPLEX*16 A(LDA,*),B(LDB,*),C(LDC,*) +* .. +* +* ===================================================================== +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG,MAX +* .. +* .. Local Scalars .. + COMPLEX*16 TEMP + INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB + LOGICAL CONJA,CONJB,NOTA,NOTB +* .. +* .. Parameters .. + COMPLEX*16 ONE + PARAMETER (ONE= (1.0D+0,0.0D+0)) + COMPLEX*16 ZERO + PARAMETER (ZERO= (0.0D+0,0.0D+0)) +* .. +* +* Set NOTA and NOTB as true if A and B respectively are not +* conjugated or transposed, set CONJA and CONJB as true if A and +* B respectively are to be transposed but not conjugated and set +* NROWA, NCOLA and NROWB as the number of rows and columns of A +* and the number of rows of B respectively. +* + NOTA = LSAME(TRANSA,'N') + NOTB = LSAME(TRANSB,'N') + CONJA = LSAME(TRANSA,'C') + CONJB = LSAME(TRANSB,'C') + IF (NOTA) THEN + NROWA = M + NCOLA = K + ELSE + NROWA = K + NCOLA = M + END IF + IF (NOTB) THEN + NROWB = K + ELSE + NROWB = N + END IF +* +* Test the input parameters. +* + INFO = 0 + IF ((.NOT.NOTA) .AND. (.NOT.CONJA) .AND. + + (.NOT.LSAME(TRANSA,'T'))) THEN + INFO = 1 + ELSE IF ((.NOT.NOTB) .AND. (.NOT.CONJB) .AND. + + (.NOT.LSAME(TRANSB,'T'))) THEN + INFO = 2 + ELSE IF (M.LT.0) THEN + INFO = 3 + ELSE IF (N.LT.0) THEN + INFO = 4 + ELSE IF (K.LT.0) THEN + INFO = 5 + ELSE IF (LDA.LT.MAX(1,NROWA)) THEN + INFO = 8 + ELSE IF (LDB.LT.MAX(1,NROWB)) THEN + INFO = 10 + ELSE IF (LDC.LT.MAX(1,M)) THEN + INFO = 13 + END IF + IF (INFO.NE.0) THEN + CALL XERBLA('ZGEMM ',INFO) + RETURN + END IF +* +* Quick return if possible. +* + IF ((M.EQ.0) .OR. (N.EQ.0) .OR. + + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN +* +* And when alpha.eq.zero. +* + IF (ALPHA.EQ.ZERO) THEN + IF (BETA.EQ.ZERO) THEN + DO 20 J = 1,N + DO 10 I = 1,M + C(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1,N + DO 30 I = 1,M + C(I,J) = BETA*C(I,J) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF (NOTB) THEN + IF (NOTA) THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 50 I = 1,M + C(I,J) = ZERO + 50 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 60 I = 1,M + C(I,J) = BETA*C(I,J) + 60 CONTINUE + END IF + DO 80 L = 1,K + TEMP = ALPHA*B(L,J) + DO 70 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + ELSE IF (CONJA) THEN +* +* Form C := alpha*A**H*B + beta*C. +* + DO 120 J = 1,N + DO 110 I = 1,M + TEMP = ZERO + DO 100 L = 1,K + TEMP = TEMP + DCONJG(A(L,I))*B(L,J) + 100 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 110 CONTINUE + 120 CONTINUE + ELSE +* +* Form C := alpha*A**T*B + beta*C +* + DO 150 J = 1,N + DO 140 I = 1,M + TEMP = ZERO + DO 130 L = 1,K + TEMP = TEMP + A(L,I)*B(L,J) + 130 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 140 CONTINUE + 150 CONTINUE + END IF + ELSE IF (NOTA) THEN + IF (CONJB) THEN +* +* Form C := alpha*A*B**H + beta*C. +* + DO 200 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 160 I = 1,M + C(I,J) = ZERO + 160 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 170 I = 1,M + C(I,J) = BETA*C(I,J) + 170 CONTINUE + END IF + DO 190 L = 1,K + TEMP = ALPHA*DCONJG(B(J,L)) + DO 180 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE + ELSE +* +* Form C := alpha*A*B**T + beta*C +* + DO 250 J = 1,N + IF (BETA.EQ.ZERO) THEN + DO 210 I = 1,M + C(I,J) = ZERO + 210 CONTINUE + ELSE IF (BETA.NE.ONE) THEN + DO 220 I = 1,M + C(I,J) = BETA*C(I,J) + 220 CONTINUE + END IF + DO 240 L = 1,K + TEMP = ALPHA*B(J,L) + DO 230 I = 1,M + C(I,J) = C(I,J) + TEMP*A(I,L) + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + END IF + ELSE IF (CONJA) THEN + IF (CONJB) THEN +* +* Form C := alpha*A**H*B**H + beta*C. +* + DO 280 J = 1,N + DO 270 I = 1,M + TEMP = ZERO + DO 260 L = 1,K + TEMP = TEMP + DCONJG(A(L,I))*DCONJG(B(J,L)) + 260 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 270 CONTINUE + 280 CONTINUE + ELSE +* +* Form C := alpha*A**H*B**T + beta*C +* + DO 310 J = 1,N + DO 300 I = 1,M + TEMP = ZERO + DO 290 L = 1,K + TEMP = TEMP + DCONJG(A(L,I))*B(J,L) + 290 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 300 CONTINUE + 310 CONTINUE + END IF + ELSE + IF (CONJB) THEN +* +* Form C := alpha*A**T*B**H + beta*C +* + DO 340 J = 1,N + DO 330 I = 1,M + TEMP = ZERO + DO 320 L = 1,K + TEMP = TEMP + A(L,I)*DCONJG(B(J,L)) + 320 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 330 CONTINUE + 340 CONTINUE + ELSE +* +* Form C := alpha*A**T*B**T + beta*C +* + DO 370 J = 1,N + DO 360 I = 1,M + TEMP = ZERO + DO 350 L = 1,K + TEMP = TEMP + A(L,I)*B(J,L) + 350 CONTINUE + IF (BETA.EQ.ZERO) THEN + C(I,J) = ALPHA*TEMP + ELSE + C(I,J) = ALPHA*TEMP + BETA*C(I,J) + END IF + 360 CONTINUE + 370 CONTINUE + END IF + END IF +* + RETURN +* +* End of ZGEMM . +* + END diff --git a/Fortran/gfortran/regression/block_1.f08 b/Fortran/gfortran/regression/block_1.f08 --- /dev/null +++ b/Fortran/gfortran/regression/block_1.f08 @@ -0,0 +1,34 @@ +! { dg-do run } +! { dg-options "-std=f2008 " } + +! Basic Fortran 2008 BLOCK construct test. + +PROGRAM main + IMPLICIT NONE + INTEGER :: i + + i = 42 + + ! Empty block. + BLOCK + END BLOCK + + ! Block without local variables but name. + BLOCK + IF (i /= 42) STOP 1 + i = 5 + END BLOCK + IF (i /= 5) STOP 2 + + ! Named block with local variable and nested block. + myblock: BLOCK + INTEGER :: i + i = -1 + BLOCK + IF (i /= -1) STOP 3 + i = -2 + END BLOCK + IF (i /= -2) STOP 4 + END BLOCK myblock ! Matching end-label. + IF (i /= 5) STOP 5 +END PROGRAM main diff --git a/Fortran/gfortran/regression/block_10.f90 b/Fortran/gfortran/regression/block_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/block_10.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! +! PR fortran/51605 +! + +contains + subroutine foo + BLOCK_NAME: block + end block BLOCK_NAME + end subroutine foo + + subroutine BLOCK_NAME() + end subroutine BLOCK_NAME + + subroutine bar() + end subroutine bar +end + +subroutine test() +contains + subroutine BLOCK_NAME() + end subroutine BLOCK_NAME + + subroutine foobar() + end subroutine foobar + + subroutine foo + BLOCK_NAME: block + end block BLOCK_NAME + end subroutine foo + + subroutine bar() + end subroutine bar +end diff --git a/Fortran/gfortran/regression/block_11.f90 b/Fortran/gfortran/regression/block_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/block_11.f90 @@ -0,0 +1,66 @@ +! { dg-do link } +! +! PR fortran/52729 +! +! Based on a contribution of Andrew Benson +! +module testMod + type testType + end type testType +contains + subroutine testSub() + implicit none + procedure(double precision ), pointer :: r + class (testType ), pointer :: testObject + double precision :: testVal + + ! Failed as testFunc was BT_UNKNOWN + select type (testObject) + class is (testType) + testVal=testFunc() + r => testFunc + end select + return + end subroutine testSub + + double precision function testFunc() + implicit none + return + end function testFunc +end module testMod + +module testMod2 + implicit none +contains + subroutine testSub() + procedure(double precision ), pointer :: r + double precision :: testVal + ! Failed as testFunc was BT_UNKNOWN + block + r => testFunc + testVal=testFunc() + end block + end subroutine testSub + + double precision function testFunc() + end function testFunc +end module testMod2 + +module m3 + implicit none +contains + subroutine my_test() + procedure(sub), pointer :: ptr + ! Before the fix, one had the link error + ! "undefined reference to `sub.1909'" + block + ptr => sub + call sub() + end block + end subroutine my_test + subroutine sub(a) + integer, optional :: a + end subroutine sub +end module m3 + +end diff --git a/Fortran/gfortran/regression/block_12.f90 b/Fortran/gfortran/regression/block_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/block_12.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR 50627 - this used to free a namespace twice. +program main + block +end program main ! { dg-error "END BLOCK" } +! { dg-prune-output "Unexpected end of file" } diff --git a/Fortran/gfortran/regression/block_13.f08 b/Fortran/gfortran/regression/block_13.f08 --- /dev/null +++ b/Fortran/gfortran/regression/block_13.f08 @@ -0,0 +1,58 @@ +! { dg-do run } +! Checks the fix for PR57959. The first assignment to a was proceeding +! without a deep copy. Since the anum field of 'uKnot' was being pointed +! to twice, the frees in the finally block, following the BLOCK caused +! a double free. +! +! Contributed by Tobias Burnus +! +program main + implicit none + type :: type1 + real, allocatable :: anum + character(len = :), allocatable :: chr + end type type1 + real, parameter :: five = 5.0 + real, parameter :: point_one = 0.1 + + type :: type2 + type(type1) :: temp + end type type2 + block + type(type1) :: uKnot + type(type2) :: a + + uKnot = type1 (five, "hello") + call check (uKnot%anum, five) + call check_chr (uKnot%chr, "hello") + + a = type2 (uKnot) ! Deep copy needed here + call check (a%temp%anum, five) + call check_chr (a%temp%chr, "hello") + + a = type2 (type1(point_one, "goodbye")) ! Not here + call check (a%temp%anum, point_one) + call check_chr (a%temp%chr, "goodbye") + + a = type2 (foo (five)) ! Not here + call check (a%temp%anum, five) + call check_chr (a%temp%chr, "foo set me") + end block +contains + subroutine check (arg1, arg2) + real :: arg1, arg2 + if (arg1 .ne. arg2) STOP 1 + end subroutine + + subroutine check_chr (arg1, arg2) + character(*) :: arg1, arg2 + if (len (arg1) .ne. len (arg2)) STOP 1 + if (arg1 .ne. arg2) STOP 2 + end subroutine + + type(type1) function foo (arg) + real :: arg + foo = type1 (arg, "foo set me") + end function +end + diff --git a/Fortran/gfortran/regression/block_14.f90 b/Fortran/gfortran/regression/block_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/block_14.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! PR 66113 - this used to ICE with deeply nested BLOCKS. +program main + integer :: n + real :: s + n = 3 + block + block + block + block + block + real, dimension(n) :: a + a = 3. + s = sum(a) + end block + end block + end block + end block + end block + if (s /= 9) STOP 1 +end program main diff --git a/Fortran/gfortran/regression/block_15.f08 b/Fortran/gfortran/regression/block_15.f08 --- /dev/null +++ b/Fortran/gfortran/regression/block_15.f08 @@ -0,0 +1,20 @@ +! { dg-do compile } +! +! Contributed by Tobias Burnus +! Check fix for PR62536 works as expected. + +function f2 (x) +implicit none + integer f2, x + block + block named ! { dg-error "Unclassifiable statement" } + integer a ! should be SAVEd + a = a + x ! should increment by y every time + f2 = a + end block named ! { dg-error "Syntax error in END BLOCK statement" } + end block + return +endfunction + +end + diff --git a/Fortran/gfortran/regression/block_16.f08 b/Fortran/gfortran/regression/block_16.f08 --- /dev/null +++ b/Fortran/gfortran/regression/block_16.f08 @@ -0,0 +1,26 @@ +! { dg-do compile } +! PR82009 [F08] ICE with block construct +MODULE sparse_matrix_csx_benchmark_utils + IMPLICIT NONE +CONTAINS + SUBROUTINE sparse_matrix_csr_benchmark ( ) + WRITE(*,*) 'At*x: t' + block + integer, dimension(1), parameter :: idxs=[1] + integer :: i, idx + do i = 1, size(idxs) + idx = idxs(i) + enddo + end block + END SUBROUTINE sparse_matrix_csr_benchmark + SUBROUTINE sparse_matrix_csc_benchmark ( ) + WRITE(*,*) 'An*x: t' + block + integer, dimension(1), parameter :: idxs=[1] + integer :: i, idx + do i = 1, size(idxs) + idx = idxs(i) + enddo + end block + END SUBROUTINE sparse_matrix_csc_benchmark +END MODULE sparse_matrix_csx_benchmark_utils diff --git a/Fortran/gfortran/regression/block_2.f08 b/Fortran/gfortran/regression/block_2.f08 --- /dev/null +++ b/Fortran/gfortran/regression/block_2.f08 @@ -0,0 +1,38 @@ +! { dg-do run } +! { dg-options "-std=f2008 -fdump-tree-original" } + +! More sophisticated BLOCK runtime checks for correct initialization/clean-up. + +PROGRAM main + IMPLICIT NONE + INTEGER :: n + + n = 5 + + myblock: BLOCK + INTEGER :: arr(n) + IF (SIZE (arr) /= 5) STOP 1 + BLOCK + INTEGER :: arr(2*n) + IF (SIZE (arr) /= 10) STOP 2 + END BLOCK + IF (SIZE (arr) /= 5) STOP 3 + END BLOCK myblock + + BLOCK + INTEGER, ALLOCATABLE :: alloc_arr(:) + IF (ALLOCATED (alloc_arr)) STOP 4 + ALLOCATE (alloc_arr(n)) + IF (SIZE (alloc_arr) /= 5) STOP 5 + ! Should be free'ed here (but at least somewhere), this is checked + ! with pattern below. + END BLOCK + + BLOCK + CHARACTER(LEN=n) :: str + IF (LEN (str) /= 5) STOP 6 + str = "123456789" + IF (str /= "12345") STOP 7 + END BLOCK +END PROGRAM main +! { dg-final { scan-tree-dump-times "free \\(\\(void \\*\\) alloc_arr\\.data" 1 "original" } } diff --git a/Fortran/gfortran/regression/block_3.f90 b/Fortran/gfortran/regression/block_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/block_3.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-std=f95" } + +! BLOCK should be rejected without F2008. + +PROGRAM main + IMPLICIT NONE + + BLOCK ! { dg-error "Fortran 2008" } + INTEGER :: i + END BLOCK +END PROGRAM main diff --git a/Fortran/gfortran/regression/block_4.f08 b/Fortran/gfortran/regression/block_4.f08 --- /dev/null +++ b/Fortran/gfortran/regression/block_4.f08 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } + +! Check for label mismatch errors with BLOCK statements. + +PROGRAM main + IMPLICIT NONE + + BLOCK + END BLOCK wrongname ! { dg-error "Syntax error" } + + myname: BLOCK + END BLOCK wrongname ! { dg-error "Expected label 'myname'" } + + myname2: BLOCK + END BLOCK ! { dg-error "Expected block name of 'myname2'" } +END PROGRAM main ! { dg-error "Expecting END BLOCK" } +! { dg-error "Unexpected end of file" "" { target "*-*-*" } 0 } diff --git a/Fortran/gfortran/regression/block_5.f08 b/Fortran/gfortran/regression/block_5.f08 --- /dev/null +++ b/Fortran/gfortran/regression/block_5.f08 @@ -0,0 +1,38 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! We want to check for statement functions, thus legacy mode. + +! Check for errors with declarations not allowed within BLOCK. + +SUBROUTINE proc (a) + IMPLICIT NONE + INTEGER :: a + + BLOCK + INTENT(IN) :: a ! { dg-error "not allowed inside of BLOCK" } + VALUE :: a ! { dg-error "not allowed inside of BLOCK" } + OPTIONAL :: a ! { dg-error "not allowed inside of BLOCK" } + END BLOCK +END SUBROUTINE proc + +PROGRAM main + IMPLICIT NONE + + BLOCK + IMPLICIT INTEGER(a-z) ! { dg-error "not allowed inside of BLOCK" } + INTEGER :: a, b, c, d + INTEGER :: stfunc + stfunc(a, b) = a + b ! { dg-error "not allowed inside of BLOCK" } + EQUIVALENCE (a, b) ! { dg-error "not allowed inside of BLOCK" } + NAMELIST /NLIST/ a, b ! { dg-error "not allowed inside of BLOCK" } + COMMON /CBLOCK/ c, d ! { dg-error "not allowed inside of BLOCK" } + ! This contains is in the specification part. + CONTAINS ! { dg-error "Unexpected CONTAINS statement" } + END BLOCK + + BLOCK + PRINT *, "Hello, world" + ! This one in the executable statement part. + CONTAINS ! { dg-error "Unexpected CONTAINS statement" } + END BLOCK +END PROGRAM main diff --git a/Fortran/gfortran/regression/block_6.f08 b/Fortran/gfortran/regression/block_6.f08 --- /dev/null +++ b/Fortran/gfortran/regression/block_6.f08 @@ -0,0 +1,17 @@ +! { dg-do run { xfail *-*-* } } +! { dg-options "-std=f2008 " } + +! Check for correct scope of variables that are implicit typed within a BLOCK. +! This is not yet implemented, thus XFAIL'ed the test. + +PROGRAM main + IMPLICIT INTEGER(a-z) + + BLOCK + ! a gets implicitly typed, but scope should not be limited to BLOCK. + a = 42 + END BLOCK + + ! Here, we should still access the same a that was set above. + IF (a /= 42) STOP 1 +END PROGRAM main diff --git a/Fortran/gfortran/regression/block_7.f08 b/Fortran/gfortran/regression/block_7.f08 --- /dev/null +++ b/Fortran/gfortran/regression/block_7.f08 @@ -0,0 +1,24 @@ +! { dg-do run } +! { dg-options "-std=f2008 " } + +! Check for correct placement (on the stack) of local variables with BLOCK +! and recursive container procedures. + +RECURSIVE SUBROUTINE myproc (i) + INTEGER, INTENT(IN) :: i + ! Wrap the block up in some other construct so we see this doesn't mess + ! things up, either. + DO + BLOCK + INTEGER :: x + x = i + IF (i > 0) CALL myproc (i - 1) + IF (x /= i) STOP 1 + END BLOCK + EXIT + END DO +END SUBROUTINE myproc + +PROGRAM main + CALL myproc (42) +END PROGRAM main diff --git a/Fortran/gfortran/regression/block_8.f08 b/Fortran/gfortran/regression/block_8.f08 --- /dev/null +++ b/Fortran/gfortran/regression/block_8.f08 @@ -0,0 +1,17 @@ +! { dg-do run } +! { dg-options "-std=f2008 " } + +! Check BLOCK with SAVE'ed variables. + +PROGRAM main + IMPLICIT NONE + INTEGER :: i + + DO i = 1, 100 + BLOCK + INTEGER, SAVE :: summed = 0 + summed = summed + i + IF (i == 100 .AND. summed /= 5050) STOP 1 + END BLOCK + END DO +END PROGRAM main diff --git a/Fortran/gfortran/regression/block_9.f08 b/Fortran/gfortran/regression/block_9.f08 --- /dev/null +++ b/Fortran/gfortran/regression/block_9.f08 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! PR 46849: [OOP] MODULE PROCEDURE resolution does not work in BLOCK or SELECT TYPE +! +! Contributed by Reinhold Bader + + implicit none + + block + call init(fun) + end block + +contains + + subroutine init(func) + real, external :: func + end subroutine + + real function fun() + fun = 1.1 + end function + +end diff --git a/Fortran/gfortran/regression/block_end_error_1.f90 b/Fortran/gfortran/regression/block_end_error_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/block_end_error_1.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! PR fortran/62536 +! Bad "end block" causes ICE. +subroutine s + block + end block named ! { dg-error "Syntax error in END BLOCK statement" } + return +endsubroutine ! { dg-error "Expecting END BLOCK statement" } +! { dg-prune-output "Unexpected end of file" } diff --git a/Fortran/gfortran/regression/block_name_1.f90 b/Fortran/gfortran/regression/block_name_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/block_name_1.f90 @@ -0,0 +1,78 @@ +! { dg-do compile } +! Verify that the compiler accepts the various legal combinations of +! using construct names. +! +! The correct behavior of EXIT and CYCLE is already established in +! the various DO related testcases, they're included here for +! completeness. + dimension a(5) + i = 0 + ! construct name is optional on else clauses + ia: if (i > 0) then + i = 1 + else + i = 2 + end if ia + ib: if (i < 0) then + i = 3 + else ib + i = 4 + end if ib + ic: if (i < 0) then + i = 5 + else if (i == 0) then ic + i = 6 + else if (i == 1) then + i =7 + else if (i == 2) then ic + i = 8 + end if ic + + fa: forall (i=1:5, a(i) > 0) + a(i) = 9 + end forall fa + + wa: where (a > 0) + a = -a + elsewhere + wb: where (a == 0) + a = a + 1. + elsewhere wb + a = 2*a + end where wb + end where wa + + j = 1 + sa: select case (i) + case (1) + i = 2 + case (2) sa + i = 3 + case default sa + sb: select case (j) + case (1) sb + i = j + case default + j = i + end select sb + end select sa + + da: do i=1,10 + cycle da + cycle + exit da + exit + db: do + cycle da + cycle db + cycle + exit da + exit db + exit + j = i+1 + end do db + dc: do while (j>0) + j = j-1 + end do dc + end do da +end diff --git a/Fortran/gfortran/regression/block_name_2.f90 b/Fortran/gfortran/regression/block_name_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/block_name_2.f90 @@ -0,0 +1,60 @@ +! { dg-do compile } +! Test that various illegal combinations of block statements with +! block names yield the correct error messages. Motivated by PR31471. +program blocks + dimension a(5,2) + + a = 0 + + ! The END statement of a labelled block needs to carry the construct + ! name. + d1: do i=1,10 + end do ! { dg-error "Expected block name of .... in END DO statement" } + end do d1 + + i1: if (i > 0) then + end if ! { dg-error "Expected block name of .... in END IF statement" } + end if i1 + + s1: select case (i) + end select ! { dg-error "Expected block name of .... in END SELECT statement" } + end select s1 + + w1: where (a > 0) + end where ! { dg-error "Expected block name of .... in END WHERE statement" } + end where w1 + + f1: forall (i = 1:10) + end forall ! { dg-error "Expected block name of .... in END FORALL statement" } + end forall f1 + + ! A construct name may not appear in the END statement, if it + ! doesn't appear in the statement beginning the block. + ! Likewise it may not appear in ELSE IF, ELSE, ELSEWHERE or CASE + ! statements. + do i=1,10 + end do d2 ! { dg-error "Syntax error in END DO statement" } + end do + + if (i > 0) then + else if (i ==0) then i2 ! { dg-error "Syntax error in ELSE IF statement" } + else i2 ! { dg-error "Invalid character.s. in ELSE statement" } + end if i2 ! { dg-error "Syntax error in END IF statement" } + end if + + select case (i) + case (1) s2 ! { dg-error "Syntax error in CASE specification" } + case default s2 ! { dg-error "Syntax error in CASE specification" } + end select s2 ! { dg-error "Syntax error in END SELECT statement" } + end select + + where (a > 0) + elsewhere w2 ! { dg-error "Invalid character.s. in ELSE statement" } + end where w2 ! { dg-error "Syntax error in END WHERE statement" } + end where + + forall (i=1:10) + end forall f2 ! { dg-error "Syntax error in END FORALL statement" } + end forall + +end program blocks diff --git a/Fortran/gfortran/regression/blockdata_1.f90 b/Fortran/gfortran/regression/blockdata_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/blockdata_1.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! tests basic block data functionality +! we didn't allow multiple block data program units +block data + common /a/ y(3) + data y /3*1./ +end + +blockdata d1 + common /a/ w(3) + common /b/ u + data u /1./ +end blockdata d1 + +block data d2 + common /b/ u + common j ! { dg-warning "blank COMMON but initialization is only allowed in named common" } + data j /1/ +end block data d2 +! +! begin testing code +common /a/ x(3) +common /b/ y +common i + +if (any(x /= 1.)) STOP 1 +if (y /= 1. .or. i /= 1) STOP 2 +end diff --git a/Fortran/gfortran/regression/blockdata_10.f90 b/Fortran/gfortran/regression/blockdata_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/blockdata_10.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! +! PR 88009: [9 Regression] ICE in find_intrinsic_vtab, at fortran/class.c:2761 +! +! Contributed by G. Steinmetz + +module m + class(*), allocatable :: z +end +block data + use m + z = 'z' ! { dg-error "assignment statement is not allowed|Unexpected assignment statement" } +end diff --git a/Fortran/gfortran/regression/blockdata_11.f90 b/Fortran/gfortran/regression/blockdata_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/blockdata_11.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! PR 84394 - this used to complain about private procedures in +! BLOCK data. +module mod1 + implicit none + type :: type1 + integer :: i1 + end type type1 +end module + +module mod2 + implicit none + contains + subroutine sub1 + integer vals + common /block1/ vals(5) + if (any(vals /= [1, 2, 3, 4, 5])) stop 1 + end subroutine +end module + +block data blkdat + use mod1 + integer vals + common /block1/ vals(5) + data vals/1, 2, 3, 4, 5/ +end block data blkdat + +program main + use mod2, only: sub1 + implicit none + call sub1 +end program + diff --git a/Fortran/gfortran/regression/blockdata_2.f90 b/Fortran/gfortran/regression/blockdata_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/blockdata_2.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! Test for pr29537 where we did ICE trying to dereference the NULL +! proc_name from an unnamed block data which we intended to use as locus +! for a blank common. +block data + common c +end !block data +end diff --git a/Fortran/gfortran/regression/blockdata_3.f90 b/Fortran/gfortran/regression/blockdata_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/blockdata_3.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-options "-W -Wall" } +! Tests the fix for PR29539, in which the derived type in a blockdata +! cause an ICE. With the fix for PR29565, this now compiles and runs +! correctly. +! +! Contributed by Bernhard Fischer +! +block data + common /c/ d(5), cc + type c_t + sequence + integer i + end type c_t + type (c_t) :: cc + data d /5*1./ + data cc%i /5/ +end + + common /c/ d(5), cc + type c_t + sequence + integer i + end type c_t + type (c_t) :: cc + print *, d + print *, cc +end diff --git a/Fortran/gfortran/regression/blockdata_4.f90 b/Fortran/gfortran/regression/blockdata_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/blockdata_4.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-std=gnu" } +! PR33152 Initialization/declaration problems in block data +! Test case prepared by Jerry DeLisle +blockdata bab + character(len=3) :: myname(2)=(/'bar','baz'/) + common/nmstr/myname +end blockdata bab + +blockdata thdinit + implicit none + integer, parameter :: nmin=2 + common/onestr/emname + character(len=3) :: emname(nmin) = (/'bar','baz'/) +end blockdata thdinit + +blockdata fooinit + implicit none + integer, parameter :: nmin=2 + common/twostr/aname + data aname/'bar','baz'/ ! { dg-error "DATA array" } + character(len=3) :: aname(nmin) +end blockdata fooinit + +end diff --git a/Fortran/gfortran/regression/blockdata_5.f90 b/Fortran/gfortran/regression/blockdata_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/blockdata_5.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! PR34227 Initialized symbol in COMMON: Missing checks +program main + implicit none + integer, parameter:: nmin = 2 + character(len=3) :: emname(nmin)=(/'bar','baz'/) + common/nmstr/emname ! { dg-error "can only be COMMON in BLOCK DATA" } +end program main + diff --git a/Fortran/gfortran/regression/blockdata_6.f90 b/Fortran/gfortran/regression/blockdata_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/blockdata_6.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! PR34227 Initialized symbol in COMMON: Missing checks +program main + implicit none + integer, parameter:: nmin = 2 + character(len=3) :: emname(nmin) + data emname/'bar','baz'/ + common/dd/emname ! { dg-error "can only be COMMON in BLOCK DATA" } +end program main diff --git a/Fortran/gfortran/regression/blockdata_7.f90 b/Fortran/gfortran/regression/blockdata_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/blockdata_7.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR fortran/55444 +! +! Contributed by Henrik Holst +! + BLOCKDATA +! USE ISO_C_BINDING, ONLY: C_INT, C_FLOAT ! WORKS + USE :: ISO_C_BINDING ! FAILS + INTEGER(C_INT) X + REAL(C_FLOAT) Y + COMMON /FOO/ X,Y + BIND(C,NAME='fortranStuff') /FOO/ + DATA X /1/ + DATA Y /2.0/ + END BLOCKDATA diff --git a/Fortran/gfortran/regression/blockdata_8.f90 b/Fortran/gfortran/regression/blockdata_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/blockdata_8.f90 @@ -0,0 +1,48 @@ +! { dg-do compile } +! +! PR fortran/44350 +! +! Fortran 2008, C1116 only permits a small subset of statements in BLOCK DATA +! +! Part of the test case was contributed by Vittorio Zecca +! +module m +end module m + +BLOCK DATA valid2 + use m + implicit integer(a-z) + intrinsic :: sin + common /one/ a, c + bind(C) :: /one/ + dimension c(5) + parameter (g = 7) +END BLOCK DATA valid2 + +BLOCK DATA valid + use m + implicit none + type t + sequence + end type t + type(t), save :: x + integer :: y + real :: q + save :: y + dimension :: q(5) +! class(*) :: zz ! See PR fortran/58857 +! pointer :: zz + target :: q + volatile y + asynchronous q +END BLOCK DATA valid + +block data invalid + common x + f(x)=x ! { dg-error "STATEMENT FUNCTION statement is not allowed inside of BLOCK DATA" } + interface ! { dg-error "INTERFACE statement is not allowed inside of BLOCK DATA" } + end interface +1 format() ! { dg-error "FORMAT statement is not allowed inside of BLOCK DATA" } +end block invalid ! { dg-error "Expecting END BLOCK DATA statement" } + +! { dg-error "Unexpected end of file" "" { target "*-*-*" } 0 } diff --git a/Fortran/gfortran/regression/blockdata_9.f b/Fortran/gfortran/regression/blockdata_9.f --- /dev/null +++ b/Fortran/gfortran/regression/blockdata_9.f @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-fno-automatic -finit-local-zero" } +! PR fortran/66347 + + block data + implicit none + integer i, n + parameter (n=1) + character*2 s1(n) + character*8 s2(n) + common /foo/ s1, s2 + data (s1(i),s2(i),i=1,n)/"ab","12345678"/ + end diff --git a/Fortran/gfortran/regression/blocks_nested_incomplete_1.f90 b/Fortran/gfortran/regression/blocks_nested_incomplete_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/blocks_nested_incomplete_1.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! +! PR fortran/66175 +! Nested incomplete blocks cause ICE. +program main + block + block +end program ! { dg-error "Expecting END BLOCK statement" } +! { dg-prune-output "Unexpected end of file" } diff --git a/Fortran/gfortran/regression/bom_UTF-8.f90 b/Fortran/gfortran/regression/bom_UTF-8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bom_UTF-8.f90 @@ -0,0 +1,3 @@ +print *, "Hello world" +end +! { dg-do compile } diff --git a/Fortran/gfortran/regression/bom_UTF-8_F.F90 b/Fortran/gfortran/regression/bom_UTF-8_F.F90 --- /dev/null +++ b/Fortran/gfortran/regression/bom_UTF-8_F.F90 @@ -0,0 +1,3 @@ +print *, "Hello world" +end +! { dg-do compile } diff --git a/Fortran/gfortran/regression/bom_error.f90 b/Fortran/gfortran/regression/bom_error.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bom_error.f90 @@ -0,0 +1,4 @@ +��print *, "Hello world!" +��end ! { dg-error "Invalid character" } +! { dg-do compile } +! { dg-error "Unexpected end of file" "" { target "*-*-*" } 0 } diff --git a/Fortran/gfortran/regression/bom_include.f90 b/Fortran/gfortran/regression/bom_include.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bom_include.f90 @@ -0,0 +1,2 @@ +! { dg-do compile } +include "bom_include.inc" diff --git a/Fortran/gfortran/regression/bom_include.inc b/Fortran/gfortran/regression/bom_include.inc --- /dev/null +++ b/Fortran/gfortran/regression/bom_include.inc @@ -0,0 +1,2 @@ +print *, "Hello world!" +end diff --git a/Fortran/gfortran/regression/bound_1.f90 b/Fortran/gfortran/regression/bound_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bound_1.f90 @@ -0,0 +1,20 @@ +! { dg-do run } + implicit none + + type test_type + integer, dimension(5) :: a + end type test_type + + type (test_type), target :: tt(2) + integer i + + i = ubound(tt(1)%a, 1) + if (i/=5) STOP 1 + i = lbound(tt(1)%a, 1) + if (i/=1) STOP 2 + + i = ubound(tt, 1) + if (i/=2) STOP 3 + i = lbound(tt, 1) + if (i/=1) STOP 4 +end diff --git a/Fortran/gfortran/regression/bound_2.f90 b/Fortran/gfortran/regression/bound_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bound_2.f90 @@ -0,0 +1,220 @@ +! { dg-do run } +! { dg-options "-std=gnu" } +! PR fortran/29391 +! This file is here to check that LBOUND and UBOUND return correct values +! +! Contributed by Francois-Xavier Coudert (coudert@clipper.ens.fr) + implicit none + integer :: i(-1:1,-1:1) = 0 + integer :: j(-1:2) = 0 + integer :: u(7,4,2,9) + + call foo(u,4) + call jackal(-1,-8) + call jackal(-1,8) + + if (any(lbound(i(-1:1,-1:1)) /= 1)) STOP 1 + if (lbound(i(-1:1,-1:1), 1) /= 1) STOP 2 + if (lbound(i(-1:1,-1:1), 2) /= 1) STOP 3 + + if (any(ubound(i(-1:1,-1:1)) /= 3)) STOP 4 + if (ubound(i(-1:1,-1:1), 1) /= 3) STOP 5 + if (ubound(i(-1:1,-1:1), 2) /= 3) STOP 6 + + if (any(lbound(i(:,:)) /= 1)) STOP 7 + if (lbound(i(:,:), 1) /= 1) STOP 8 + if (lbound(i(:,:), 2) /= 1) STOP 9 + + if (any(ubound(i(:,:)) /= 3)) STOP 10 + if (ubound(i(:,:), 1) /= 3) STOP 11 + if (ubound(i(:,:), 2) /= 3) STOP 12 + + if (any(lbound(i(0:,-1:)) /= 1)) STOP 13 + if (lbound(i(0:,-1:), 1) /= 1) STOP 14 + if (lbound(i(0:,-1:), 2) /= 1) STOP 15 + + if (any(ubound(i(0:,-1:)) /= [2,3])) STOP 16 + if (ubound(i(0:,-1:), 1) /= 2) STOP 17 + if (ubound(i(0:,-1:), 2) /= 3) STOP 18 + + if (any(lbound(i(:0,:0)) /= 1)) STOP 19 + if (lbound(i(:0,:0), 1) /= 1) STOP 20 + if (lbound(i(:0,:0), 2) /= 1) STOP 21 + + if (any(ubound(i(:0,:0)) /= 2)) STOP 22 + if (ubound(i(:0,:0), 1) /= 2) STOP 23 + if (ubound(i(:0,:0), 2) /= 2) STOP 24 + + if (any(lbound(transpose(i)) /= 1)) STOP 25 + if (lbound(transpose(i), 1) /= 1) STOP 26 + if (lbound(transpose(i), 2) /= 1) STOP 27 + + if (any(ubound(transpose(i)) /= 3)) STOP 28 + if (ubound(transpose(i), 1) /= 3) STOP 29 + if (ubound(transpose(i), 2) /= 3) STOP 30 + + if (any(lbound(reshape(i,[2,2])) /= 1)) STOP 31 + if (lbound(reshape(i,[2,2]), 1) /= 1) STOP 32 + if (lbound(reshape(i,[2,2]), 2) /= 1) STOP 33 + + if (any(ubound(reshape(i,[2,2])) /= 2)) STOP 34 + if (ubound(reshape(i,[2,2]), 1) /= 2) STOP 35 + if (ubound(reshape(i,[2,2]), 2) /= 2) STOP 36 + + if (any(lbound(cshift(i,-1)) /= 1)) STOP 37 + if (lbound(cshift(i,-1), 1) /= 1) STOP 38 + if (lbound(cshift(i,-1), 2) /= 1) STOP 39 + + if (any(ubound(cshift(i,-1)) /= 3)) STOP 40 + if (ubound(cshift(i,-1), 1) /= 3) STOP 41 + if (ubound(cshift(i,-1), 2) /= 3) STOP 42 + + if (any(lbound(eoshift(i,-1)) /= 1)) STOP 43 + if (lbound(eoshift(i,-1), 1) /= 1) STOP 44 + if (lbound(eoshift(i,-1), 2) /= 1) STOP 45 + + if (any(ubound(eoshift(i,-1)) /= 3)) STOP 46 + if (ubound(eoshift(i,-1), 1) /= 3) STOP 47 + if (ubound(eoshift(i,-1), 2) /= 3) STOP 48 + + if (any(lbound(spread(i,1,2)) /= 1)) STOP 49 + if (lbound(spread(i,1,2), 1) /= 1) STOP 50 + if (lbound(spread(i,1,2), 2) /= 1) STOP 51 + + if (any(ubound(spread(i,1,2)) /= [2,3,3])) STOP 52 + if (ubound(spread(i,1,2), 1) /= 2) STOP 53 + if (ubound(spread(i,1,2), 2) /= 3) STOP 54 + if (ubound(spread(i,1,2), 3) /= 3) STOP 55 + + if (any(lbound(maxloc(i)) /= 1)) STOP 56 + if (lbound(maxloc(i), 1) /= 1) STOP 57 + + if (any(ubound(maxloc(i)) /= 2)) STOP 58 + if (ubound(maxloc(i), 1) /= 2) STOP 59 + + if (any(lbound(minloc(i)) /= 1)) STOP 60 + if (lbound(minloc(i), 1) /= 1) STOP 61 + + if (any(ubound(minloc(i)) /= 2)) STOP 62 + if (ubound(minloc(i), 1) /= 2) STOP 63 + + if (any(lbound(maxval(i,2)) /= 1)) STOP 64 + if (lbound(maxval(i,2), 1) /= 1) STOP 65 + + if (any(ubound(maxval(i,2)) /= 3)) STOP 66 + if (ubound(maxval(i,2), 1) /= 3) STOP 67 + + if (any(lbound(minval(i,2)) /= 1)) STOP 68 + if (lbound(minval(i,2), 1) /= 1) STOP 69 + + if (any(ubound(minval(i,2)) /= 3)) STOP 70 + if (ubound(minval(i,2), 1) /= 3) STOP 71 + + if (any(lbound(any(i==1,2)) /= 1)) STOP 72 + if (lbound(any(i==1,2), 1) /= 1) STOP 73 + + if (any(ubound(any(i==1,2)) /= 3)) STOP 74 + if (ubound(any(i==1,2), 1) /= 3) STOP 75 + + if (any(lbound(count(i==1,2)) /= 1)) STOP 76 + if (lbound(count(i==1,2), 1) /= 1) STOP 77 + + if (any(ubound(count(i==1,2)) /= 3)) STOP 78 + if (ubound(count(i==1,2), 1) /= 3) STOP 79 + + if (any(lbound(merge(i,i,.true.)) /= 1)) STOP 80 + if (lbound(merge(i,i,.true.), 1) /= 1) STOP 81 + if (lbound(merge(i,i,.true.), 2) /= 1) STOP 82 + + if (any(ubound(merge(i,i,.true.)) /= 3)) STOP 83 + if (ubound(merge(i,i,.true.), 1) /= 3) STOP 84 + if (ubound(merge(i,i,.true.), 2) /= 3) STOP 85 + + if (any(lbound(lbound(i)) /= 1)) STOP 86 + if (lbound(lbound(i), 1) /= 1) STOP 87 + + if (any(ubound(lbound(i)) /= 2)) STOP 88 + if (ubound(lbound(i), 1) /= 2) STOP 89 + + if (any(lbound(ubound(i)) /= 1)) STOP 90 + if (lbound(ubound(i), 1) /= 1) STOP 91 + + if (any(ubound(ubound(i)) /= 2)) STOP 92 + if (ubound(ubound(i), 1) /= 2) STOP 93 + + if (any(lbound(shape(i)) /= 1)) STOP 94 + if (lbound(shape(i), 1) /= 1) STOP 95 + + if (any(ubound(shape(i)) /= 2)) STOP 96 + if (ubound(shape(i), 1) /= 2) STOP 97 + + if (any(lbound(product(i,2)) /= 1)) STOP 98 + if (any(ubound(product(i,2)) /= 3)) STOP 99 + if (any(lbound(sum(i,2)) /= 1)) STOP 100 + if (any(ubound(sum(i,2)) /= 3)) STOP 101 + if (any(lbound(matmul(i,i)) /= 1)) STOP 102 + if (any(ubound(matmul(i,i)) /= 3)) STOP 103 + if (any(lbound(pack(i,.true.)) /= 1)) STOP 104 + if (any(ubound(pack(i,.true.)) /= 9)) STOP 105 + if (any(lbound(unpack(j,[.true.],[2])) /= 1)) STOP 106 + if (any(ubound(unpack(j,[.true.],[2])) /= 1)) STOP 107 + + call sub1(i,3) + call sub1(reshape([7,9,4,6,7,9],[3,2]),3) + call sub2 + +contains + + subroutine sub1(a,n) + integer :: n, a(2:n+1,4:*) + + if (any([lbound(a,1), lbound(a,2)] /= [2, 4])) STOP 108 + if (any(lbound(a) /= [2, 4])) STOP 109 + end subroutine sub1 + + subroutine sub2 + integer :: x(3:2, 1:2) + + if (size(x) /= 0) STOP 110 + if (lbound (x, 1) /= 1 .or. lbound(x, 2) /= 1) STOP 111 + if (any (lbound (x) /= [1, 1])) STOP 112 + if (ubound (x, 1) /= 0 .or. ubound(x, 2) /= 2) STOP 113 + if (any (ubound (x) /= [0, 2])) STOP 114 + end subroutine sub2 + + subroutine sub3 + integer :: x(4:5, 1:2) + + if (size(x) /= 0) STOP 115 + if (lbound (x, 1) /= 4 .or. lbound(x, 2) /= 1) STOP 116 + if (any (lbound (x) /= [4, 1])) STOP 117 + if (ubound (x, 1) /= 4 .or. ubound(x, 2) /= 2) STOP 118 + if (any (ubound (x) /= [4, 2])) STOP 119 + end subroutine sub3 + + subroutine foo (x,n) + integer :: n + integer :: x(7,n,2,*) + + if (ubound(x,1) /= 7 .or. ubound(x,2) /= 4 .or. ubound(x,3) /= 2) STOP 120 + end subroutine foo + + subroutine jackal (b, c) + integer :: b, c + integer :: soda(b:c, 3:4) + + if (b > c) then + if (size(soda) /= 0) STOP 121 + if (lbound (soda, 1) /= 1 .or. ubound (soda, 1) /= 0) STOP 122 + else + if (size(soda) /= 2*(c-b+1)) STOP 123 + if (lbound (soda, 1) /= b .or. ubound (soda, 1) /= c) STOP 124 + end if + + if (lbound (soda, 2) /= 3 .or. ubound (soda, 2) /= 4) STOP 125 + if (any (lbound (soda) /= [lbound(soda,1), lbound(soda,2)])) STOP 126 + if (any (ubound (soda) /= [ubound(soda,1), ubound(soda,2)])) STOP 127 + + end subroutine jackal + +end diff --git a/Fortran/gfortran/regression/bound_3.f90 b/Fortran/gfortran/regression/bound_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bound_3.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! + call s(1,0) + call s(2,0) + call s(3,0) + call s(4,0) + call s(5,1) + call s(6,2) + call s(7,3) +contains + subroutine s(n,m) + implicit none + integer n, m + real x(10) + if (any (lbound(x(5:n)) /= 1)) STOP 1 + if (lbound(x(5:n),1) /= 1) STOP 2 + if (any (ubound(x(5:n)) /= m)) STOP 3 + if (ubound(x(5:n),1) /= m) STOP 4 + end subroutine +end program diff --git a/Fortran/gfortran/regression/bound_4.f90 b/Fortran/gfortran/regression/bound_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bound_4.f90 @@ -0,0 +1,30 @@ +! { dg-do run } + +program test + integer x(20) + integer, volatile :: n + n = 1 + if (size(x(n:2:-3)) /= 0) STOP 1 + + call ha0020(-3) + call ha0020(-1) +end program test + +subroutine ha0020(mf3) + implicit none + integer xca(2), xda(2), mf3 + + xca = 1 + xda = -1 + + xca(1:2:-1) = xda(1:2:mf3) + + if (any (xca /= 1)) STOP 2 + if (any(xda(1:2:mf3) /= xda(1:0))) STOP 3 + if (size(xda(1:2:mf3)) /= 0) STOP 4 + if (any(shape(xda(1:2:mf3)) /= 0)) STOP 5 + if (any(ubound(xda(1:2:mf3)) /= 0)) STOP 6 + if (ubound(xda(1:2:mf3),1) /= 0) STOP 7 + if (lbound(xda(1:2:mf3),1) /= 1) STOP 8 + +end subroutine diff --git a/Fortran/gfortran/regression/bound_5.f90 b/Fortran/gfortran/regression/bound_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bound_5.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! +! PR fortran/38859 +! Wrong bounds simplification +! +! Contributed by Dick Hendrickson + + type x + integer I + end type x + type (x) A(0:5, 2:8) + integer ida(2) + + ida = lbound(a) + if (any(ida /= (/0,2/))) STOP 1 + + ida = lbound(a%i) + if (any(ida /= (/1,1/))) STOP 2 + + ida = ubound(a) + if (any(ida /= (/5,8/))) STOP 3 + + ida = ubound(a%i) + if (any(ida /= (/6,7/))) STOP 4 + + end diff --git a/Fortran/gfortran/regression/bound_6.f90 b/Fortran/gfortran/regression/bound_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bound_6.f90 @@ -0,0 +1,71 @@ +! { dg-do run } +! Test the fix for PR38852 and PR39006 in which LBOUND did not work +! for some arrays with negative strides. +! +! Contributed by Dick Hendrickson +! Clive Page +! and Mikael Morin +! +program try_je0031 + integer ida(4) + real dda(5,5,5,5,5) + integer, parameter :: nx = 4, ny = 3 + interface + SUBROUTINE PR38852(IDA,DDA,nf2,nf5,mf2) + INTEGER IDA(4) + REAL DDA(5,5,5,5,5) + TARGET DDA + END SUBROUTINE + end interface + integer :: array1(nx,ny), array2(nx,ny) + data array2 / 1,2,3,4, 10,20,30,40, 100,200,300,400 / + array1 = array2 + call PR38852(IDA,DDA,2,5,-2) + call PR39006(array1, array2(:,ny:1:-1)) + call mikael ! http://gcc.gnu.org/ml/fortran/2009-01/msg00342.html +contains + subroutine PR39006(array1, array2) + integer, intent(in) :: array1(:,:), array2(:,:) + integer :: j + do j = 1, ubound(array2,2) + if (any (array1(:,j) .ne. array2(:,4-j))) STOP 1 + end do + end subroutine +end + +SUBROUTINE PR38852(IDA,DDA,nf2,nf5,mf2) + INTEGER IDA(4) + REAL DLA(:,:,:,:) + REAL DDA(5,5,5,5,5) + POINTER DLA + TARGET DDA + DLA => DDA(2:3, 1:3:2, 5:4:-1, NF2, NF5:NF2:MF2) + IDA = UBOUND(DLA) + if (any(ida /= 2)) STOP 1 + DLA => DDA(2:3, 1:3:2, 5:4:-1, 2, 5:2:-2) + IDA = UBOUND(DLA) + if (any(ida /= 2)) STOP 1 +! +! These worked. +! + DLA => DDA(2:3, 1:3:2, 5:4:-1, 2, 5:2:-2) + IDA = shape(DLA) + if (any(ida /= 2)) STOP 1 + DLA => DDA(2:3, 1:3:2, 5:4:-1, 2, 5:2:-2) + IDA = LBOUND(DLA) + if (any(ida /= 1)) STOP 1 +END SUBROUTINE + +subroutine mikael + implicit none + call test (1, 3, 3) + call test (2, 3, 3) + call test (2, -1, 0) + call test (1, -1, 0) +contains + subroutine test (a, b, expect) + integer :: a, b, expect + integer :: c(a:b) + if (ubound (c, 1) .ne. expect) STOP 1 + end subroutine test +end subroutine diff --git a/Fortran/gfortran/regression/bound_7.f90 b/Fortran/gfortran/regression/bound_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bound_7.f90 @@ -0,0 +1,223 @@ +! { dg-do run } +! { dg-options "-std=gnu" } +! PR fortran/29391 +! This file is here to check that LBOUND and UBOUND return correct values +! +! Contributed by Francois-Xavier Coudert (coudert@clipper.ens.fr) + implicit none + integer, allocatable :: i(:,:), j(:), u(:,:,:,:) + + allocate (i(-1:1,-1:1)) + i = 0 + allocate (j(-1:2)) + j = 0 + allocate (u(7,4,2,9)) + + call foo(u,4) + call jackal(-1,-8) + call jackal(-1,8) + + if (any(lbound(i(-1:1,-1:1)) /= 1)) STOP 1 + if (lbound(i(-1:1,-1:1), 1) /= 1) STOP 2 + if (lbound(i(-1:1,-1:1), 2) /= 1) STOP 3 + + if (any(ubound(i(-1:1,-1:1)) /= 3)) STOP 4 + if (ubound(i(-1:1,-1:1), 1) /= 3) STOP 5 + if (ubound(i(-1:1,-1:1), 2) /= 3) STOP 6 + + if (any(lbound(i(:,:)) /= 1)) STOP 7 + if (lbound(i(:,:), 1) /= 1) STOP 8 + if (lbound(i(:,:), 2) /= 1) STOP 9 + + if (any(ubound(i(:,:)) /= 3)) STOP 10 + if (ubound(i(:,:), 1) /= 3) STOP 11 + if (ubound(i(:,:), 2) /= 3) STOP 12 + + if (any(lbound(i(0:,-1:)) /= 1)) STOP 13 + if (lbound(i(0:,-1:), 1) /= 1) STOP 14 + if (lbound(i(0:,-1:), 2) /= 1) STOP 15 + + if (any(ubound(i(0:,-1:)) /= [2,3])) STOP 16 + if (ubound(i(0:,-1:), 1) /= 2) STOP 17 + if (ubound(i(0:,-1:), 2) /= 3) STOP 18 + + if (any(lbound(i(:0,:0)) /= 1)) STOP 19 + if (lbound(i(:0,:0), 1) /= 1) STOP 20 + if (lbound(i(:0,:0), 2) /= 1) STOP 21 + + if (any(ubound(i(:0,:0)) /= 2)) STOP 22 + if (ubound(i(:0,:0), 1) /= 2) STOP 23 + if (ubound(i(:0,:0), 2) /= 2) STOP 24 + + if (any(lbound(transpose(i)) /= 1)) STOP 25 + if (lbound(transpose(i), 1) /= 1) STOP 26 + if (lbound(transpose(i), 2) /= 1) STOP 27 + + if (any(ubound(transpose(i)) /= 3)) STOP 28 + if (ubound(transpose(i), 1) /= 3) STOP 29 + if (ubound(transpose(i), 2) /= 3) STOP 30 + + if (any(lbound(reshape(i,[2,2])) /= 1)) STOP 31 + if (lbound(reshape(i,[2,2]), 1) /= 1) STOP 32 + if (lbound(reshape(i,[2,2]), 2) /= 1) STOP 33 + + if (any(ubound(reshape(i,[2,2])) /= 2)) STOP 34 + if (ubound(reshape(i,[2,2]), 1) /= 2) STOP 35 + if (ubound(reshape(i,[2,2]), 2) /= 2) STOP 36 + + if (any(lbound(cshift(i,-1)) /= 1)) STOP 37 + if (lbound(cshift(i,-1), 1) /= 1) STOP 38 + if (lbound(cshift(i,-1), 2) /= 1) STOP 39 + + if (any(ubound(cshift(i,-1)) /= 3)) STOP 40 + if (ubound(cshift(i,-1), 1) /= 3) STOP 41 + if (ubound(cshift(i,-1), 2) /= 3) STOP 42 + + if (any(lbound(eoshift(i,-1)) /= 1)) STOP 43 + if (lbound(eoshift(i,-1), 1) /= 1) STOP 44 + if (lbound(eoshift(i,-1), 2) /= 1) STOP 45 + + if (any(ubound(eoshift(i,-1)) /= 3)) STOP 46 + if (ubound(eoshift(i,-1), 1) /= 3) STOP 47 + if (ubound(eoshift(i,-1), 2) /= 3) STOP 48 + + if (any(lbound(spread(i,1,2)) /= 1)) STOP 49 + if (lbound(spread(i,1,2), 1) /= 1) STOP 50 + if (lbound(spread(i,1,2), 2) /= 1) STOP 51 + + if (any(ubound(spread(i,1,2)) /= [2,3,3])) STOP 52 + if (ubound(spread(i,1,2), 1) /= 2) STOP 53 + if (ubound(spread(i,1,2), 2) /= 3) STOP 54 + if (ubound(spread(i,1,2), 3) /= 3) STOP 55 + + if (any(lbound(maxloc(i)) /= 1)) STOP 56 + if (lbound(maxloc(i), 1) /= 1) STOP 57 + + if (any(ubound(maxloc(i)) /= 2)) STOP 58 + if (ubound(maxloc(i), 1) /= 2) STOP 59 + + if (any(lbound(minloc(i)) /= 1)) STOP 60 + if (lbound(minloc(i), 1) /= 1) STOP 61 + + if (any(ubound(minloc(i)) /= 2)) STOP 62 + if (ubound(minloc(i), 1) /= 2) STOP 63 + + if (any(lbound(maxval(i,2)) /= 1)) STOP 64 + if (lbound(maxval(i,2), 1) /= 1) STOP 65 + + if (any(ubound(maxval(i,2)) /= 3)) STOP 66 + if (ubound(maxval(i,2), 1) /= 3) STOP 67 + + if (any(lbound(minval(i,2)) /= 1)) STOP 68 + if (lbound(minval(i,2), 1) /= 1) STOP 69 + + if (any(ubound(minval(i,2)) /= 3)) STOP 70 + if (ubound(minval(i,2), 1) /= 3) STOP 71 + + if (any(lbound(any(i==1,2)) /= 1)) STOP 72 + if (lbound(any(i==1,2), 1) /= 1) STOP 73 + + if (any(ubound(any(i==1,2)) /= 3)) STOP 74 + if (ubound(any(i==1,2), 1) /= 3) STOP 75 + + if (any(lbound(count(i==1,2)) /= 1)) STOP 76 + if (lbound(count(i==1,2), 1) /= 1) STOP 77 + + if (any(ubound(count(i==1,2)) /= 3)) STOP 78 + if (ubound(count(i==1,2), 1) /= 3) STOP 79 + + if (any(lbound(merge(i,i,.true.)) /= 1)) STOP 80 + if (lbound(merge(i,i,.true.), 1) /= 1) STOP 81 + if (lbound(merge(i,i,.true.), 2) /= 1) STOP 82 + + if (any(ubound(merge(i,i,.true.)) /= 3)) STOP 83 + if (ubound(merge(i,i,.true.), 1) /= 3) STOP 84 + if (ubound(merge(i,i,.true.), 2) /= 3) STOP 85 + + if (any(lbound(lbound(i)) /= 1)) STOP 86 + if (lbound(lbound(i), 1) /= 1) STOP 87 + + if (any(ubound(lbound(i)) /= 2)) STOP 88 + if (ubound(lbound(i), 1) /= 2) STOP 89 + + if (any(lbound(ubound(i)) /= 1)) STOP 90 + if (lbound(ubound(i), 1) /= 1) STOP 91 + + if (any(ubound(ubound(i)) /= 2)) STOP 92 + if (ubound(ubound(i), 1) /= 2) STOP 93 + + if (any(lbound(shape(i)) /= 1)) STOP 94 + if (lbound(shape(i), 1) /= 1) STOP 95 + + if (any(ubound(shape(i)) /= 2)) STOP 96 + if (ubound(shape(i), 1) /= 2) STOP 97 + + if (any(lbound(product(i,2)) /= 1)) STOP 98 + if (any(ubound(product(i,2)) /= 3)) STOP 99 + if (any(lbound(sum(i,2)) /= 1)) STOP 100 + if (any(ubound(sum(i,2)) /= 3)) STOP 101 + if (any(lbound(matmul(i,i)) /= 1)) STOP 102 + if (any(ubound(matmul(i,i)) /= 3)) STOP 103 + if (any(lbound(pack(i,.true.)) /= 1)) STOP 104 + if (any(ubound(pack(i,.true.)) /= 9)) STOP 105 + if (any(lbound(unpack(j,[.true.],[2])) /= 1)) STOP 106 + if (any(ubound(unpack(j,[.true.],[2])) /= 1)) STOP 107 + + call sub1(i,3) + call sub1(reshape([7,9,4,6,7,9],[3,2]),3) + call sub2 + +contains + + subroutine sub1(a,n) + integer :: n, a(2:n+1,4:*) + + if (any([lbound(a,1), lbound(a,2)] /= [2, 4])) STOP 108 + if (any(lbound(a) /= [2, 4])) STOP 109 + end subroutine sub1 + + subroutine sub2 + integer :: x(3:2, 1:2) + + if (size(x) /= 0) STOP 110 + if (lbound (x, 1) /= 1 .or. lbound(x, 2) /= 1) STOP 111 + if (any (lbound (x) /= [1, 1])) STOP 112 + if (ubound (x, 1) /= 0 .or. ubound(x, 2) /= 2) STOP 113 + if (any (ubound (x) /= [0, 2])) STOP 114 + end subroutine sub2 + + subroutine sub3 + integer :: x(4:5, 1:2) + + if (size(x) /= 0) STOP 115 + if (lbound (x, 1) /= 4 .or. lbound(x, 2) /= 1) STOP 116 + if (any (lbound (x) /= [4, 1])) STOP 117 + if (ubound (x, 1) /= 4 .or. ubound(x, 2) /= 2) STOP 118 + if (any (ubound (x) /= [4, 2])) STOP 119 + end subroutine sub3 + + subroutine foo (x,n) + integer :: x(7,n,2,*), n + + if (ubound(x,1) /= 7 .or. ubound(x,2) /= 4 .or. ubound(x,3) /= 2) STOP 120 + end subroutine foo + + subroutine jackal (b, c) + integer :: b, c + integer :: soda(b:c, 3:4) + + if (b > c) then + if (size(soda) /= 0) STOP 121 + if (lbound (soda, 1) /= 1 .or. ubound (soda, 1) /= 0) STOP 122 + else + if (size(soda) /= 2*(c-b+1)) STOP 123 + if (lbound (soda, 1) /= b .or. ubound (soda, 1) /= c) STOP 124 + end if + + if (lbound (soda, 2) /= 3 .or. ubound (soda, 2) /= 4) STOP 125 + if (any (lbound (soda) /= [lbound(soda,1), lbound(soda,2)])) STOP 126 + if (any (ubound (soda) /= [ubound(soda,1), ubound(soda,2)])) STOP 127 + + end subroutine jackal + +end diff --git a/Fortran/gfortran/regression/bound_8.f90 b/Fortran/gfortran/regression/bound_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bound_8.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! { dg-options "-Warray-temporaries " } + +! Check that LBOUND/UBOUND/SIZE/SHAPE of array-expressions get simplified +! in certain cases. +! There should no array-temporaries warnings pop up, as this means that +! the intrinsic call has not been properly simplified. + +! Contributed by Daniel Kraft, d@domob.eu. + +PROGRAM main + IMPLICIT NONE + + ! Some explicitely shaped arrays and allocatable ones. + INTEGER :: a(2, 3), b(0:1, 4:6) + INTEGER, ALLOCATABLE :: x(:, :), y(:, :) + + ! Allocate to matching sizes and initialize. + ALLOCATE (x(-1:0, -3:-1), y(11:12, 3)) + a = 0 + b = 1 + x = 2 + y = 3 + + ! Run the checks. This should be simplified without array temporaries, + ! and additionally correct (of course). + + ! Shape of expressions known at compile-time. + IF (ANY (LBOUND (a + b) /= 1)) STOP 1 + IF (ANY (UBOUND (2 * b) /= (/ 2, 3 /))) STOP 2 + IF (ANY (SHAPE (- b) /= (/ 2, 3 /))) STOP 3 + IF (SIZE (a ** 2) /= 6) STOP 1 + + ! Shape unknown at compile-time. + IF (ANY (LBOUND (x + y) /= 1)) STOP 4 + IF (SIZE (x ** 2) /= 6) STOP 5 + + ! Unfortunately, the array-version of UBOUND and SHAPE keep generating + ! temporary arrays for their results (not for the operation). Thus we + ! can not check SHAPE in this case and do UBOUND in the single-dimension + ! version. + IF (UBOUND (2 * y, 1) /= 2 .OR. UBOUND (2 * y, 2) /= 3) STOP 6 + !IF (ANY (SHAPE (- y) /= (/ 2, 3 /))) STOP 7 +END PROGRAM main diff --git a/Fortran/gfortran/regression/bound_9.f90 b/Fortran/gfortran/regression/bound_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bound_9.f90 @@ -0,0 +1,70 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! Check for different combinations of lbound for dummy arrays, +! stressing empty arrays. The assignments with "one =" should +! be simplified at compile time. +module tst + implicit none +contains + subroutine foo (a, b, one, m) + integer, dimension(:), intent(in) :: a + integer, dimension (-2:), intent(in) :: b + integer, intent(out) :: one, m + one = lbound(a,1) + m = lbound(b,1) + end subroutine foo + + subroutine bar (a, b, n, m) + integer, dimension(:), allocatable, intent(inout) :: a + integer, dimension(:), pointer, intent(inout) :: b + integer, intent(out) :: n, m + n = lbound(a,1) + m = lbound(b,1) + end subroutine bar + + subroutine baz (a, n, m, s) + integer, intent(in) :: n,m + integer, intent(out) :: s + integer, dimension(n:m) :: a + s = lbound(a,1) + end subroutine baz + + subroutine qux (a, s, one) + integer, intent(in) :: s + integer, dimension(s) :: a + integer, intent(out) :: one + one = lbound(a,1) + end subroutine qux +end module tst + +program main + use tst + implicit none + integer, dimension(3), target :: a, b + integer, dimension(0) :: empty + integer, dimension(:), allocatable :: x + integer, dimension(:), pointer :: y + integer :: n,m + + + call foo(a,b,n,m) + if (n .ne. 1 .or. m .ne. -2) STOP 1 + call foo(a(2:0), empty, n, m) + if (n .ne. 1 .or. m .ne. 1) STOP 2 + call foo(empty, a(2:0), n, m) + if (n .ne. 1 .or. m .ne. 1) STOP 3 + allocate (x(0)) + y => a(3:2) + call bar (x, y, n, m) + if (n .ne. 1 .or. m .ne. 1) STOP 4 + + call baz(a,3,2,n) + if (n .ne. 1) STOP 5 + + call baz(a,2,3,n) + if (n .ne. 2) STOP 6 + + call qux(a, -3, n) + if (n .ne. 1) STOP 7 +end program main +! { dg-final { scan-tree-dump-times "\\*one = 1" 2 "original" } } diff --git a/Fortran/gfortran/regression/bound_resolve_after_error_1.f90 b/Fortran/gfortran/regression/bound_resolve_after_error_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bound_resolve_after_error_1.f90 @@ -0,0 +1,13 @@ +! Testcase for bound check after issued error +! See PR 94192 +! { dg-do compile } +program bound_for_illegal + +contains + + subroutine bnds(a) ! { dg-error "must have a deferred shape or assumed rank" } + integer, pointer, intent(in) :: a(1:2) + print *,lbound(a) + end subroutine bnds + +end program bound_for_illegal diff --git a/Fortran/gfortran/regression/bound_simplification_1.f90 b/Fortran/gfortran/regression/bound_simplification_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bound_simplification_1.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! { dg-options "" } + implicit none + real :: f(10,10,10,3,4) + integer, parameter :: upper(5) = ubound(f), lower(5) = lbound (f) + integer :: varu(5), varl(5) + + varu(:) = ubound(f) + varl(:) = lbound(f) + if (any (varu /= upper)) STOP 1 + if (any (varl /= lower)) STOP 2 + + call check (f, upper, lower) + call check (f, ubound(f), lbound(f)) + +contains + + subroutine check (f, upper, lower) + implicit none + integer :: upper(5), lower(5) + real :: f(:,:,:,:,:) + + if (any (ubound(f) /= upper)) STOP 3 + if (any (lbound(f) /= lower)) STOP 4 + end subroutine check + +end diff --git a/Fortran/gfortran/regression/bound_simplification_2.f90 b/Fortran/gfortran/regression/bound_simplification_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bound_simplification_2.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR 38914 - this used to give an ICE due to missing +! simplification. +module foo + INTEGER, PARAMETER, DIMENSION(0:20,4) :: IP_ARRAY2_4_S = 0 + INTEGER, PARAMETER, DIMENSION(2) :: IP_ARRAY1_32_S = & + & (/ LBOUND(IP_ARRAY2_4_S(5:10,2:3))/) +END module foo diff --git a/Fortran/gfortran/regression/bound_simplification_3.f90 b/Fortran/gfortran/regression/bound_simplification_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bound_simplification_3.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/54208 +! The I and J definitions used to raise an error because ARR's array spec +! was resolved to late for the LBOUND and UBOUND calls to be simplified to +! a constant. +! +! Contributed by Carlos A. Cruz + +program testit + integer, parameter :: n=2 + integer, dimension(1-min(n,2)/2:n) :: arr + integer, parameter :: i=lbound(arr,1) + integer, parameter :: j=ubound(arr,1) + ! write(6,*) i, j + if (i /= 0) STOP 1 + if (j /= 2) STOP 2 +end program testit + +! { dg-final { scan-tree-dump-times "bound" 0 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_stop" 0 "original" } } diff --git a/Fortran/gfortran/regression/bound_simplification_4.f90 b/Fortran/gfortran/regression/bound_simplification_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bound_simplification_4.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! { dg-additional-options "-fcoarray=single -fdump-tree-original" } +! +! Check that {L,U}{,CO}BOUND intrinsics are properly simplified. +! + type :: t + integer :: c + end type t + + type(t) :: d(3:8) = t(7) + type(t) :: e[5:9,-1:*] + + if (lbound(d, 1) /= 3) STOP 1 + if (lbound(d(3:5), 1) /= 1) STOP 2 + if (lbound(d%c, 1) /= 1) STOP 3 + if (ubound(d, 1) /= 8) STOP 4 + if (ubound(d(3:5), 1) /= 3) STOP 5 + if (ubound(d%c, 1) /= 6) STOP 6 + + if (lcobound(e, 1) /= 5) STOP 7 + if (lcobound(e%c, 1) /= 5) STOP 8 + if (lcobound(e, 2) /= -1) STOP 9 + if (lcobound(e%c, 2) /= -1) STOP 10 + if (ucobound(e, 1) /= 9) STOP 11 + if (ucobound(e%c, 1) /= 9) STOP 12 + ! no simplification for ucobound(e{,%c}, dim=2) +end +! { dg-final { scan-tree-dump-not "bound" "original" } } +! { dg-final { scan-tree-dump-not "_gfortran_stop" "original" } } diff --git a/Fortran/gfortran/regression/bound_simplification_5.f90 b/Fortran/gfortran/regression/bound_simplification_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bound_simplification_5.f90 @@ -0,0 +1,74 @@ +! { dg-do run } +! { dg-additional-options "-fcoarray=single -fdump-tree-original" } +! +! Check that {L,U}{,CO}BOUND intrinsics are properly simplified. +! + implicit none + + type :: t + integer :: c + end type t + + type(t) :: d(3:8) = t(7) + type(t) :: e[5:9,-1:*] + type(t) :: h(3), j(4), k(0) + + !Test full arrays vs subarrays + if (lbound(d, 1) /= 3) STOP 1 + if (lbound(d(3:5), 1) /= 1) STOP 2 + if (lbound(d%c, 1) /= 1) STOP 3 + if (ubound(d, 1) /= 8) STOP 4 + if (ubound(d(3:5), 1) /= 3) STOP 5 + if (ubound(d%c, 1) /= 6) STOP 6 + + if (lcobound(e, 1) /= 5) STOP 7 + if (lcobound(e%c, 1) /= 5) STOP 8 + if (lcobound(e, 2) /= -1) STOP 9 + if (lcobound(e%c, 2) /= -1) STOP 10 + if (ucobound(e, 1) /= 9) STOP 11 + if (ucobound(e%c, 1) /= 9) STOP 12 + ! no simplification for ucobound(e{,%c}, dim=2) + + if (any(lbound(d ) /= [3])) STOP 13 + if (any(lbound(d(3:5)) /= [1])) STOP 14 + if (any(lbound(d%c ) /= [1])) STOP 15 + if (any(ubound(d ) /= [8])) STOP 16 + if (any(ubound(d(3:5)) /= [3])) STOP 17 + if (any(ubound(d%c ) /= [6])) STOP 18 + + if (any(lcobound(e ) /= [5, -1])) STOP 19 + if (any(lcobound(e%c) /= [5, -1])) STOP 20 + ! no simplification for ucobound(e{,%c}) + + call test_empty_arrays(h, j, k) + +contains + subroutine test_empty_arrays(a, c, d) + type(t) :: a(:), c(-3:0), d(3:1) + type(t) :: f(4:2), g(0:6) + + if (lbound(a, 1) /= 1) STOP 21 + if (lbound(c, 1) /= -3) STOP 22 + if (lbound(d, 1) /= 1) STOP 23 + if (lbound(f, 1) /= 1) STOP 24 + if (lbound(g, 1) /= 0) STOP 25 + + if (ubound(c, 1) /= 0) STOP 26 + if (ubound(d, 1) /= 0) STOP 27 + if (ubound(f, 1) /= 0) STOP 28 + if (ubound(g, 1) /= 6) STOP 29 + + if (any(lbound(a) /= [ 1])) STOP 30 + if (any(lbound(c) /= [-3])) STOP 31 + if (any(lbound(d) /= [ 1])) STOP 32 + if (any(lbound(f) /= [ 1])) STOP 33 + if (any(lbound(g) /= [ 0])) STOP 34 + + if (any(ubound(c) /= [0])) STOP 35 + if (any(ubound(d) /= [0])) STOP 36 + if (any(ubound(f) /= [0])) STOP 37 + if (any(ubound(g) /= [6])) STOP 38 + + end subroutine +end +! { dg-final { scan-tree-dump-not "_gfortran_stop" "original" } } diff --git a/Fortran/gfortran/regression/bound_simplification_6.f90 b/Fortran/gfortran/regression/bound_simplification_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bound_simplification_6.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } +! +! PR fortran/66100 +! ICE on lbound simplification +! +! Original test case by Joost VandeVondele +! Reduced by Thomas Koenig +! +MODULE qs_integrate_potential_low + INTEGER, PARAMETER :: dp = 8 + TYPE cell_type + REAL(KIND=8) :: h_inv(3,3) + END TYPE + TYPE(cell_type), POINTER :: cell + REAL(KIND=dp), DIMENSION(3) :: rp + CONTAINS + SUBROUTINE integrate_general_opt() + REAL(KIND=dp) :: gp(3) + INTEGER :: ng + if (any(lbound(cell%h_inv) /= 1)) STOP 1 + if (any(ubound(cell%h_inv) /= 3)) STOP 2 + END SUBROUTINE integrate_general_opt +END MODULE qs_integrate_potential_low +! { dg-final { scan-tree-dump-not "bound" "original" } } +! { dg-final { scan-tree-dump-not "_gfortran_stop" "original" } } diff --git a/Fortran/gfortran/regression/bound_simplification_7.f90 b/Fortran/gfortran/regression/bound_simplification_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bound_simplification_7.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! PR fortran/103392 - ICE in simplify_bound + +program p + integer, allocatable :: a(1:1) ! { dg-error "deferred shape or assumed rank" } + integer :: b(1) = lbound(a) ! { dg-error "does not reduce" } + integer :: c(1) = ubound(a) ! { dg-error "does not reduce" } +end + +subroutine s(x, y) + type t + integer :: i(3) + end type t + type(t), pointer :: x(:) + type(t), allocatable :: y(:) + integer, parameter :: m(1) = ubound (x(1)% i) + integer :: n(1) = ubound (y(1)% i) +end subroutine s diff --git a/Fortran/gfortran/regression/bounds_check_1.f90 b/Fortran/gfortran/regression/bounds_check_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_1.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! PR fortran/27524 + integer :: res(1) + res = F() + if (res(1) /= 1) STOP 1 + contains + function F() + integer :: F(1) + f = 1 + end function F + end diff --git a/Fortran/gfortran/regression/bounds_check_10.f90 b/Fortran/gfortran/regression/bounds_check_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_10.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Different CHARACTER lengths" } +! PR fortran/33254: No bounds checking for array constructors +program array_char +implicit none +character (len=2) :: x, y +character (len=2) :: z(3) +x = "a " +y = "cd" +z = [y(1:1), y(1:1), x(1:len(trim(x)))] ! should work +z = [trim(x), trim(y), "aaaa"] ! [ "a", "cd", "aaaa" ] should catch first error +end program array_char + +! { dg-output "Different CHARACTER lengths .1/.. in array constructor" } diff --git a/Fortran/gfortran/regression/bounds_check_11.f90 b/Fortran/gfortran/regression/bounds_check_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_11.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Array bound checking" } +! PR fortran/33745 +! +! Don't check upper bound of assumed-size array +! + +program test + implicit none + integer, parameter :: maxss=7,maxc=8 + integer :: jp(2,maxc) + call findphase(jp) +contains + subroutine findphase(jp) + integer, intent(out) :: jp(2,*) + jp(2,2:4)=0 + jp(2,0:4)=0 ! { dg-warning "out of bounds" } + jp(3,1:4)=0 ! { dg-warning "out of bounds" } + end subroutine +end program test + +! { dg-output "At line 18 of file .*" } +! { dg-output "Index '0' of dimension 2 of array 'jp' below lower bound of 1" } + diff --git a/Fortran/gfortran/regression/bounds_check_12.f90 b/Fortran/gfortran/regression/bounds_check_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_12.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Different CHARACTER lengths" } +! Tests the fix for PR34396, where the non-constant string lengths in the +! array constructor were being ignored and the bounds checking was not +! being done correctly. +! +! Contributed by Dominique d'Humieres +! +program array_char + implicit none + integer :: i, j(5) + character (len=5) :: x, y + character (len=5) :: z(2) + x = "ab" + y = "cd" + z = "" + z = (/y(1: len (trim(y))), x(1: len (trim(x)))/) + j = ichar ([(z(1)(i:i), i=1,5)]) + if (any (j .ne. (/99,100,32,32,32/))) STOP 1 + j = ichar ([(z(2)(i:i), i=1,5)]) + if (any (j .ne. (/97,98,32,32,32/))) STOP 2 + x = "a " + z = (/y(1: len (trim(y))), x(1: len (trim(x)))/) +end program array_char + +! { dg-output "At line 24 of file .*" } +! { dg-output "Different CHARACTER lengths .2/1. in array constructor" } diff --git a/Fortran/gfortran/regression/bounds_check_13.f b/Fortran/gfortran/regression/bounds_check_13.f --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_13.f @@ -0,0 +1,21 @@ +! { dg-do compile } +! Tests the fix for PR34945, in which the lbound = KIND(YDA) was not resolved +! in time to set the size of TEST_ARRAY to zero. +! +! Contributed by Dick Hendrickson +! + SUBROUTINE VF0009(IDA1,IDA2,YDA,HDA) + INTEGER(4) IDA1(4) + INTEGER(4) IDA2(4) + COMPLEX(8) YDA(2) + INTEGER(4) HDA(3) +! I N I T I A L I Z A T I O N S E C T I O N + COMPLEX(KIND=4) :: TEST_ARRAY + $( 4:5, + $ KIND(YDA):5, + $ 4:5, + $ 4:5 ) +! T E S T S T A T E M E N T S + IDA1(1:4) = LBOUND(TEST_ARRAY) + END SUBROUTINE + diff --git a/Fortran/gfortran/regression/bounds_check_14.f90 b/Fortran/gfortran/regression/bounds_check_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_14.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } + +program test + integer x(20) + integer, volatile :: n + n = 1 + if (size(x(n:2:-3)) /= 0) STOP 1 + + call ha0020(-3) + call ha0020(-1) +end program test + +subroutine ha0020(mf3) + implicit none + integer xca(2), xda(2), mf3 + + xca = 1 + xda = -1 + + xca(1:2:-1) = xda(1:2:mf3) + + if (any (xca /= 1)) STOP 2 + if (any(xda(1:2:mf3) /= xda(1:0))) STOP 3 + if (size(xda(1:2:mf3)) /= 0) STOP 4 + if (any(shape(xda(1:2:mf3)) /= 0)) STOP 5 + if (any(ubound(xda(1:2:mf3)) /= 0)) STOP 6 + if (ubound(xda(1:2:mf3),1) /= 0) STOP 7 + if (lbound(xda(1:2:mf3),1) /= 1) STOP 8 + +end subroutine diff --git a/Fortran/gfortran/regression/bounds_check_15.f90 b/Fortran/gfortran/regression/bounds_check_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_15.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! Test the fix for PR42783, in which a bogus array bounds violation +! with missing optional array argument. +! +! Contributed by Harald Anlauf +! +program gfcbug99 + implicit none + character(len=8), parameter :: mnem_list(2) = "A" + + call foo (mnem_list) ! This call succeeds + call foo () ! This call fails +contains + subroutine foo (mnem_list) + character(len=8) ,intent(in) ,optional :: mnem_list(:) + + integer :: i,j + character(len=256) :: ml + ml = '' + j = 0 + if (present (mnem_list)) then + do i = 1, size (mnem_list) + if (mnem_list(i) /= "") then + j = j + 1 + if (j > len (ml)/8) STOP 1 + ml((j-1)*8+1:(j-1)*8+8) = mnem_list(i) + end if + end do + end if + if (j > 0) print *, trim (ml(1:8)) + end subroutine foo +end program gfcbug99 diff --git a/Fortran/gfortran/regression/bounds_check_16.f90 b/Fortran/gfortran/regression/bounds_check_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_16.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-fcheck=bounds" } +! +! PR fortran/50815 +! +! Don't check the bounds of deferred-length strings. +! gfortran had an ICE before because it did. +! +SUBROUTINE TEST(VALUE) + IMPLICIT NONE + CHARACTER(LEN=:), ALLOCATABLE :: VALUE + CHARACTER(LEN=128) :: VAL + VALUE = VAL +END SUBROUTINE TEST diff --git a/Fortran/gfortran/regression/bounds_check_17.f90 b/Fortran/gfortran/regression/bounds_check_17.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_17.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! { dg-options "-fcheck=bounds" } +! { dg-shouldfail "above upper bound" } +! +! PR fortran/29800 +! +! Contributed by Joost VandeVondele +! + +TYPE data + INTEGER :: x(10) +END TYPE +TYPE data_areas + TYPE(data) :: y(10) +END TYPE + +TYPE(data_areas) :: z(10) + +integer, volatile :: i,j,k +i=1 ; j=1 ; k=11 + +z(i)%y(j)%x(k)=0 + +END + +! { dg-output "At line 22 of file .*bounds_check_17.f90.*Fortran runtime error: Index '11' of dimension 1 of array 'z%y%x' above upper bound of 10" } diff --git a/Fortran/gfortran/regression/bounds_check_18.f90 b/Fortran/gfortran/regression/bounds_check_18.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_18.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +program main + implicit none + integer :: n + real, dimension(10) :: a + n = 0 + call random_number(a) + if (any(a(n+1:n+5) > [1.0, 2.0, 3.0])) print *,"Hello!" ! { dg-error "not conformable" } +end program main diff --git a/Fortran/gfortran/regression/bounds_check_19.f90 b/Fortran/gfortran/regression/bounds_check_19.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_19.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! +! Test the fix for PR52162 in which the elemental and conversion +! intrinsics in lines 14 and 19 would cause the bounds check to fail. +! +! Contributed by Dominique d'Humieres +! + integer(4), allocatable :: a(:) + integer(8), allocatable :: b(:) + real, allocatable :: c(:) + allocate (b(7:11), source = [7_8,8_8,9_8,10_8,11_8]) + + a = b ! Implicit conversion + + if (lbound (a, 1) .ne. lbound(b, 1)) STOP 1 + if (ubound (a, 1) .ne. ubound(b, 1)) STOP 2 + + c = sin(real(b(9:11))/100_8) ! Elemental intrinsic + + if ((ubound(c, 1) - lbound(c, 1)) .ne. 2) STOP 3 + if (any (nint(asin(c)*100.0) .ne. b(9:11))) STOP 4 + deallocate (a, b, c) + end diff --git a/Fortran/gfortran/regression/bounds_check_2.f b/Fortran/gfortran/regression/bounds_check_2.f --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_2.f @@ -0,0 +1,39 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! PR fortran/19777 + implicit none + integer npts + parameter (npts=10) + double precision v(npts) + double precision w(npts,npts,npts) + external init1 + external init2 + + call init1 (npts, v) + call init2 (npts, w) + end + + subroutine init1 (npts, v) + implicit none + integer npts + double precision v(*) + + integer i + + do 10 i = 1, npts + v(i) = 0 + 10 continue + end + + subroutine init2 (npts, w) + implicit none + integer npts + double precision w(npts,npts,*) + + integer i + + do 20 i = 1, npts + w(i,1,1) = 0 + w(1,npts,i) = 0 + 20 continue + end diff --git a/Fortran/gfortran/regression/bounds_check_20.f90 b/Fortran/gfortran/regression/bounds_check_20.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_20.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! { dg-additional-options "-fcheck=bounds -ffrontend-optimize" } +! PR 85631 - this used to cause a runtime error with bounds checking. +module x +contains + subroutine sub(a, b) + real, dimension(:,:), intent(in) :: a + real, dimension(:,:), intent(out), allocatable :: b + b = transpose(a) + end subroutine sub +end module x + +program main + use x + implicit none + real, dimension(2,2) :: a + real, dimension(:,:), allocatable :: b + data a /-2., 3., -5., 7./ + call sub(a, b) + if (any (b /= reshape([-2., -5., 3., 7.], shape(b)))) stop 1 + b = matmul(transpose(b), a) + if (any (b /= reshape([-11., 15., -25., 34.], shape(b)))) stop 2 +end program + diff --git a/Fortran/gfortran/regression/bounds_check_21.f90 b/Fortran/gfortran/regression/bounds_check_21.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_21.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-Warray-bounds -O2" } +! PR 92422 - this complained about an array subscript out of bounds. + +PROGRAM character_warning + + CHARACTER(len=16) :: word + + word = 'hi' + WRITE(*,*) word + +END PROGRAM character_warning diff --git a/Fortran/gfortran/regression/bounds_check_22.f90 b/Fortran/gfortran/regression/bounds_check_22.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_22.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-fcheck=bounds" } +! PR fortran/100656 - ICE in gfc_conv_expr_present + +subroutine s(x) + character(:), allocatable, optional :: x(:) + if ( present(x) ) then + if ( allocated(x) ) then + x = 'a' // x // 'e' + end if + end if +end diff --git a/Fortran/gfortran/regression/bounds_check_23.f90 b/Fortran/gfortran/regression/bounds_check_23.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_23.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-options "-fcheck=bounds -fdump-tree-original" } +! PR fortran/98490 - out of bounds in array constructor with implied do loop + +program test + implicit none + call sub('Lorem ipsum') +contains + subroutine sub( text ) + character(len=*), intent(in) :: text + character(len=1), allocatable :: c(:) + integer :: i + c = [ ( text(i:i), i = 1, len(text) ) ] + if (c(1) /= 'L') stop 1 + end subroutine sub +end program test + +! { dg-final { scan-tree-dump-times "Substring out of bounds:" 2 "original" } } diff --git a/Fortran/gfortran/regression/bounds_check_3.f90 b/Fortran/gfortran/regression/bounds_check_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_3.f90 @@ -0,0 +1,69 @@ +! { dg-do compile } + integer,parameter :: n = 5, m = 8 + integer a(10), i + + print *, a(15:14) ! don't warn + print *, a(14:15) ! { dg-warning "is out of bounds" } + print *, a(-5:-6) ! don't warn + print *, a(-6:-5) ! { dg-warning "is out of bounds" } + print *, a(15:14:1) ! don't warn + print *, a(14:15:1) ! { dg-warning "is out of bounds" } + print *, a(-5:-6:1) ! don't warn + print *, a(-6:-5:1) ! { dg-warning "is out of bounds" } + print *, a(15:14:-1) ! { dg-warning "is out of bounds" } + print *, a(14:15:-1) ! don't warn + print *, a(-5:-6:-1) ! { dg-warning "is out of bounds" } + print *, a(-6:-5:-1) ! don't warn + + print *, a(15:) ! don't warn + print *, a(15::-1) ! { dg-warning "is out of bounds" } + print *, a(-1:) ! { dg-warning "is out of bounds" } + print *, a(-1::-1) ! don't warn + print *, a(:-1) ! don't warn + print *, a(:-1:-1) ! { dg-warning "is out of bounds" } + print *, a(:11) ! { dg-warning "is out of bounds" } + print *, a(:11:-1) ! don't warn + + print *, a(1:20:10) ! { dg-warning "is out of bounds" } + print *, a(1:15:15) ! don't warn + print *, a(1:16:15) ! { dg-warning "is out of bounds" } + print *, a(10:15:6) ! don't warn + print *, a(11:15:6) ! { dg-warning "is out of bounds" } + print *, a(11:-5:6) ! don't warn + + print *, a(10:-8:-9) ! { dg-warning "is out of bounds" } + print *, a(10:-7:-9) ! don't warn + + print *, a(0:0:-1) ! { dg-warning "is out of bounds" } + print *, a(0:0:1) ! { dg-warning "is out of bounds" } + print *, a(0:0) ! { dg-warning "is out of bounds" } + + print *, a(1:15:i) ! don't warn + print *, a(1:15:n) ! { dg-warning "is out of bounds" } + print *, a(1:15:m) ! don't warn + + print *, a(1:-5:-m) ! don't warn + print *, a(1:-5:-n) ! { dg-warning "is out of bounds" } + print *, a(1:-5:-i) ! don't warn + + print *, a(-5:-5) ! { dg-warning "is out of bounds" } + print *, a(15:15) ! { dg-warning "is out of bounds" } + print *, a(-5:-5:1) ! { dg-warning "is out of bounds" } + print *, a(15:15:-1) ! { dg-warning "is out of bounds" } + print *, a(-5:-5:2) ! { dg-warning "is out of bounds" } + print *, a(15:15:-2) ! { dg-warning "is out of bounds" } + print *, a(-5:-5:n) ! { dg-warning "is out of bounds" } + print *, a(15:15:-n) ! { dg-warning "is out of bounds" } + print *, a(-5:-5:i) ! { dg-warning "is out of bounds" } + print *, a(15:15:-i) ! { dg-warning "is out of bounds" } + print *, a(5:5) ! don't warn + print *, a(5:5:1) ! don't warn + print *, a(5:5:-1) ! don't warn + print *, a(5:5:2) ! don't warn + print *, a(5:5:-2) ! don't warn + print *, a(5:5:n) ! don't warn + print *, a(5:5:-n) ! don't warn + print *, a(5:5:i) ! don't warn + print *, a(5:5:-i) ! don't warn + + end diff --git a/Fortran/gfortran/regression/bounds_check_4.f90 b/Fortran/gfortran/regression/bounds_check_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_4.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +subroutine foo(n,x) + implicit none + integer, intent(in) :: n + complex(8), intent(out) :: x(n,*) + x(1,1) = 0.d0 + x(n,1) = 0.d0 + x(:,1) = 0.d0 + x(2:,1) = 0.d0 + x(:n-1,1) = 0.d0 + x((/1,n/),1) = 0.d0 +end subroutine foo + +program test + implicit none + integer, parameter :: n = 17 + complex(8) :: x(n,n) + call foo(n,x) +end program test diff --git a/Fortran/gfortran/regression/bounds_check_5.f90 b/Fortran/gfortran/regression/bounds_check_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_5.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! This tests the fix for PR30190, in which the array reference +! in the associated statement would cause a segfault. +! +! Contributed by Tobias Burnus +! + TYPE particle_type + INTEGER, POINTER :: p(:) + END TYPE particle_type + TYPE(particle_type), POINTER :: t(:) + integer :: i + logical :: f + i = 1 + allocate(t(1)) + allocate(t(1)%p(0)) + f = associated(t(i)%p,t(i)%p) +end diff --git a/Fortran/gfortran/regression/bounds_check_6.f90 b/Fortran/gfortran/regression/bounds_check_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_6.f90 @@ -0,0 +1,8 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! +! Testcase for PR30655, we used to issue a compile-time warning + integer i(12), j + j = -1 + i(0:j) = 42 + end diff --git a/Fortran/gfortran/regression/bounds_check_7.f90 b/Fortran/gfortran/regression/bounds_check_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_7.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Array reference out of bounds" } +! PR fortran/31627 +subroutine foo(a) + integer a(*), i + i = 0 + a(i) = 42 +end subroutine foo + +program test + integer x(42) + call foo(x) +end program test +! { dg-output "Index '0' of dimension 1 of array 'a' below lower bound of 1" } diff --git a/Fortran/gfortran/regression/bounds_check_8.f90 b/Fortran/gfortran/regression/bounds_check_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_8.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! PR fortran/32036 +program test + type t + integer, dimension (5) :: field + end type t + type (t), dimension (2) :: a + integer :: calls + + type xyz_type + integer :: x + end type xyz_type + type (xyz_type), dimension(3) :: xyz + character(len=80) :: s + + xyz(1)%x = 11111 + xyz(2)%x = 0 + xyz(3)%x = 0 + + write(s,*) xyz(bar()) + if (trim(adjustl(s)) /= "11111") STOP 1 + + a(1)%field = 0 + a(2)%field = 0 + calls = 0 + if (sum(a(foo(calls))%field) /= 0) STOP 2 + if (calls .ne. 1) STOP 3 + +contains + + function foo (calls) + integer :: calls, foo + calls = calls + 1 + foo = 2 + end function foo + + integer function bar () + integer, save :: i = 1 + bar = i + i = i + 1 + end function + +end program test diff --git a/Fortran/gfortran/regression/bounds_check_9.f90 b/Fortran/gfortran/regression/bounds_check_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_9.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! PR fortran/31119 +! +module sub_mod +contains +elemental subroutine set_optional(i,idef,iopt) + integer, intent(out) :: i + integer, intent(in) :: idef + integer, intent(in), optional :: iopt + if (present(iopt)) then + i = iopt + else + i = idef + end if + end subroutine set_optional + + subroutine sub(ivec) + integer, intent(in), optional :: ivec(:) + integer :: ivec_(2) + call set_optional(ivec_,(/1,2/)) + if (any (ivec_ /= (/1, 2/))) STOP 1 + call set_optional(ivec_,(/1,2/),ivec) + if (present (ivec)) then + if (any (ivec_ /= ivec)) STOP 2 + else + if (any (ivec_ /= (/1, 2/))) STOP 3 + end if + end subroutine sub +end module sub_mod + +program main + use sub_mod, only: sub + call sub() + call sub((/4,5/)) +end program main diff --git a/Fortran/gfortran/regression/bounds_check_array_ctor_1.f90 b/Fortran/gfortran/regression/bounds_check_array_ctor_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_array_ctor_1.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "foo" } +! +! PR 36112 +! Check correct bounds-checking behavior for character-array-constructors. + + call test ("this is long") +contains + subroutine test(s) + character(len=*) :: s + character(len=128) :: arr(2) + arr = (/ s, "abc" /) + end subroutine test +end +! { dg-output "Different CHARACTER lengths \\(12/3\\) in array constructor" } diff --git a/Fortran/gfortran/regression/bounds_check_array_ctor_2.f90 b/Fortran/gfortran/regression/bounds_check_array_ctor_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_array_ctor_2.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "foo" } +! +! PR 36112 +! Check correct bounds-checking behavior for character-array-constructors. + + call test ("this is long") +contains + subroutine test(s) + character(len=*) :: s + character(len=128) :: arr(2) + arr = (/ "abc", s /) + end subroutine test +end +! { dg-output "Different CHARACTER lengths \\(3/12\\) in array constructor" } diff --git a/Fortran/gfortran/regression/bounds_check_array_ctor_3.f90 b/Fortran/gfortran/regression/bounds_check_array_ctor_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_array_ctor_3.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! +! PR 36112 +! Check correct bounds-checking behavior for character-array-constructors. +! This should not need any -fbounds-check and is enabled all the time. + + character(len=128) :: arr(2) = (/ "abc", "foobar" /) ! { dg-error "Different CHARACTER lengths" } + arr = (/ "abc", "foobar" /) ! { dg-error "Different CHARACTER lengths" } +end diff --git a/Fortran/gfortran/regression/bounds_check_array_ctor_4.f90 b/Fortran/gfortran/regression/bounds_check_array_ctor_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_array_ctor_4.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "foo" } +! +! PR 36112 +! Check correct bounds-checking behavior for character-array-constructors. + + call test ("short", "this is long") +contains + subroutine test(r, s) + character(len=*) :: r, s + character(len=128) :: arr(2) + arr = (/ r, s /) + end subroutine test +end +! { dg-output "Different CHARACTER lengths \\(5/12\\) in array constructor" } diff --git a/Fortran/gfortran/regression/bounds_check_array_ctor_5.f90 b/Fortran/gfortran/regression/bounds_check_array_ctor_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_array_ctor_5.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! PR 36112 +! Check correct bounds-checking behavior for character-array-constructors. +! No need for -fbounds-check, enabled unconditionally. + + character(len=5) :: s = "hello" + character(len=128) :: arr(3) + arr = (/ "abc", "foo", s /) ! { dg-error "Different CHARACTER lengths" } +end diff --git a/Fortran/gfortran/regression/bounds_check_array_ctor_6.f90 b/Fortran/gfortran/regression/bounds_check_array_ctor_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_array_ctor_6.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "foo" } +! +! PR 36112 +! Check correct bounds-checking behavior for character-array-constructors. + + call test ("short", "also5") +contains + subroutine test(r, s) + character(len=*) :: r, s + character(len=128) :: arr(3) + arr = (/ r, s, "this is too long" /) + end subroutine test +end +! { dg-output "Different CHARACTER lengths \\(5/16\\) in array constructor" } diff --git a/Fortran/gfortran/regression/bounds_check_array_ctor_7.f90 b/Fortran/gfortran/regression/bounds_check_array_ctor_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_array_ctor_7.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "foo" } +! +! PR 36112 +! Check correct bounds-checking behavior for character-array-constructors. + + call test ("short") +contains + subroutine test(s) + character(len=*) :: s + character(len=128) :: arr(3) + arr = (/ "this is long", "this one too", s /) + end subroutine test +end +! { dg-output "Different CHARACTER lengths \\(12/5\\) in array constructor" } diff --git a/Fortran/gfortran/regression/bounds_check_array_ctor_8.f90 b/Fortran/gfortran/regression/bounds_check_array_ctor_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_array_ctor_8.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "foo" } +! +! PR 36112 +! Check correct bounds-checking behavior for character-array-constructors. + + call test ("short") +contains + subroutine test(s) + character(len=*) :: s + character(len=128) :: arr(3) + arr = (/ s, "this is long", "this one too" /) + end subroutine test +end +! { dg-output "Different CHARACTER lengths \\(5/12\\) in array constructor" } diff --git a/Fortran/gfortran/regression/bounds_check_fail_1.f90 b/Fortran/gfortran/regression/bounds_check_fail_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_fail_1.f90 @@ -0,0 +1,7 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "foo" } + integer x(1) + x(2) = x(1) ! { dg-warning "out of bounds" } + end +! { dg-output "Index '2' of dimension 1 of array 'x' above upper bound of 1" } diff --git a/Fortran/gfortran/regression/bounds_check_fail_2.f90 b/Fortran/gfortran/regression/bounds_check_fail_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_fail_2.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "foo" } +! +! PR 31119 +module sub_mod +contains + elemental subroutine set_optional(i,idef,iopt) + integer, intent(out) :: i + integer, intent(in) :: idef + integer, intent(in), optional :: iopt + if (present(iopt)) then + i = iopt + else + i = idef + end if + end subroutine set_optional + + subroutine sub(ivec) + integer , intent(in), optional :: ivec(:) + integer :: ivec_(2) + call set_optional(ivec_,(/1,2/)) + if (any (ivec_ /= (/1,2/))) STOP 1 + call set_optional(ivec_,(/1,2/),ivec) + if (present (ivec)) then + if (any (ivec_ /= ivec)) STOP 2 + else + if (any (ivec_ /= (/1,2/))) STOP 3 + end if + end subroutine sub +end module sub_mod + +program main + use sub_mod, only: sub + call sub() + call sub((/4,5/)) + call sub((/4/)) +end program main +! { dg-output "Fortran runtime error: Array bound mismatch" } diff --git a/Fortran/gfortran/regression/bounds_check_fail_3.f90 b/Fortran/gfortran/regression/bounds_check_fail_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_fail_3.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "foo" } + integer x(10), m, n + x = (/ (i, i = 1, 10) /) + m = -3 + n = -2 + x(7:1:m) = x(6:2:n) + if (any(x /= (/ 2, 2, 3, 4, 5, 6, 6, 8, 9, 10 /))) STOP 1 + x(8:1:m) = x(5:2:n) + end +! { dg-output "line 10 .* bound mismatch .* dimension 1 .* array \'x\' \\\(3/2\\\)" } diff --git a/Fortran/gfortran/regression/bounds_check_fail_4.f90 b/Fortran/gfortran/regression/bounds_check_fail_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_fail_4.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "foo" } + integer x(10), m, n + x = (/ (i, i = 1, 10) /) + m = -3 + n = -2 + x(7:1:m) = x(1:3) + x(6:2:n) + if (any(x /= (/ 5, 2, 3, 6, 5, 6, 7, 8, 9, 10 /))) STOP 1 + x(8:1:m) = x(1:3) + x(5:2:n) + end +! { dg-output "line 10 .* bound mismatch .* dimension 1 .* array \'x\' \\\(2/3\\\)" } diff --git a/Fortran/gfortran/regression/bounds_check_strlen_1.f90 b/Fortran/gfortran/regression/bounds_check_strlen_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_strlen_1.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Character length mismatch" } + +! PR fortran/37746 +! Test bounds-checking for string length of dummy arguments. + +SUBROUTINE test (str) + IMPLICIT NONE + CHARACTER(len=5) :: str +END SUBROUTINE test + +PROGRAM main + IMPLICIT NONE + CALL test ('abc') ! { dg-warning "Character length of actual argument shorter" } +END PROGRAM main + +! { dg-output "shorter than the declared one for dummy argument 'str' \\(3/5\\)" } diff --git a/Fortran/gfortran/regression/bounds_check_strlen_2.f90 b/Fortran/gfortran/regression/bounds_check_strlen_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_strlen_2.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Character length mismatch" } + +! PR fortran/37746 +! Test bounds-checking for string length of dummy arguments. + +MODULE m + +CONTAINS + + SUBROUTINE test (str, n) + IMPLICIT NONE + INTEGER :: n + CHARACTER(len=n) :: str + END SUBROUTINE test + + SUBROUTINE test2 (str) + IMPLICIT NONE + CHARACTER(len=*) :: str + CALL test (str, 5) ! Expected length of str is 5. + END SUBROUTINE test2 + +END MODULE m + +PROGRAM main + USE m + IMPLICIT NONE + CALL test2 ('abc') ! String is too short. +END PROGRAM main + +! { dg-output "shorter than the declared one for dummy argument 'str' \\(3/5\\)" } diff --git a/Fortran/gfortran/regression/bounds_check_strlen_3.f90 b/Fortran/gfortran/regression/bounds_check_strlen_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_strlen_3.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Character length mismatch" } + +! PR fortran/37746 +! Test bounds-checking for string length of dummy arguments. + +MODULE m + +CONTAINS + + SUBROUTINE test (str) + IMPLICIT NONE + CHARACTER(len=5), POINTER :: str + END SUBROUTINE test + + SUBROUTINE test2 (n) + IMPLICIT NONE + INTEGER :: n + CHARACTER(len=n), POINTER :: str + CALL test (str) + END SUBROUTINE test2 + +END MODULE m + +PROGRAM main + USE m + IMPLICIT NONE + CALL test2 (7) ! Too long. +END PROGRAM main + +! { dg-output "does not match the declared one for dummy argument 'str' \\(7/5\\)" } diff --git a/Fortran/gfortran/regression/bounds_check_strlen_4.f90 b/Fortran/gfortran/regression/bounds_check_strlen_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_strlen_4.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Character length mismatch" } + +! PR fortran/37746 +! Test bounds-checking for string length of dummy arguments. + +MODULE m + +CONTAINS + + SUBROUTINE test (str) + IMPLICIT NONE + CHARACTER(len=5), ALLOCATABLE :: str(:) + END SUBROUTINE test + + SUBROUTINE test2 (n) + IMPLICIT NONE + INTEGER :: n + CHARACTER(len=n), ALLOCATABLE :: str(:) + CALL test (str) + END SUBROUTINE test2 + +END MODULE m + +PROGRAM main + USE m + IMPLICIT NONE + CALL test2 (7) ! Too long. +END PROGRAM main + +! { dg-output "does not match the declared one for dummy argument 'str' \\(7/5\\)" } diff --git a/Fortran/gfortran/regression/bounds_check_strlen_5.f90 b/Fortran/gfortran/regression/bounds_check_strlen_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_strlen_5.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Character length mismatch" } + +! PR fortran/37746 +! Test bounds-checking for string length of dummy arguments. + +MODULE m + +CONTAINS + + SUBROUTINE test (str) + IMPLICIT NONE + CHARACTER(len=5) :: str(:) ! Assumed shape. + END SUBROUTINE test + + SUBROUTINE test2 (n) + IMPLICIT NONE + INTEGER :: n + CHARACTER(len=n) :: str(2) + CALL test (str) + END SUBROUTINE test2 + +END MODULE m + +PROGRAM main + USE m + IMPLICIT NONE + CALL test2 (7) ! Too long. +END PROGRAM main + +! { dg-output "does not match the declared one for dummy argument 'str' \\(7/5\\)" } diff --git a/Fortran/gfortran/regression/bounds_check_strlen_6.f90 b/Fortran/gfortran/regression/bounds_check_strlen_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_strlen_6.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } + +! PR fortran/37746 +! Ensure that too long or matching string lengths don't trigger the runtime +! error for matching string lengths, if the dummy argument is neither +! POINTER nor ALLOCATABLE or assumed-shape. +! Also check that absent OPTIONAL arguments don't trigger the check. + +MODULE m +CONTAINS + + SUBROUTINE test (str, opt) + IMPLICIT NONE + CHARACTER(len=5) :: str + CHARACTER(len=5), OPTIONAL :: opt + END SUBROUTINE test + +END MODULE m + +PROGRAM main + USE m + IMPLICIT NONE + CALL test ('abcde') ! String length matches. + CALL test ('abcdef') ! String too long, is ok. +END PROGRAM main diff --git a/Fortran/gfortran/regression/bounds_check_strlen_7.f90 b/Fortran/gfortran/regression/bounds_check_strlen_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_strlen_7.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Character length mismatch" } + +! PR fortran/37746 +! Test bounds-checking for string length of dummy arguments. + +MODULE m +CONTAINS + + SUBROUTINE test (opt) + IMPLICIT NONE + CHARACTER(len=5), OPTIONAL :: opt + END SUBROUTINE test + +END MODULE m + +PROGRAM main + USE m + IMPLICIT NONE + CALL test ('') ! 0 length, but not absent argument. +END PROGRAM main + +! { dg-output "shorter than the declared one for dummy argument 'opt' \\(0/5\\)" } diff --git a/Fortran/gfortran/regression/bounds_check_strlen_8.f90 b/Fortran/gfortran/regression/bounds_check_strlen_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_strlen_8.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! +! PR fortran/40383 +! Gave before a bogus out of bounds. +! Contributed by Joost VandeVondele. +! +MODULE M1 + INTEGER, PARAMETER :: default_string_length=80 +END MODULE M1 +MODULE M2 + USE M1 + IMPLICIT NONE +CONTAINS + FUNCTION F1(a,b,c,d) RESULT(RES) + CHARACTER(LEN=default_string_length), OPTIONAL :: a,b,c,d + LOGICAL :: res + END FUNCTION F1 +END MODULE M2 + +MODULE M3 + USE M1 + USE M2 + IMPLICIT NONE +CONTAINS + SUBROUTINE S1 + CHARACTER(LEN=default_string_length) :: a,b + LOGICAL :: L1 + INTEGER :: i + DO I=1,10 + L1=F1(a,b) + ENDDO + END SUBROUTINE +END MODULE M3 + +USE M3 +CALL S1 +END diff --git a/Fortran/gfortran/regression/bounds_check_strlen_9.f90 b/Fortran/gfortran/regression/bounds_check_strlen_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_check_strlen_9.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! +! PR fortran/40452 +! The following program is valid Fortran 90 and later. +! The storage-sequence association of the dummy argument +! allows that the actual argument ["ab", "cd"] is mapped +! to the dummy argument a(1) which perfectly fits. +! (The dummy needs to be an array, however.) +! + +program test + implicit none + call sub(["ab", "cd"]) +contains + subroutine sub(a) + character(len=4) :: a(1) + print *, a(1) + end subroutine sub +end program test diff --git a/Fortran/gfortran/regression/bounds_temporaries_1.f90 b/Fortran/gfortran/regression/bounds_temporaries_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/bounds_temporaries_1.f90 @@ -0,0 +1,64 @@ +! { dg-do compile } +! This tests the fix for PRs 26834, 25669 and 18803, in which +! shape information for the lbound and ubound intrinsics was not +! transferred to the scalarizer. For this reason, an ICE would +! ensue, whenever these functions were used in temporaries. +! +! The tests are lifted from the PRs and some further checks are +! done to make sure that nothing is broken. +! +! This is PR26834 +subroutine gfcbug34 () + implicit none + type t + integer, pointer :: i (:) => NULL () + end type t + type(t), save :: gf + allocate (gf%i(20)) + write(*,*) 'ubound:', ubound (gf% i) + write(*,*) 'lbound:', lbound (gf% i) +end subroutine gfcbug34 + +! This is PR25669 +subroutine foo (a) + real a(*) + call bar (a, LBOUND(a),2) ! { dg-error "Rank mismatch in argument" } +end subroutine foo +subroutine bar (b, i, j) + real b(i:j) + print *, i, j + print *, b(i:j) +end subroutine bar + +! This is PR18003 +subroutine io_bug() + integer :: a(10) + print *, ubound(a) +end subroutine io_bug + +! This checks that lbound and ubound are OK in temporary +! expressions. +subroutine io_bug_plus() + integer :: a(10, 10), b(2) + print *, ubound(a)*(/1,2/) + print *, (/1,2/)*ubound(a) +end subroutine io_bug_plus + + character(4) :: ch(2), ech(2) = (/'ABCD', 'EFGH'/) + real(4) :: a(2) + equivalence (ech,a) ! { dg-warning "default CHARACTER EQUIVALENCE statement" } + integer(1) :: i(8) = (/(j, j = 1,8)/) + +! Check that the bugs have gone + call io_bug () + call io_bug_plus () + call foo ((/1.0,2.0,3.0/)) + call gfcbug34 () + +! Check that we have not broken other intrinsics. + print *, cos ((/1.0,2.0/)) + print *, transfer (a, ch) + print *, i(1:4) * transfer (a, i, 4) * 2 +end + + diff --git a/Fortran/gfortran/regression/boz_1.f90 b/Fortran/gfortran/regression/boz_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/boz_1.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! { dg-options "-std=gnu -fallow-invalid-boz" } +! Test the boz handling +program boz + + implicit none + + integer(1), parameter :: b1 = b'00000001' ! { dg-warning "BOZ literal constant" } + integer(2), parameter :: b2 = b'0101010110101010' ! { dg-warning "BOZ literal constant" } + integer(4), parameter :: b4 = b'01110000111100001111000011110000' ! { dg-warning "BOZ literal constant" } + integer(8), parameter :: & + & b8 = b'0111000011110000111100001111000011110000111100001111000011110000' ! { dg-warning "BOZ literal constant" } + + integer(1), parameter :: o1 = o'12' ! { dg-warning "BOZ literal constant" } + integer(2), parameter :: o2 = o'4321' ! { dg-warning "BOZ literal constant" } + integer(4), parameter :: o4 = o'43210765' ! { dg-warning "BOZ literal constant" } + integer(8), parameter :: o8 = o'1234567076543210' ! { dg-warning "BOZ literal constant" } + + integer(1), parameter :: z1 = z'a' ! { dg-warning "BOZ literal constant" } + integer(2), parameter :: z2 = z'ab' ! { dg-warning "BOZ literal constant" } + integer(4), parameter :: z4 = z'dead' ! { dg-warning "BOZ literal constant" } + integer(8), parameter :: z8 = z'deadbeef' ! { dg-warning "BOZ literal constant" } + + if (z1 /= 10_1) STOP 1 + if (z2 /= 171_2) STOP 2 + if (z4 /= 57005_4) STOP 3 + if (z8 /= 3735928559_8) STOP 4 + + if (b1 /= 1_1) STOP 5 + if (b2 /= 21930_2) STOP 6 + if (b4 /= 1894838512_4) STOP 7 + if (b8 /= 8138269444283625712_8) STOP 8 + + if (o1 /= 10_1) STOP 9 + if (o2 /= 2257_2) STOP 10 + if (o4 /= 9245173_4) STOP 11 + if (o8 /= 45954958542472_8) STOP 12 + +end program boz diff --git a/Fortran/gfortran/regression/boz_10.f90 b/Fortran/gfortran/regression/boz_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/boz_10.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! PR fortran/34342 +! +! Diagnose BOZ literal for non-integer variables in +! a DATA statement. And outside DATA statements. +! +real :: r +integer :: i +r = real(z'FFFF') ! { dg-error "outside a DATA statement" } +i = int(z'4455') ! { dg-error "outside a DATA statement" } +r = z'FFFF' + 1.0 ! { dg-error "outside a DATA statement" } +i = z'4455' + 1 ! { dg-error "outside a DATA statement" } +end diff --git a/Fortran/gfortran/regression/boz_11.f90 b/Fortran/gfortran/regression/boz_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/boz_11.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! +program test0 + implicit none + real, parameter :: & + r = transfer(int(b'01000000001010010101001111111101',kind=4),0.) + complex, parameter :: z = r * (0, 1.) + real(kind=8), parameter :: rd = dble(b'00000000000000000000000000000000& + &01000000001010010101001111111101') + complex(kind=8), parameter :: zd = (0._8, 1._8) * rd + integer :: x = 0 + + if (cmplx(b'01000000001010010101001111111101',x,4) /= r) STOP 1 + if (cmplx(x,b'01000000001010010101001111111101',4) /= z) STOP 2 + +end program test0 diff --git a/Fortran/gfortran/regression/boz_12.f90 b/Fortran/gfortran/regression/boz_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/boz_12.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +program test + implicit none + real x4 + double precision x8 + x4 = 1.7 + x8 = 1.7 + write(*,*) cmplx(x8,z'1FFFFFFFFFFFFFFFF') + write(*,*) dcmplx(x8,z'1FFFFFFFFFFFFFFFF') +end program test diff --git a/Fortran/gfortran/regression/boz_13.f90 b/Fortran/gfortran/regression/boz_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/boz_13.f90 @@ -0,0 +1,13 @@ +! { dg-do run } + +! PR fortran/36214 +! For BOZ-initialization of floats, the precision used to be wrong sometimes. + +implicit none + real, parameter :: r = 0.0 + real(kind=8), parameter :: rd = real (z'00000000& + &402953FD', 8) + + if (real (z'00000000& + &402953FD', 8) /= rd) STOP 1 +end diff --git a/Fortran/gfortran/regression/boz_14.f90 b/Fortran/gfortran/regression/boz_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/boz_14.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-add-options ieee } + +! PR fortran/36214 +! For BOZ-initialization of floats, the precision used to be wrong sometimes. + + implicit none + real(4) r + real(8) rd + complex(8) z + rd = & + real (b'00000000000000000000000000000000& + &01000000001010010101001111111101',8) + z = & + cmplx(b'00000000000000000000000000000000& + &01000000001010010101001111111101',0,8) + r = 0. + if (z /= rd) STOP 1 + end diff --git a/Fortran/gfortran/regression/boz_15.f90 b/Fortran/gfortran/regression/boz_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/boz_15.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_real } +! { dg-require-effective-target fortran_large_int } +! +! PR fortran/41711 +! +! Check reading and writing of real(10/16) BOZ, +! which needs integer(16) support. +! +implicit none +character(len=256) :: str +integer,parameter :: xp = selected_real_kind (precision (0.0d0)+1) +real(xp) :: r1,r2 +complex(xp) :: z1,z2 + +r2 = 5.0_xp +r1 = 2.0_xp +! Real B(OZ) +write(str,'(b128)') r1 +read (str,'(b128)') r2 +if(r2 /= r1) STOP 1 +! Real (B)O(Z) +r2 = 5.0_xp +write(str,'(o126)') r1 +read (str,'(o126)') r2 +if(r2 /= r1) STOP 2 +! Real (BO)Z +r2 = 5.0_xp +write(str,'(z126)') r1 +read (str,'(z126)') r2 +if(r2 /= r1) STOP 3 + +z2 = cmplx(5.0_xp,7.0_xp) +z1 = cmplx(2.0_xp,3.0_xp) +! Complex B(OZ) +write(str,'(2b128)') z1 +read (str,'(2b128)') z2 +if(z2 /= z1) STOP 4 +! Complex (B)O(Z) +z2 = cmplx(5.0_xp,7.0_xp) +write(str,'(2o126)') z1 +read (str,'(2o126)') z2 +if(z2 /= z1) STOP 5 +! Complex (BO)Z +z2 = cmplx(5.0_xp,7.0_xp) +write(str,'(2z126)') z1 +read (str,'(2z126)') z2 +if(z2 /= z1) STOP 6 +end diff --git a/Fortran/gfortran/regression/boz_3.f90 b/Fortran/gfortran/regression/boz_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/boz_3.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! { dg-options "-std=gnu -fallow-invalid-boz" } +! +! Test that the BOZ constant on the RHS, which are of different KIND than +! the LHS, are correctly converted. +! +program boz + + implicit none + + integer(1), parameter :: & + & b1 = b'000000000001111' ! { dg-warning "BOZ literal constant at" } + integer(2), parameter :: & + & b2 = b'00000000000000000111000011110000' ! { dg-warning "BOZ literal constant at" } + integer(4), parameter :: & + & b4 = b'0000000000000000000000000000000001110000111100001111000011110000' ! { dg-warning "BOZ literal constant at" } + + integer(1), parameter :: o1 = o'0012' ! { dg-warning "BOZ literal constant at" } + integer(2), parameter :: o2 = o'0004321' ! { dg-warning "BOZ literal constant at" } + integer(4), parameter :: o4 = o'0000000043210765' ! { dg-warning "BOZ literal constant at" } + + integer(1), parameter :: z1 = z'0a' ! { dg-warning "BOZ literal constant at" } + integer(2), parameter :: z2 = z'00ab' ! { dg-warning "BOZ literal constant at" } + integer(4), parameter :: z4 = z'0000dead' ! { dg-warning "BOZ literal constant at" } + + if (b1 /= 15_1) STOP 1 + if (b2 /= 28912_2) STOP 2 + if (b4 /= 1894838512_4) STOP 3 + + if (o1 /= 10_1) STOP 4 + if (o2 /= 2257_2) STOP 5 + if (o4 /= 9245173_4) STOP 6 + + if (z1 /= 10_1) STOP 7 + if (z2 /= 171_2) STOP 8 + if (z4 /= 57005_4) STOP 9 + +end program boz diff --git a/Fortran/gfortran/regression/boz_4.f90 b/Fortran/gfortran/regression/boz_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/boz_4.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-fallow-invalid-boz" } +! +program boz + implicit none + integer(1), parameter :: b1 = b'0101010110101010' ! { dg-warning "BOZ literal constant" } + integer(2), parameter :: b2 = b'01110000111100001111000011110000' ! { dg-warning "BOZ literal constant" } + integer(4), parameter :: & + & b4 = b'0111000011110000111100001111000011110000111100001111000011110000' ! { dg-warning "BOZ literal constant" } + integer(1), parameter :: o1 = o'1234567076543210' ! { dg-warning "BOZ literal constant" } + integer(2), parameter :: o2 = o'1234567076543210' ! { dg-warning "BOZ literal constant" } + integer(4), parameter :: o4 = o'1234567076543210' ! { dg-warning "BOZ literal constant" } + integer(1), parameter :: z1 = z'deadbeef' ! { dg-warning "BOZ literal constant" } + integer(2), parameter :: z2 = z'deadbeef' ! { dg-warning "BOZ literal constant" } + integer(4), parameter :: z4 = z'deadbeeffeed' ! { dg-warning "BOZ literal constant" } +end program boz diff --git a/Fortran/gfortran/regression/boz_5.f90 b/Fortran/gfortran/regression/boz_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/boz_5.f90 @@ -0,0 +1,4 @@ +! { dg-do compile } + integer, dimension (2) :: i + i = (/Z'abcde', Z'abcde/) ! { dg-error "cannot appear in" } +end diff --git a/Fortran/gfortran/regression/boz_6.f90 b/Fortran/gfortran/regression/boz_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/boz_6.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-std=gnu -fallow-invalid-boz" } +! PR 24917 +program test + integer ib, io, iz, ix + integer jb, jo, jz, jx + data ib, jb /b'111', '111'b/ ! { dg-warning "nonstandard" } + data io, jo /o'234', '234'o/ ! { dg-warning "nonstandard" } + data iz, jz /z'abc', 'abc'z/ ! { dg-warning "nonstandard" } + data ix, jx /x'abc', 'abc'x/ ! { dg-warning "nonstandard" } + if (ib /= jb) STOP 1 + if (io /= jo) STOP 2 + if (iz /= jz) STOP 3 + if (ix /= jx) STOP 4 +end program test diff --git a/Fortran/gfortran/regression/boz_7.f90 b/Fortran/gfortran/regression/boz_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/boz_7.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-std=f95 -pedantic" } +! +! PR fortran/34342 +! +! Some BOZ extensions where not diagnosed +! +integer :: k, m +integer :: j = z'000abc' ! { dg-error "BOZ used outside a DATA statement" } +data k/x'0003'/ ! { dg-error "nonstandard X instead of Z" } +data m/'0003'z/ ! { dg-error "nonstandard postfix" } +end diff --git a/Fortran/gfortran/regression/boz_8.f90 b/Fortran/gfortran/regression/boz_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/boz_8.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/34342 +! +! Diagnose BOZ literal for non-integer variables in +! a DATA statement. Cf. Fortran 2003, 5.2.5 DATA statement: +! "If a data-stmt-constant is a boz-literal-constant, the +! corresponding variable shall be of type integer." +! +real :: r +integer :: i +data i/z'111'/ +data r/z'4455'/ ! { dg-error "BOZ literal constant" } +r = z'FFFF' ! { dg-error "BOZ literal constant" } +i = z'4455' ! { dg-error "BOZ literal constant" } +r = real(z'FFFFFFFFF') +end diff --git a/Fortran/gfortran/regression/boz_9.f90 b/Fortran/gfortran/regression/boz_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/boz_9.f90 @@ -0,0 +1,118 @@ +! { dg-do run } +! { dg-options "-fno-range-check" } +! +! PR fortran/34342 +! +! Test for Fortran 2003 BOZ. +! +program f2003 +implicit none + +real,parameter :: r2c = real(int(z'3333')) +real,parameter :: rc = real(z'50CB9F09') +double precision,parameter :: dc = dble(Z'3FD34413509F79FF') +complex,parameter :: z1c = cmplx(b'11000001010001101101110110000011', 3.049426e-10) +complex,parameter :: z2c = cmplx(4.160326e16, o'6503667306') + +real :: r2 = real(int(z'3333')) +real :: r = real(z'50CB9F09') +double precision :: d = dble(Z'3FD34413509F79FF') +complex :: z1 = cmplx(b'11000001010001101101110110000011', 3.049426e-10) +complex :: z2 = cmplx(4.160326e16, o'6503667306') + +if (r2c /= 13107.0) STOP 1 +if (rc /= 2.732958e10) STOP 2 +if (dc /= 0.30102999566398120d0) STOP 3 +if (real(z1c) /= -1.242908e1 .or. aimag(z1c) /= 3.049426e-10) STOP 4 +if (real(z2c) /= 4.160326e16 .or. aimag(z2c) /= 5.343285e-7) STOP 5 + +if (r2 /= 13107.0) STOP 6 +if (r /= 2.732958e10) STOP 7 +if (d /= 0.30102999566398120d0) STOP 8 +if (real(z1) /= -1.242908e1 .or. aimag(z1) /= 3.049426e-10) STOP 9 +if (real(z2) /= 4.160326e16 .or. aimag(z2) /= 5.343285e-7) STOP 10 + +r2 = dble(int(z'3333')) +r = real(z'50CB9F09') +d = dble(Z'3FD34413509F79FF') +z1 = cmplx(b'11000001010001101101110110000011', 3.049426e-10) +z2 = cmplx(4.160326e16, o'6503667306') + +if (r2 /= 13107d0) STOP 11 +if (r /= 2.732958e10) STOP 12 +if (d /= 0.30102999566398120d0) STOP 13 +if (real(z1) /= -1.242908e1 .or. aimag(z1) /= 3.049426e-10) STOP 14 +if (real(z2) /= 4.160326e16 .or. aimag(z2) /= 5.343285e-7) STOP 15 + +call test4() +call test8() + +contains + +subroutine test4 +real,parameter :: r2c = real(int(z'3333', kind=4), kind=4) +real,parameter :: rc = real(z'50CB9F09', kind=4) +complex,parameter :: z1c = cmplx(b'11000001010001101101110110000011', 3.049426e-10, kind=4) +complex,parameter :: z2c = cmplx(4.160326e16, o'6503667306', kind=4) + +real :: r2 = real(int(z'3333', kind=4), kind=4) +real :: r = real(z'50CB9F09', kind=4) +complex :: z1 = cmplx(b'11000001010001101101110110000011', 3.049426e-10, kind=4) +complex :: z2 = cmplx(4.160326e16, o'6503667306', kind=4) + +if (r2c /= 13107.0) STOP 16 +if (rc /= 2.732958e10) STOP 17 +if (real(z1) /= -1.242908e1 .or. aimag(z1) /= 3.049426e-10) STOP 18 +if (real(z2) /= 4.160326e16 .or. aimag(z2) /= 5.343285e-7) STOP 19 + +if (r2 /= 13107.0) STOP 20 +if (r /= 2.732958e10) STOP 21 +if (real(z1) /= -1.242908e1 .or. aimag(z1) /= 3.049426e-10) STOP 22 +if (real(z2) /= 4.160326e16 .or. aimag(z2) /= 5.343285e-7) STOP 23 + +r2 = real(int(z'3333'), kind=4) +r = real(z'50CB9F09', kind=4) +z1 = cmplx(b'11000001010001101101110110000011', 3.049426e-10, kind=4) +z2 = cmplx(4.160326e16, o'6503667306', kind=4) + +if (r2 /= 13107.0) STOP 24 +if (r /= 2.732958e10) STOP 25 +if (real(z1) /= -1.242908e1 .or. aimag(z1) /= 3.049426e-10) STOP 26 +if (real(z2) /= 4.160326e16 .or. aimag(z2) /= 5.343285e-7) STOP 27 +end subroutine test4 + + +subroutine test8 +real(8),parameter :: r2c = real(int(z'FFFFFF3333', kind=8), kind=8) +real(8),parameter :: rc = real(z'AAAAAFFFFFFF3333', kind=8) +complex(8),parameter :: z1c = cmplx(b'11111011111111111111111111111111111111111111111111111111110101',-4.0, kind=8) +complex(8),parameter :: z2c = cmplx(5.0, o'442222222222233301245', kind=8) + +real(8) :: r2 = real(int(z'FFFFFF3333',kind=8),kind=8) +real(8) :: r = real(z'AAAAAFFFFFFF3333', kind=8) +complex(8) :: z1 = cmplx(b'11111011111111111111111111111111111111111111111111111111110101',-4.0, kind=8) +complex(8) :: z2 = cmplx(5.0, o'442222222222233301245', kind=8) + +if (r2c /= 1099511575347.0d0) STOP 28 +if (rc /= -3.72356884822177915d-103) STOP 29 +if (real(z1c) /= 3.05175781249999627d-5 .or. aimag(z1c) /= -4.0) STOP 30 +if (real(z2c) /= 5.0 .or. aimag(z2c) /= 3.98227593015308981d41) STOP 31 + +if (r2 /= 1099511575347.0d0) STOP 32 +if (r /= -3.72356884822177915d-103) STOP 33 +if (real(z1) /= 3.05175781249999627d-5 .or. aimag(z1) /= -4.0) STOP 34 +if (real(z2) /= 5.0 .or. aimag(z2) /= 3.98227593015308981d41) STOP 35 + +r2 = real(int(z'FFFFFF3333',kind=8),kind=8) +r = real(z'AAAAAFFFFFFF3333', kind=8) +z1 = cmplx(b'11111011111111111111111111111111111111111111111111111111110101',-4.0, kind=8) +z2 = cmplx(5.0, o'442222222222233301245', kind=8) + +if (r2 /= 1099511575347.0d0) STOP 36 +if (r /= -3.72356884822177915d-103) STOP 37 +if (real(z1) /= 3.05175781249999627d-5 .or. aimag(z1) /= -4.0) STOP 38 +if (real(z2) /= 5.0 .or. aimag(z2) /= 3.98227593015308981d41) STOP 39 + +end subroutine test8 + +end program f2003 diff --git a/Fortran/gfortran/regression/boz_bge.f90 b/Fortran/gfortran/regression/boz_bge.f90 --- /dev/null +++ b/Fortran/gfortran/regression/boz_bge.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +program foo + + integer :: k = 4242 + + if (bge(z'1234', z'5678') .neqv. .false.) stop 1 + if (bgt(z'1234', z'5678') .neqv. .false.) stop 2 + if (ble(z'1234', z'5678') .eqv. .false.) stop 3 + if (blt(z'1234', z'5678') .eqv. .false.) stop 4 + + if (bge(z'1234', k) .eqv. .false.) stop 5 + if (bgt(z'1234', k) .eqv. .false.) stop 6 + if (ble(z'1234', k) .neqv. .false.) stop 7 + if (blt(z'1234', k) .neqv. .false.) stop 8 + + if (bge(k, z'5678') .neqv. .false.) stop 9 + if (bgt(k, z'5678') .neqv. .false.) stop 10 + if (ble(k, z'5678') .eqv. .false.) stop 11 + if (blt(k, z'5678') .eqv. .false.) stop 12 + +end program foo + diff --git a/Fortran/gfortran/regression/boz_complex_1.f90 b/Fortran/gfortran/regression/boz_complex_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/boz_complex_1.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +program foo + + implicit none + + complex(4) z + + z = complex(z'4444', z'4444') ! { dg-error "cannot both be BOZ" } + if (real(z,4) /= 17476.0 .or. aimag(z) /= 42.0) stop 2 + + z = complex(z'4444', 42) ! { dg-error "cannot appear in the" } + if (real(z,4) /= 17476.0 .or. aimag(z) /= 42.0) stop 2 + + z = complex(z'44444400', 42.) ! { dg-error "cannot appear in the" } + if (real(z,4) /= 785.062500 .or. aimag(z) /= 42.0) stop 3 + +end program foo diff --git a/Fortran/gfortran/regression/boz_complex_2.f90 b/Fortran/gfortran/regression/boz_complex_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/boz_complex_2.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-fallow-invalid-boz" } +program foo + + implicit none + + complex(4) z + + z = complex(z'4444', 42) ! { dg-warning "cannot appear in the" } + if (real(z,4) /= 17476.0 .or. aimag(z) /= 42.0) stop 2 + + z = complex(z'44444400', 42.) ! { dg-warning "cannot appear in the" } + if (real(z,4) /= 785.062500 .or. aimag(z) /= 42.0) stop 3 + +end program foo diff --git a/Fortran/gfortran/regression/boz_complex_3.f90 b/Fortran/gfortran/regression/boz_complex_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/boz_complex_3.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-fallow-invalid-boz -w" } +program foo + + implicit none + + complex(4) z + + z = complex(z'4444', 42) + if (real(z,4) /= 17476.0 .or. aimag(z) /= 42.0) stop 2 + + z = complex(z'44444400', 42.) + if (real(z,4) /= 785.062500 .or. aimag(z) /= 42.0) stop 3 + +end program foo diff --git a/Fortran/gfortran/regression/boz_dble.f90 b/Fortran/gfortran/regression/boz_dble.f90 --- /dev/null +++ b/Fortran/gfortran/regression/boz_dble.f90 @@ -0,0 +1,6 @@ +! { dg-do run } +program foo + double precision x + x = dble(z"400921FB54411744"); + if (x /= 3.1415926535_8) stop 1 +end diff --git a/Fortran/gfortran/regression/boz_dshift_1.f90 b/Fortran/gfortran/regression/boz_dshift_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/boz_dshift_1.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +program foo + integer k, n + k = dshiftl(z'1234',z'2345',1) ! { dg-error "cannot both be BOZ" } + n = dshiftr(z'1234',z'2345',1) ! { dg-error "cannot both be BOZ" } + if (k .eq. n) stop 1 + k = dshiftl(z'1234',3.1415,1) ! { dg-error "must be INTEGER" } + n = dshiftr(2.7362,z'2345',1) ! { dg-error "must be INTEGER" } + if (k .eq. n) stop 2 +end program foo diff --git a/Fortran/gfortran/regression/boz_dshift_2.f90 b/Fortran/gfortran/regression/boz_dshift_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/boz_dshift_2.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +program foo + integer k, n + k = dshiftl(z'1234',42,1) + n = dshiftr(z'1234',42,1) + if (k /= 9320) stop 1 + if (n /= 21) stop 2 + k = dshiftl(42,b'01010101', 1) + n = dshiftr(22,o'12345', 1) + if (k /= 84) stop 1 + if (n /= 2674) stop 2 +end program foo diff --git a/Fortran/gfortran/regression/boz_float_1.f90 b/Fortran/gfortran/regression/boz_float_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/boz_float_1.f90 @@ -0,0 +1,4 @@ +! { dg-do compile } +program foo + print *, float(z'1234') ! { dg-error "cannot appear in" } +end program foo diff --git a/Fortran/gfortran/regression/boz_float_2.f90 b/Fortran/gfortran/regression/boz_float_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/boz_float_2.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +! { dg-options "-fallow-invalid-boz" } +program foo + print *, float(z'1234') ! { dg-warning "cannot appear in" } +end program foo diff --git a/Fortran/gfortran/regression/boz_float_3.f90 b/Fortran/gfortran/regression/boz_float_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/boz_float_3.f90 @@ -0,0 +1,7 @@ +! { dg-do run } +! { dg-options "-fallow-invalid-boz -w" } +program foo + integer i + i = float(z'1234') + if (i /= 4660.0) stop 1 +end program foo diff --git a/Fortran/gfortran/regression/boz_iand_1.f90 b/Fortran/gfortran/regression/boz_iand_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/boz_iand_1.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +program foo + print *, iand(z'1234', z'3456') ! { dg-error "cannot both be" } + print *, and(z'1234', z'3456') ! { dg-error "cannot both be" } + print *, ieor(z'1234', z'3456') ! { dg-error "cannot both be" } + print *, xor(z'1234', z'3456') ! { dg-error "cannot both be" } + print *, ior(z'1234', z'3456') ! { dg-error "cannot both be" } + print *, or(z'1234', z'3456') ! { dg-error "cannot both be" } +end program foo + diff --git a/Fortran/gfortran/regression/boz_iand_2.f90 b/Fortran/gfortran/regression/boz_iand_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/boz_iand_2.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +program foo + integer :: k = 42 + n = iand(k, z'3456'); if (n /= 2) stop 1 + n = iand(z'1234', k); if (n /= 32) stop 2 + n = and(k, z'3456'); if (n /= 2) stop 3 + n = and(z'1234', k); if (n /= 32) stop 4 + n = ieor(k, z'3456'); if (n /= 13436) stop 5 + n = ieor(z'1234', k); if (n /= 4638) stop 6 + n = xor(k, z'3456'); if (n /= 13436) stop 7 + n = xor(z'1234', k); if (n /= 4638) stop 8 + n = ior(k, z'3456'); if (n /= 13438) stop 9 + n = ior(z'1234', k); if (n /= 4670) stop 10 + n = or(k, z'3456'); if (n /= 13438) stop 11 + n = or(z'1234', k); if (n /= 4670) stop 12 +end program foo + diff --git a/Fortran/gfortran/regression/boz_int.f90 b/Fortran/gfortran/regression/boz_int.f90 --- /dev/null +++ b/Fortran/gfortran/regression/boz_int.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +program foo + implicit none + integer(1) i1 + integer(2) i2 + integer(4) i4, j4 + integer(8) i8 + i1 = int(z'12', 1); if (i1 /= 18) stop 1 + i2 = int(z'1234', 2); if (i2 /= 4660) stop 2 + i4 = int(z'1234', 4); if (i4 /= 4660) stop 3 + j4 = int(z'1234'); if (i4 /= 4660) stop 4 + i8 = int(z'1233456',8); if (i8 /= 19084374_8) stop 5 +end program diff --git a/Fortran/gfortran/regression/btest_1.f90 b/Fortran/gfortran/regression/btest_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/btest_1.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +program a + integer :: i = 42 + logical l + l = btest(i, -1) ! { dg-error "must be nonnegative" } + l = btest(i, 65) ! { dg-error "must be less than" } +end program a diff --git a/Fortran/gfortran/regression/byte_1.f90 b/Fortran/gfortran/regression/byte_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/byte_1.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options " -std=f95" } +program testbyte + integer(1) :: ii = 7 + call foo(ii) +end program testbyte + +subroutine foo(ii) + integer(1) ii + byte b ! { dg-error "BYTE type" } + b = ii + call bar(ii,b) +end subroutine foo + +subroutine bar(ii,b) + integer (1) ii + byte b ! { dg-error "BYTE type" } + if (b.ne.ii) then +! print *,"Failed" + STOP 1 + end if +end subroutine bar diff --git a/Fortran/gfortran/regression/byte_2.f90 b/Fortran/gfortran/regression/byte_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/byte_2.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! { dg-options "-std=gnu" } +program testbyte + integer(1) :: ii = 7 + call foo(ii) +end program testbyte + +subroutine foo(ii) + integer(1) ii + byte b + b = ii + call bar(ii,b) +end subroutine foo + +subroutine bar(ii,b) + integer (1) ii + byte b + if (b.ne.ii) then +! print *,"Failed" + STOP 1 + end if +end subroutine bar diff --git a/Fortran/gfortran/regression/byte_3.f b/Fortran/gfortran/regression/byte_3.f --- /dev/null +++ b/Fortran/gfortran/regression/byte_3.f @@ -0,0 +1,6 @@ +c { dg-do run } +c { dg-options "-std=legacy" } + bytea + a = 1 + if (a /= 1 .and. kind(a) /= a) stop 1 + end diff --git a/Fortran/gfortran/regression/byte_4.f90 b/Fortran/gfortran/regression/byte_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/byte_4.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-w" } + bytea ! { dg-error "Unclassifiable statement" } + byte b + byte :: d + a = 1 + b = 1 + d = 1 + print *, a, b * d + end diff --git a/Fortran/gfortran/regression/c_assoc.f90 b/Fortran/gfortran/regression/c_assoc.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_assoc.f90 @@ -0,0 +1,68 @@ +! { dg-do run } +! { dg-additional-sources test_c_assoc.c } +module c_assoc + use, intrinsic :: iso_c_binding + implicit none + +contains + + function test_c_assoc_0(my_c_ptr) bind(c) + use, intrinsic :: iso_c_binding, only: c_ptr, c_int, c_associated + integer(c_int) :: test_c_assoc_0 + type(c_ptr), value :: my_c_ptr + + if(c_associated(my_c_ptr)) then + test_c_assoc_0 = 1 + else + test_c_assoc_0 = 0 + endif + end function test_c_assoc_0 + + function test_c_assoc_1(my_c_ptr_1, my_c_ptr_2) bind(c) + use, intrinsic :: iso_c_binding, only: c_ptr, c_int, c_associated + integer(c_int) :: test_c_assoc_1 + type(c_ptr), value :: my_c_ptr_1 + type(c_ptr), value :: my_c_ptr_2 + + if(c_associated(my_c_ptr_1, my_c_ptr_2)) then + test_c_assoc_1 = 1 + else + test_c_assoc_1 = 0 + endif + end function test_c_assoc_1 + + function test_c_assoc_2(my_c_ptr_1, my_c_ptr_2, num_ptrs) bind(c) + integer(c_int) :: test_c_assoc_2 + type(c_ptr), value :: my_c_ptr_1 + type(c_ptr), value :: my_c_ptr_2 + integer(c_int), value :: num_ptrs + + if(num_ptrs .eq. 1) then + if(c_associated(my_c_ptr_1)) then + test_c_assoc_2 = 1 + else + test_c_assoc_2 = 0 + endif + else + if(c_associated(my_c_ptr_1, my_c_ptr_2)) then + test_c_assoc_2 = 1 + else + test_c_assoc_2 = 0 + endif + endif + end function test_c_assoc_2 + + subroutine verify_assoc(my_c_ptr_1, my_c_ptr_2) bind(c) + type(c_ptr), value :: my_c_ptr_1 + type(c_ptr), value :: my_c_ptr_2 + + if(.not. c_associated(my_c_ptr_1)) then + STOP 1 + else if(.not. c_associated(my_c_ptr_2)) then + STOP 2 + else if(.not. c_associated(my_c_ptr_1, my_c_ptr_2)) then + STOP 3 + endif + end subroutine verify_assoc + +end module c_assoc diff --git a/Fortran/gfortran/regression/c_assoc_2.f03 b/Fortran/gfortran/regression/c_assoc_2.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_assoc_2.f03 @@ -0,0 +1,36 @@ +! { dg-do compile } +module c_assoc_2 + use, intrinsic :: iso_c_binding, only: c_ptr, c_associated + +contains + subroutine sub0(my_c_ptr) bind(c) + type(c_ptr), value :: my_c_ptr + type(c_ptr), pointer :: my_c_ptr_2 + integer :: my_integer + + if(.not. c_associated(my_c_ptr)) then + STOP 1 + end if + + if(.not. c_associated(my_c_ptr, my_c_ptr)) then + STOP 2 + end if + + if(.not. c_associated(my_c_ptr, my_c_ptr, my_c_ptr)) then ! { dg-error "Too many arguments in call" } + STOP 3 + end if + + if(.not. c_associated()) then ! { dg-error "Missing actual argument" } + STOP 4 + end if + + if(.not. c_associated(my_c_ptr_2)) then + STOP 5 + end if + + if(.not. c_associated(my_integer)) then ! { dg-error "shall have the type TYPE.C_PTR. or TYPE.C_FUNPTR." } + STOP 6 + end if + end subroutine sub0 + +end module c_assoc_2 diff --git a/Fortran/gfortran/regression/c_assoc_3.f90 b/Fortran/gfortran/regression/c_assoc_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_assoc_3.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! +! PR fortran/43303 +! +! Contributed by Dennis Wassel +! +PROGRAM c_assoc + use iso_c_binding + type(c_ptr) :: x + x = c_null_ptr + print *, C_ASSOCIATED(x) ! <<< was ICEing here + if (C_ASSOCIATED(x)) STOP 1 +END PROGRAM c_assoc diff --git a/Fortran/gfortran/regression/c_assoc_4.f90 b/Fortran/gfortran/regression/c_assoc_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_assoc_4.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! PR fortran/49023 +! +PROGRAM test + + USE, INTRINSIC :: iso_c_binding + IMPLICIT NONE + + TYPE (C_PTR) :: x, y + + PRINT *, C_ASSOCIATED([x,y]) ! { dg-error "'c_ptr_1' argument of 'c_associated' intrinsic at .1. must be a scalar" } + +END PROGRAM test diff --git a/Fortran/gfortran/regression/c_assoc_5.f90 b/Fortran/gfortran/regression/c_assoc_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_assoc_5.f90 @@ -0,0 +1,69 @@ +! { dg-do compile } +! +! PR fortran/56969 +! +! Contributed by Salvatore Filippone +! +! Was before rejected as the different c_associated weren't recognized to +! come from the same module. +! +module test_mod + use iso_c_binding + + type(c_ptr), save :: test_context = c_null_ptr + + type, bind(c) :: s_Cmat + type(c_ptr) :: Mat = c_null_ptr + end type s_Cmat + + + interface + function FtestCreate(context) & + & bind(c,name="FtestCreate") result(res) + use iso_c_binding + type(c_ptr) :: context + integer(c_int) :: res + end function FtestCreate + end interface +contains + + function initFtest() result(res) + implicit none + integer(c_int) :: res + if (c_associated(test_context)) then + res = 0 + else + res = FtestCreate(test_context) + end if + end function initFtest +end module test_mod + +module base_mat_mod + type base_sparse_mat + integer, allocatable :: ia(:) + end type base_sparse_mat +end module base_mat_mod + +module extd_mat_mod + + use iso_c_binding + use test_mod + use base_mat_mod + + type, extends(base_sparse_mat) :: extd_sparse_mat + type(s_Cmat) :: deviceMat + end type extd_sparse_mat + +end module extd_mat_mod + +subroutine extd_foo(a) + + use extd_mat_mod + implicit none + class(extd_sparse_mat), intent(inout) :: a + + if (c_associated(a%deviceMat%Mat)) then + write(*,*) 'C Associated' + end if + +end subroutine extd_foo diff --git a/Fortran/gfortran/regression/c_by_val.c b/Fortran/gfortran/regression/c_by_val.c --- /dev/null +++ b/Fortran/gfortran/regression/c_by_val.c @@ -0,0 +1,76 @@ +/* Passing from fortran to C by value, using %VAL. */ + +#include + +/* We used to #include , but this fails for some platforms + (like cygwin) who don't have it yet. */ +#define complex __complex__ +#define _Complex_I (1.0iF) + +extern void f_to_f__ (float*, float, float*, float**); +extern void f_to_f8__ (double*, double, double*, double**); +extern void i_to_i__ (int*, int, int*, int**); +extern void i_to_i8__ (int64_t*, int64_t, int64_t*, int64_t**); +extern void c_to_c__ (complex float*, complex float, complex float*, complex float**); +extern void c_to_c8__ (complex double*, complex double, complex double*, complex double**); +extern void abort (void); + +void +f_to_f__(float *retval, float a1, float *a2, float **a3) +{ + if ( a1 != *a2 ) abort(); + if ( a1 != **a3 ) abort(); + a1 = 0.0; + *retval = *a2 * 2.0; + return; +} + +void +f_to_f8__(double *retval, double a1, double *a2, double **a3) +{ + if ( a1 != *a2 ) abort(); + if ( a1 != **a3 ) abort(); + a1 = 0.0; + *retval = *a2 * 2.0; + return; +} + +void +i_to_i__(int *retval, int i1, int *i2, int **i3) +{ + if ( i1 != *i2 ) abort(); + if ( i1 != **i3 ) abort(); + i1 = 0; + *retval = *i2 * 3; + return; +} + +void +i_to_i8__(int64_t *retval, int64_t i1, int64_t *i2, int64_t **i3) +{ + if ( i1 != *i2 ) abort(); + if ( i1 != **i3 ) abort(); + i1 = 0; + *retval = *i2 * 3; + return; +} + +void +c_to_c__(complex float *retval, complex float c1, complex float *c2, complex float **c3) +{ + if ( c1 != *c2 ) abort(); + if ( c1 != *(*c3) ) abort(); + c1 = 0.0 + 0.0 * _Complex_I; + *retval = (*c2) * 4.0; + return; +} + +void +c_to_c8__(complex double *retval, complex double c1, complex double *c2, complex double **c3) +{ + if ( c1 != *c2 ) abort(); + if ( c1 != *(*c3) ) abort(); + c1 = 0.0 + 0.0 * _Complex_I;; + *retval = (*c2) * 4.0; + return; +} diff --git a/Fortran/gfortran/regression/c_by_val_1.f b/Fortran/gfortran/regression/c_by_val_1.f --- /dev/null +++ b/Fortran/gfortran/regression/c_by_val_1.f @@ -0,0 +1,53 @@ +C { dg-do run } +C { dg-additional-sources c_by_val.c } +C { dg-options "-ff2c -w -O0" } + + program c_by_val_1 + external f_to_f, i_to_i, c_to_c + external f_to_f8, i_to_i8, c_to_c8 + real a, b, c + real(8) a8, b8, c8 + integer(4) i, j, k + integer(8) i8, j8, k8 + complex u, v, w + complex(8) u8, v8, w8 + + a = 42.0 + b = 0.0 + c = a + call f_to_f (b, %VAL (a), %REF (c), %LOC (c)) + if ((2.0 * a).ne.b) STOP 1 + + a8 = 43.0 + b8 = 1.0 + c8 = a8 + call f_to_f8 (b8, %VAL (a8), %REF (c8), %LOC (c8)) + if ((2.0 * a8).ne.b8) STOP 2 + + i = 99 + j = 0 + k = i + call i_to_i (j, %VAL (i), %REF (k), %LOC (k)) + if ((3 * i).ne.j) STOP 3 + + i8 = 199 + j8 = 10 + k8 = i8 + call i_to_i8 (j8, %VAL (i8), %REF (k8), %LOC (k8)) + if ((3 * i8).ne.j8) STOP 4 + + u = (-1.0, 2.0) + v = (1.0, -2.0) + w = u + call c_to_c (v, %VAL (u), %REF (w), %LOC (w)) + if ((4.0 * u).ne.v) STOP 5 + + u8 = (-1.0, 2.0) + v8 = (1.0, -2.0) + w8 = u8 + call c_to_c8 (v8, %VAL (u8), %REF (w8), %LOC (w8)) + if ((4.0 * u8).ne.v8) STOP 6 + + stop + end + diff --git a/Fortran/gfortran/regression/c_by_val_2.f90 b/Fortran/gfortran/regression/c_by_val_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_by_val_2.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! { dg-options "-w" } + +program c_by_val_2 + external bar + real (4) :: bar, ar(2) = (/1.0,2.0/) + type :: mytype + integer :: i + end type mytype + type(mytype) :: z + character(8) :: c = "blooey" + real :: stmfun, x + stmfun(x)=x**2 + + x = 5 + print *, stmfun(%VAL(x)) ! { dg-error "not allowed in this context" } + print *, sin (%VAL(2.0)) ! { dg-error "not allowed in this context" } + print *, foo (%VAL(1.0)) ! { dg-error "not allowed in this context" } + call foobar (%VAL(0.5)) ! { dg-error "not allowed in this context" } + print *, bar (%VAL(z)) ! { dg-error "not of numeric type" } + print *, bar (%VAL(c)) ! { dg-error "not of numeric type" } + print *, bar (%VAL(ar)) ! { dg-error "cannot be an array" } + print *, bar (%VAL(0.0)) +contains + function foo (a) + real(4) :: a, foo + foo = cos (a) + end function foo + subroutine foobar (a) + real(4) :: a + print *, a + end subroutine foobar +end program c_by_val_2 + diff --git a/Fortran/gfortran/regression/c_by_val_3.f90 b/Fortran/gfortran/regression/c_by_val_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_by_val_3.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +program c_by_val_3 + external bar + real (4) :: bar + print *, bar (%VAL(0.0)) ! { dg-error "argument list function" } +end program c_by_val_3 diff --git a/Fortran/gfortran/regression/c_by_val_4.f b/Fortran/gfortran/regression/c_by_val_4.f --- /dev/null +++ b/Fortran/gfortran/regression/c_by_val_4.f @@ -0,0 +1,17 @@ +C { dg-do compile } +C Tests the fix for PR30888, in which the dummy procedure would +C generate an error with the %VAL argument, even though it is +C declared EXTERNAL. +C +C Contributed by Peter W. Draper +C + SUBROUTINE VALTEST( DOIT ) + EXTERNAL DOIT + INTEGER P + INTEGER I + I = 0 + P = 0 + CALL DOIT( %VAL( P ) ) ! { dg-warning "Extension: argument list function" } + CALL DOIT( I ) + CALL DOIT( %VAL( P ) ) ! { dg-warning "Extension: argument list function" } + END diff --git a/Fortran/gfortran/regression/c_by_val_5.f90 b/Fortran/gfortran/regression/c_by_val_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_by_val_5.f90 @@ -0,0 +1,67 @@ +! { dg-do run } +! Overwrite -pedantic setting: +! { dg-options "-Wall" } +! +! Tests the fix for PR31668, in which %VAL was rejected for +! module and internal procedures. +! + +subroutine bmp_write(nx) + implicit none + integer, value :: nx + if(nx /= 10) STOP 1 + nx = 11 + if(nx /= 11) STOP 2 +end subroutine bmp_write + +module x + implicit none + ! The following interface does in principle + ! not match the procedure (missing VALUE attribute) + ! However, this occures in real-world code calling + ! C routines where an interface is better than + ! "external" only. + interface + subroutine bmp_write(nx) + integer, value :: nx + end subroutine bmp_write + end interface +contains + SUBROUTINE Grid2BMP(NX) + INTEGER, INTENT(IN) :: NX + if(nx /= 10) STOP 3 + call bmp_write(%val(nx)) + if(nx /= 10) STOP 4 + END SUBROUTINE Grid2BMP +END module x + +! The following test is possible and +! accepted by other compilers, but +! does not make much sense. +! Either one uses VALUE then %VAL is +! not needed or the function will give +! wrong results. +! +!subroutine test() +! implicit none +! integer :: n +! n = 5 +! if(n /= 5) STOP 5 +! call test2(%VAL(n)) +! if(n /= 5) STOP 6 +! contains +! subroutine test2(a) +! integer, value :: a +! if(a /= 5) STOP 7 +! a = 2 +! if(a /= 2) STOP 8 +! end subroutine test2 +!end subroutine test + +program main + use x + implicit none +! external test + call Grid2BMP(10) +! call test() +end program main diff --git a/Fortran/gfortran/regression/c_char_driver.c b/Fortran/gfortran/regression/c_char_driver.c --- /dev/null +++ b/Fortran/gfortran/regression/c_char_driver.c @@ -0,0 +1,14 @@ +void param_test(char my_char, char my_char_2); +void sub0(void); +void sub1(char *my_char); + +int main(int argc, char **argv) +{ + char my_char = 'y'; + + param_test('y', 'z'); + sub0(); + sub1(&my_char); + + return 0; +} diff --git a/Fortran/gfortran/regression/c_char_tests.f03 b/Fortran/gfortran/regression/c_char_tests.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_char_tests.f03 @@ -0,0 +1,27 @@ +! { dg-do run } +! { dg-additional-sources c_char_driver.c } +! Verify that character dummy arguments for bind(c) procedures can work both +! by-value and by-reference when called by either C or Fortran. +! PR fortran/32732 +module c_char_tests + use, intrinsic :: iso_c_binding, only: c_char + implicit none +contains + subroutine param_test(my_char, my_char_2) bind(c) + character(c_char), value :: my_char + character(c_char), value :: my_char_2 + if(my_char /= c_char_'y') STOP 1 + if(my_char_2 /= c_char_'z') STOP 2 + + call sub1(my_char) + end subroutine param_test + + subroutine sub0() bind(c) + call param_test('y', 'z') + end subroutine sub0 + + subroutine sub1(my_char_ref) bind(c) + character(c_char) :: my_char_ref + if(my_char_ref /= c_char_'y') STOP 3 + end subroutine sub1 +end module c_char_tests diff --git a/Fortran/gfortran/regression/c_char_tests_2.f03 b/Fortran/gfortran/regression/c_char_tests_2.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_char_tests_2.f03 @@ -0,0 +1,33 @@ +! { dg-do run } +! Verify that the changes made to character dummy arguments for bind(c) +! procedures doesn't break non-bind(c) routines. +! PR fortran/32732 +subroutine bar(a) + use, intrinsic :: iso_c_binding, only: c_char + character(c_char), value :: a + if(a /= c_char_'a') STOP 1 +end subroutine bar + +subroutine bar2(a) + use, intrinsic :: iso_c_binding, only: c_char + character(c_char) :: a + if(a /= c_char_'a') STOP 2 +end subroutine bar2 + +use iso_c_binding +implicit none +interface + subroutine bar(a) + import + character(c_char),value :: a + end subroutine bar + subroutine bar2(a) + import + character(c_char) :: a + end subroutine bar2 +end interface + character(c_char) :: z + z = 'a' + call bar(z) + call bar2(z) +end diff --git a/Fortran/gfortran/regression/c_char_tests_3.f90 b/Fortran/gfortran/regression/c_char_tests_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_char_tests_3.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! { dg-additional-sources c_char_tests_3_c.c } +! +! PR fortran/103828 +! Check that we can pass many function args as C char, which are interoperable +! with both INTEGER(C_SIGNED_CHAR) and CHARACTER(C_CHAR). + +subroutine test_int (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) bind(c) + use, intrinsic :: iso_c_binding + implicit none + integer(c_signed_char), value :: a, b, c, d, e, f, g, h, i, j, k, l, m, n, o + + if (a /= iachar('a')) stop 1 + if (b /= iachar('b')) stop 2 + if (c /= iachar('c')) stop 3 + if (d /= iachar('d')) stop 4 + if (e /= iachar('e')) stop 5 + if (f /= iachar('f')) stop 6 + if (g /= iachar('g')) stop 7 + if (h /= iachar('h')) stop 8 + if (i /= iachar('i')) stop 9 + if (j /= iachar('j')) stop 10 + if (k /= iachar('k')) stop 11 + if (l /= iachar('l')) stop 12 + if (m /= iachar('m')) stop 13 + if (n /= iachar('n')) stop 14 + if (o /= iachar('o')) stop 15 +end subroutine + +subroutine test_char (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) bind(c) + use, intrinsic :: iso_c_binding + implicit none + character(kind=c_char, len=1), value :: a, b, c, d, e, f, g, h, i, j, k, l, m, n, o + + if (a /= 'a') stop 101 + if (b /= 'b') stop 102 + if (c /= 'c') stop 103 + if (d /= 'd') stop 104 + if (e /= 'e') stop 105 + if (f /= 'f') stop 106 + if (g /= 'g') stop 107 + if (h /= 'h') stop 108 + if (i /= 'i') stop 109 + if (j /= 'j') stop 110 + if (k /= 'k') stop 111 + if (l /= 'l') stop 112 + if (m /= 'm') stop 113 + if (n /= 'n') stop 114 + if (o /= 'o') stop 115 +end subroutine + diff --git a/Fortran/gfortran/regression/c_char_tests_3_c.c b/Fortran/gfortran/regression/c_char_tests_3_c.c --- /dev/null +++ b/Fortran/gfortran/regression/c_char_tests_3_c.c @@ -0,0 +1,16 @@ +void test_char (char, char, char, char, char, + char, char, char, char, char, + char, char, char, char, char); + +void test_int (char, char, char, char, char, + char, char, char, char, char, + char, char, char, char, char); + +int main (void) { + test_char ('a', 'b', 'c', 'd', 'e', + 'f', 'g', 'h', 'i', 'j', + 'k', 'l', 'm', 'n', 'o'); + test_int ('a', 'b', 'c', 'd', 'e', + 'f', 'g', 'h', 'i', 'j', + 'k', 'l', 'm', 'n', 'o'); +} diff --git a/Fortran/gfortran/regression/c_char_tests_4.f90 b/Fortran/gfortran/regression/c_char_tests_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_char_tests_4.f90 @@ -0,0 +1,90 @@ +! { dg-do run } +! +! PR fortran/103828 +! Check that we can pass many function args as C char, which are interoperable +! with both INTEGER(C_SIGNED_CHAR) and CHARACTER(C_CHAR). + +program test + use, intrinsic :: iso_c_binding, only : c_signed_char, c_char + implicit none + + interface + ! In order to perform this test, we cheat and pretend to give each function + ! the other one's prototype. It should still work, because all arguments + ! are interoperable with C char. + + subroutine test1 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) bind(c, name='test_int') + import c_char + character(kind=c_char, len=1), value :: a, b, c, d, e, f, g, h, i, j, k, l, m, n, o + end subroutine test1 + + subroutine test2 (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) bind(c, name='test_char') + import c_signed_char + integer(kind=c_signed_char), value :: a, b, c, d, e, f, g, h, i, j, k, l, m, n, o + end subroutine test2 + + end interface + + call test1('a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o') + call test2(ichar('a', kind=c_signed_char), & + ichar('b', kind=c_signed_char), & + ichar('c', kind=c_signed_char), & + ichar('d', kind=c_signed_char), & + ichar('e', kind=c_signed_char), & + ichar('f', kind=c_signed_char), & + ichar('g', kind=c_signed_char), & + ichar('h', kind=c_signed_char), & + ichar('i', kind=c_signed_char), & + ichar('j', kind=c_signed_char), & + ichar('k', kind=c_signed_char), & + ichar('l', kind=c_signed_char), & + ichar('m', kind=c_signed_char), & + ichar('n', kind=c_signed_char), & + ichar('o', kind=c_signed_char)) + +end program test + +subroutine test_int (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) bind(c) + use, intrinsic :: iso_c_binding, only : c_signed_char + implicit none + integer(c_signed_char), value :: a, b, c, d, e, f, g, h, i, j, k, l, m, n, o + + if (a /= iachar('a')) stop 1 + if (b /= iachar('b')) stop 2 + if (c /= iachar('c')) stop 3 + if (d /= iachar('d')) stop 4 + if (e /= iachar('e')) stop 5 + if (f /= iachar('f')) stop 6 + if (g /= iachar('g')) stop 7 + if (h /= iachar('h')) stop 8 + if (i /= iachar('i')) stop 9 + if (j /= iachar('j')) stop 10 + if (k /= iachar('k')) stop 11 + if (l /= iachar('l')) stop 12 + if (m /= iachar('m')) stop 13 + if (n /= iachar('n')) stop 14 + if (o /= iachar('o')) stop 15 +end subroutine + +subroutine test_char (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) bind(c) + use, intrinsic :: iso_c_binding, only : c_char + implicit none + character(kind=c_char, len=1), value :: a, b, c, d, e, f, g, h, i, j, k, l, m, n, o + + if (a /= 'a') stop 101 + if (b /= 'b') stop 102 + if (c /= 'c') stop 103 + if (d /= 'd') stop 104 + if (e /= 'e') stop 105 + if (f /= 'f') stop 106 + if (g /= 'g') stop 107 + if (h /= 'h') stop 108 + if (i /= 'i') stop 109 + if (j /= 'j') stop 110 + if (k /= 'k') stop 111 + if (l /= 'l') stop 112 + if (m /= 'm') stop 113 + if (n /= 'n') stop 114 + if (o /= 'o') stop 115 +end subroutine + diff --git a/Fortran/gfortran/regression/c_char_tests_5.f90 b/Fortran/gfortran/regression/c_char_tests_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_char_tests_5.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +! { dg-options "-fbackslash" } +! +! PR fortran/103828 +! Check that we can C char with non-ASCII values, which are interoperable +! with both INTEGER(C_SIGNED_CHAR) and CHARACTER(C_CHAR). + +program test + use, intrinsic :: iso_c_binding, only : c_signed_char, c_char + implicit none + + interface + ! In order to perform this test, we cheat and pretend to give each function + ! the other one's prototype. It should still work, because all arguments + ! are interoperable with C char. + + subroutine test1 (a) bind(c, name='test_int') + import c_char + character(kind=c_char, len=1), value :: a + end subroutine test1 + + subroutine test2 (a) bind(c, name='test_char') + import c_signed_char + integer(kind=c_signed_char), value :: a + end subroutine test2 + + end interface + + call test1('\xA3') + call test2(-93_c_signed_char) + +end program test + +subroutine test_int (a) bind(c) + use, intrinsic :: iso_c_binding, only : c_signed_char + implicit none + integer(c_signed_char), value :: a + + if (a /= iachar('\xA3', kind=c_signed_char)) stop 1 +end subroutine + +subroutine test_char (a) bind(c) + use, intrinsic :: iso_c_binding, only : c_char + implicit none + character(kind=c_char, len=1), value :: a + + if (a /= '\xA3') stop 101 +end subroutine + diff --git a/Fortran/gfortran/regression/c_f_pointer_complex.f03 b/Fortran/gfortran/regression/c_f_pointer_complex.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_f_pointer_complex.f03 @@ -0,0 +1,59 @@ +! { dg-do run } +! { dg-additional-sources c_f_pointer_complex_driver.c } +! { dg-options "-std=gnu -w" } +! Test c_f_pointer for the different types of interoperable complex values. +module c_f_pointer_complex + use, intrinsic :: iso_c_binding, only: c_float_complex, c_double_complex, & + c_long_double_complex, c_f_pointer, c_ptr, c_long_double, c_int + implicit none + +contains + subroutine test_complex_scalars(my_c_float_complex, my_c_double_complex, & + my_c_long_double_complex) bind(c) + type(c_ptr), value :: my_c_float_complex + type(c_ptr), value :: my_c_double_complex + type(c_ptr), value :: my_c_long_double_complex + complex(c_float_complex), pointer :: my_f03_float_complex + complex(c_double_complex), pointer :: my_f03_double_complex + complex(c_long_double_complex), pointer :: my_f03_long_double_complex + + call c_f_pointer(my_c_float_complex, my_f03_float_complex) + call c_f_pointer(my_c_double_complex, my_f03_double_complex) + call c_f_pointer(my_c_long_double_complex, my_f03_long_double_complex) + + if(my_f03_float_complex /= (1.0, 0.0)) STOP 1 + if(my_f03_double_complex /= (2.0d0, 0.0d0)) STOP 2 + if(my_f03_long_double_complex /= (3.0_c_long_double, & + 0.0_c_long_double)) STOP 3 + end subroutine test_complex_scalars + + subroutine test_complex_arrays(float_complex_array, double_complex_array, & + long_double_complex_array, num_elems) bind(c) + type(c_ptr), value :: float_complex_array + type(c_ptr), value :: double_complex_array + type(c_ptr), value :: long_double_complex_array + complex(c_float_complex), pointer, dimension(:) :: f03_float_complex_array + complex(c_double_complex), pointer, dimension(:) :: & + f03_double_complex_array + complex(c_long_double_complex), pointer, dimension(:) :: & + f03_long_double_complex_array + integer(c_int), value :: num_elems + integer :: i + + call c_f_pointer(float_complex_array, f03_float_complex_array, & + (/ num_elems /)) + call c_f_pointer(double_complex_array, f03_double_complex_array, & + (/ num_elems /)) + call c_f_pointer(long_double_complex_array, & + f03_long_double_complex_array, (/ num_elems /)) + + do i = 1, num_elems + if(f03_float_complex_array(i) & + /= (i*(1.0, 0.0))) STOP 4 + if(f03_double_complex_array(i) & + /= (i*(1.0d0, 0.0d0))) STOP 5 + if(f03_long_double_complex_array(i) & + /= (i*(1.0_c_long_double, 0.0_c_long_double))) STOP 6 + end do + end subroutine test_complex_arrays +end module c_f_pointer_complex diff --git a/Fortran/gfortran/regression/c_f_pointer_complex_driver.c b/Fortran/gfortran/regression/c_f_pointer_complex_driver.c --- /dev/null +++ b/Fortran/gfortran/regression/c_f_pointer_complex_driver.c @@ -0,0 +1,41 @@ +/* { dg-options "-std=c99 -w" } */ +/* From c_by_val.c in gfortran.dg. */ +#define _Complex_I (1.0iF) + +#define NUM_ELEMS 10 + +void test_complex_scalars (float _Complex *float_complex_ptr, + double _Complex *double_complex_ptr, + long double _Complex *long_double_complex_ptr); +void test_complex_arrays (float _Complex *float_complex_array, + double _Complex *double_complex_array, + long double _Complex *long_double_complex_array, + int num_elems); + +int main (int argc, char **argv) +{ + float _Complex c1; + double _Complex c2; + long double _Complex c3; + float _Complex c1_array[NUM_ELEMS]; + double _Complex c2_array[NUM_ELEMS]; + long double _Complex c3_array[NUM_ELEMS]; + int i; + + c1 = 1.0 + 0.0 * _Complex_I; + c2 = 2.0 + 0.0 * _Complex_I; + c3 = 3.0 + 0.0 * _Complex_I; + + test_complex_scalars (&c1, &c2, &c3); + + for (i = 0; i < NUM_ELEMS; i++) + { + c1_array[i] = 1.0 * (i+1) + 0.0 * _Complex_I; + c2_array[i] = 1.0 * (i+1) + 0.0 * _Complex_I; + c3_array[i] = 1.0 * (i+1) + 0.0 * _Complex_I; + } + + test_complex_arrays (c1_array, c2_array, c3_array, NUM_ELEMS); + + return 0; +} diff --git a/Fortran/gfortran/regression/c_f_pointer_logical.f03 b/Fortran/gfortran/regression/c_f_pointer_logical.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_f_pointer_logical.f03 @@ -0,0 +1,33 @@ +! { dg-do run } +! { dg-additional-sources c_f_pointer_logical_driver.c } +! Verify that c_f_pointer exists for C logicals (_Bool). +module c_f_pointer_logical + use, intrinsic :: iso_c_binding, only: c_bool, c_f_pointer, c_ptr, c_int +contains + subroutine test_scalar(c_logical_ptr) bind(c) + type(c_ptr), value :: c_logical_ptr + logical(c_bool), pointer :: f03_logical_ptr + call c_f_pointer(c_logical_ptr, f03_logical_ptr) + + if(f03_logical_ptr .neqv. .true.) STOP 1 + end subroutine test_scalar + + subroutine test_array(c_logical_array, num_elems) bind(c) + type(c_ptr), value :: c_logical_array + integer(c_int), value :: num_elems + logical(c_bool), pointer, dimension(:) :: f03_logical_array + integer :: i + + call c_f_pointer(c_logical_array, f03_logical_array, (/ num_elems /)) + + ! Odd numbered locations are true (even numbered offsets in C) + do i = 1, num_elems, 2 + if(f03_logical_array(i) .neqv. .true.) STOP 2 + end do + + ! Even numbered locations are false. + do i = 2, num_elems, 2 + if(f03_logical_array(i) .neqv. .false.) STOP 3 + end do + end subroutine test_array +end module c_f_pointer_logical diff --git a/Fortran/gfortran/regression/c_f_pointer_logical_driver.c b/Fortran/gfortran/regression/c_f_pointer_logical_driver.c --- /dev/null +++ b/Fortran/gfortran/regression/c_f_pointer_logical_driver.c @@ -0,0 +1,26 @@ +/* { dg-options "-std=c99 -w" } */ + +#include + +#define NUM_ELEMS 10 + +void test_scalar(bool *my_c_bool_ptr); +void test_array(bool *my_bool_array, int num_elems); + +int main(int argc, char **argv) +{ + bool my_bool = true; + bool my_bool_array[NUM_ELEMS]; + int i; + + test_scalar(&my_bool); + + for(i = 0; i < NUM_ELEMS; i+=2) + my_bool_array[i] = true; + for(i = 1; i < NUM_ELEMS; i+=2) + my_bool_array[i] = false; + + test_array(my_bool_array, NUM_ELEMS); + + return 0; +} diff --git a/Fortran/gfortran/regression/c_f_pointer_shape_test.f90 b/Fortran/gfortran/regression/c_f_pointer_shape_test.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_f_pointer_shape_test.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! Verify that the compiler catches the error in the call to c_f_pointer +! because it is missing the required SHAPE argument. The SHAPE argument +! is optional, in general, but must exist if given a Fortran pointer +! to a non-zero rank object. --Rickett, 09.26.06 +module c_f_pointer_shape_test +contains + subroutine test_0(myAssumedArray, cPtr) + use, intrinsic :: iso_c_binding + integer, dimension(*) :: myAssumedArray + integer, dimension(:), pointer :: myArrayPtr + integer, dimension(1:2), target :: myArray + type(c_ptr), value :: cPtr + + myArrayPtr => myArray + call c_f_pointer(cPtr, myArrayPtr) ! { dg-error "Expected SHAPE argument to C_F_POINTER with array FPTR" } + end subroutine test_0 +end module c_f_pointer_shape_test diff --git a/Fortran/gfortran/regression/c_f_pointer_shape_tests_2.f03 b/Fortran/gfortran/regression/c_f_pointer_shape_tests_2.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_f_pointer_shape_tests_2.f03 @@ -0,0 +1,112 @@ +! { dg-do run } +! { dg-additional-sources c_f_pointer_shape_tests_2_driver.c } +! Verify that the optional SHAPE parameter to c_f_pointer can be of any +! valid integer kind. We don't test all kinds here since it would be +! difficult to know what kinds are valid for the architecture we're running on. +! However, testing ones that should be different should be sufficient. +module c_f_pointer_shape_tests_2 + use, intrinsic :: iso_c_binding + implicit none +contains + subroutine test_long_long_1d(cPtr, num_elems) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr), value :: cPtr + integer(c_int), value :: num_elems + integer(c_int), dimension(:), pointer :: myArrayPtr + integer(c_long_long), dimension(1) :: shape + integer :: i + + shape(1) = num_elems + call c_f_pointer(cPtr, myArrayPtr, shape) + do i = 1, num_elems + if(myArrayPtr(i) /= (i-1)) STOP 1 + end do + end subroutine test_long_long_1d + + subroutine test_long_long_2d(cPtr, num_rows, num_cols) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr), value :: cPtr + integer(c_int), value :: num_rows + integer(c_int), value :: num_cols + integer(c_int), dimension(:,:), pointer :: myArrayPtr + integer(c_long_long), dimension(2) :: shape + integer :: i,j + + shape(1) = num_rows + shape(2) = num_cols + call c_f_pointer(cPtr, myArrayPtr, shape) + do j = 1, num_cols + do i = 1, num_rows + if(myArrayPtr(i,j) /= ((j-1)*num_rows)+(i-1)) STOP 2 + end do + end do + end subroutine test_long_long_2d + + subroutine test_long_1d(cPtr, num_elems) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr), value :: cPtr + integer(c_int), value :: num_elems + integer(c_int), dimension(:), pointer :: myArrayPtr + integer(c_long), dimension(1) :: shape + integer :: i + + shape(1) = num_elems + call c_f_pointer(cPtr, myArrayPtr, shape) + do i = 1, num_elems + if(myArrayPtr(i) /= (i-1)) STOP 3 + end do + end subroutine test_long_1d + + subroutine test_int_1d(cPtr, num_elems) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr), value :: cPtr + integer(c_int), value :: num_elems + integer(c_int), dimension(:), pointer :: myArrayPtr + integer(c_int), dimension(1) :: shape + integer :: i + + shape(1) = num_elems + call c_f_pointer(cPtr, myArrayPtr, shape) + do i = 1, num_elems + if(myArrayPtr(i) /= (i-1)) STOP 4 + end do + end subroutine test_int_1d + + subroutine test_short_1d(cPtr, num_elems) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr), value :: cPtr + integer(c_int), value :: num_elems + integer(c_int), dimension(:), pointer :: myArrayPtr + integer(c_short), dimension(1) :: shape + integer :: i + + shape(1) = num_elems + call c_f_pointer(cPtr, myArrayPtr, shape) + do i = 1, num_elems + if(myArrayPtr(i) /= (i-1)) STOP 5 + end do + end subroutine test_short_1d + + subroutine test_mixed(cPtr, num_elems) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr), value :: cPtr + integer(c_int), value :: num_elems + integer(c_int), dimension(:), pointer :: myArrayPtr + integer(c_int), dimension(1) :: shape1 + integer(c_long_long), dimension(1) :: shape2 + integer :: i + + shape1(1) = num_elems + call c_f_pointer(cPtr, myArrayPtr, shape1) + do i = 1, num_elems + if(myArrayPtr(i) /= (i-1)) STOP 6 + end do + + nullify(myArrayPtr) + shape2(1) = num_elems + call c_f_pointer(cPtr, myArrayPtr, shape2) + do i = 1, num_elems + if(myArrayPtr(i) /= (i-1)) STOP 7 + end do + end subroutine test_mixed +end module c_f_pointer_shape_tests_2 diff --git a/Fortran/gfortran/regression/c_f_pointer_shape_tests_2_driver.c b/Fortran/gfortran/regression/c_f_pointer_shape_tests_2_driver.c --- /dev/null +++ b/Fortran/gfortran/regression/c_f_pointer_shape_tests_2_driver.c @@ -0,0 +1,46 @@ +#define NUM_ELEMS 10 +#define NUM_ROWS 2 +#define NUM_COLS 3 + +void test_long_long_1d(int *array, int num_elems); +void test_long_long_2d(int *array, int num_rows, int num_cols); +void test_long_1d(int *array, int num_elems); +void test_int_1d(int *array, int num_elems); +void test_short_1d(int *array, int num_elems); +void test_mixed(int *array, int num_elems); + +int main(int argc, char **argv) +{ + int my_array[NUM_ELEMS]; + int my_2d_array[NUM_ROWS][NUM_COLS]; + int i, j; + + for(i = 0; i < NUM_ELEMS; i++) + my_array[i] = i; + + for(i = 0; i < NUM_ROWS; i++) + for(j = 0; j < NUM_COLS; j++) + my_2d_array[i][j] = (i*NUM_COLS) + j; + + /* Test c_f_pointer where SHAPE is of type integer, kind=c_long_long. */ + test_long_long_1d(my_array, NUM_ELEMS); + + /* Test c_f_pointer where SHAPE is of type integer, kind=c_long_long. + The indices are transposed for Fortran. */ + test_long_long_2d(my_2d_array[0], NUM_COLS, NUM_ROWS); + + /* Test c_f_pointer where SHAPE is of type integer, kind=c_long. */ + test_long_1d(my_array, NUM_ELEMS); + + /* Test c_f_pointer where SHAPE is of type integer, kind=c_int. */ + test_int_1d(my_array, NUM_ELEMS); + + /* Test c_f_pointer where SHAPE is of type integer, kind=c_short. */ + test_short_1d(my_array, NUM_ELEMS); + + /* Test c_f_pointer where SHAPE is of type integer, kind=c_int and + kind=c_long_long. */ + test_mixed(my_array, NUM_ELEMS); + + return 0; +} diff --git a/Fortran/gfortran/regression/c_f_pointer_shape_tests_3.f03 b/Fortran/gfortran/regression/c_f_pointer_shape_tests_3.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_f_pointer_shape_tests_3.f03 @@ -0,0 +1,22 @@ +! { dg-do compile } +! Verify that the type and rank of the SHAPE argument are enforced. +module c_f_pointer_shape_tests_3 + use, intrinsic :: iso_c_binding + +contains + subroutine sub0(my_c_array) bind(c) + type(c_ptr), value :: my_c_array + integer(c_int), dimension(:), pointer :: my_array_ptr + + call c_f_pointer(my_c_array, my_array_ptr, (/ 10.0 /)) ! { dg-error "must be INTEGER" } + end subroutine sub0 + + subroutine sub1(my_c_array) bind(c) + type(c_ptr), value :: my_c_array + integer(c_int), dimension(:), pointer :: my_array_ptr + integer(c_int), dimension(1,1) :: shape + + shape(1,1) = 10 + call c_f_pointer(my_c_array, my_array_ptr, shape) ! { dg-error "must be of rank 1" } + end subroutine sub1 +end module c_f_pointer_shape_tests_3 diff --git a/Fortran/gfortran/regression/c_f_pointer_shape_tests_4.f03 b/Fortran/gfortran/regression/c_f_pointer_shape_tests_4.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_f_pointer_shape_tests_4.f03 @@ -0,0 +1,113 @@ +! { dg-do run } +! { dg-additional-sources c_f_pointer_shape_tests_2_driver.c } +! Verify that the optional SHAPE parameter to c_f_pointer can be of any +! valid integer kind. We don't test all kinds here since it would be +! difficult to know what kinds are valid for the architecture we're running on. +! However, testing ones that should be different should be sufficient. +module c_f_pointer_shape_tests_4 + use, intrinsic :: iso_c_binding + implicit none +contains + subroutine test_long_long_1d(cPtr, num_elems) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr), value :: cPtr + integer(c_int), value :: num_elems + integer(c_int), dimension(:), pointer :: myArrayPtr + integer(c_long_long), dimension(1) :: shape + integer :: i + + shape(1) = num_elems + call c_f_pointer(cPtr, myArrayPtr, shape) + do i = 1, num_elems + if(myArrayPtr(i) /= (i-1)) STOP 1 + end do + end subroutine test_long_long_1d + + subroutine test_long_long_2d(cPtr, num_rows, num_cols) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr), value :: cPtr + integer(c_int), value :: num_rows + integer(c_int), value :: num_cols + integer(c_int), dimension(:,:), pointer :: myArrayPtr + integer(c_long_long), dimension(3) :: shape + integer :: i,j + + shape(1) = num_rows + shape(2) = -3; + shape(3) = num_cols + call c_f_pointer(cPtr, myArrayPtr, shape(1:3:2)) + do j = 1, num_cols + do i = 1, num_rows + if(myArrayPtr(i,j) /= ((j-1)*num_rows)+(i-1)) STOP 2 + end do + end do + end subroutine test_long_long_2d + + subroutine test_long_1d(cPtr, num_elems) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr), value :: cPtr + integer(c_int), value :: num_elems + integer(c_int), dimension(:), pointer :: myArrayPtr + integer(c_long), dimension(1) :: shape + integer :: i + + shape(1) = num_elems + call c_f_pointer(cPtr, myArrayPtr, shape) + do i = 1, num_elems + if(myArrayPtr(i) /= (i-1)) STOP 3 + end do + end subroutine test_long_1d + + subroutine test_int_1d(cPtr, num_elems) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr), value :: cPtr + integer(c_int), value :: num_elems + integer(c_int), dimension(:), pointer :: myArrayPtr + integer(c_int), dimension(1) :: shape + integer :: i + + shape(1) = num_elems + call c_f_pointer(cPtr, myArrayPtr, shape) + do i = 1, num_elems + if(myArrayPtr(i) /= (i-1)) STOP 4 + end do + end subroutine test_int_1d + + subroutine test_short_1d(cPtr, num_elems) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr), value :: cPtr + integer(c_int), value :: num_elems + integer(c_int), dimension(:), pointer :: myArrayPtr + integer(c_short), dimension(1) :: shape + integer :: i + + shape(1) = num_elems + call c_f_pointer(cPtr, myArrayPtr, shape) + do i = 1, num_elems + if(myArrayPtr(i) /= (i-1)) STOP 5 + end do + end subroutine test_short_1d + + subroutine test_mixed(cPtr, num_elems) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr), value :: cPtr + integer(c_int), value :: num_elems + integer(c_int), dimension(:), pointer :: myArrayPtr + integer(c_int), dimension(1) :: shape1 + integer(c_long_long), dimension(1) :: shape2 + integer :: i + + shape1(1) = num_elems + call c_f_pointer(cPtr, myArrayPtr, shape1) + do i = 1, num_elems + if(myArrayPtr(i) /= (i-1)) STOP 6 + end do + + nullify(myArrayPtr) + shape2(1) = num_elems + call c_f_pointer(cPtr, myArrayPtr, shape2) + do i = 1, num_elems + if(myArrayPtr(i) /= (i-1)) STOP 7 + end do + end subroutine test_mixed +end module c_f_pointer_shape_tests_4 diff --git a/Fortran/gfortran/regression/c_f_pointer_shape_tests_4_driver.c b/Fortran/gfortran/regression/c_f_pointer_shape_tests_4_driver.c --- /dev/null +++ b/Fortran/gfortran/regression/c_f_pointer_shape_tests_4_driver.c @@ -0,0 +1,46 @@ +#define NUM_ELEMS 10 +#define NUM_ROWS 2 +#define NUM_COLS 3 + +void test_long_long_1d(int *array, int num_elems); +void test_long_long_2d(int *array, int num_rows, int num_cols); +void test_long_1d(int *array, int num_elems); +void test_int_1d(int *array, int num_elems); +void test_short_1d(int *array, int num_elems); +void test_mixed(int *array, int num_elems); + +int main(int argc, char **argv) +{ + int my_array[NUM_ELEMS]; + int my_2d_array[NUM_ROWS][NUM_COLS]; + int i, j; + + for(i = 0; i < NUM_ELEMS; i++) + my_array[i] = i; + + for(i = 0; i < NUM_ROWS; i++) + for(j = 0; j < NUM_COLS; j++) + my_2d_array[i][j] = (i*NUM_COLS) + j; + + /* Test c_f_pointer where SHAPE is of type integer, kind=c_long_long. */ + test_long_long_1d(my_array, NUM_ELEMS); + + /* Test c_f_pointer where SHAPE is of type integer, kind=c_long_long. + The indices are transposed for Fortran. */ + test_long_long_2d(my_2d_array[0], NUM_COLS, NUM_ROWS); + + /* Test c_f_pointer where SHAPE is of type integer, kind=c_long. */ + test_long_1d(my_array, NUM_ELEMS); + + /* Test c_f_pointer where SHAPE is of type integer, kind=c_int. */ + test_int_1d(my_array, NUM_ELEMS); + + /* Test c_f_pointer where SHAPE is of type integer, kind=c_short. */ + test_short_1d(my_array, NUM_ELEMS); + + /* Test c_f_pointer where SHAPE is of type integer, kind=c_int and + kind=c_long_long. */ + test_mixed(my_array, NUM_ELEMS); + + return 0; +} diff --git a/Fortran/gfortran/regression/c_f_pointer_shape_tests_5.f90 b/Fortran/gfortran/regression/c_f_pointer_shape_tests_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_f_pointer_shape_tests_5.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! +! Check that C_F_Pointer works with a noncontiguous SHAPE argument +! +use iso_c_binding +type(c_ptr) :: x +integer, target :: array(3) +integer, pointer :: ptr(:,:) +integer, pointer :: ptr2(:,:,:) +integer :: myshape(5) + +array = [22,33,44] +x = c_loc(array) +myshape = [1,2,3,4,1] + +call c_f_pointer(x, ptr, shape=myshape(1:4:2)) +if (any (lbound(ptr) /= [ 1, 1])) STOP 1 +if (any (ubound(ptr) /= [ 1, 3])) STOP 2 +if (any (shape(ptr) /= [ 1, 3])) STOP 3 +if (any (ptr(1,:) /= array)) STOP 4 + +call c_f_pointer(x, ptr2, shape=myshape([1,3,1])) +if (any (lbound(ptr2) /= [ 1, 1, 1])) STOP 5 +if (any (ubound(ptr2) /= [ 1, 3, 1])) STOP 6 +if (any (shape(ptr2) /= [ 1, 3, 1])) STOP 7 +if (any (ptr2(1,:,1) /= array)) STOP 8 +end diff --git a/Fortran/gfortran/regression/c_f_pointer_shape_tests_6.f90 b/Fortran/gfortran/regression/c_f_pointer_shape_tests_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_f_pointer_shape_tests_6.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! PR 60302: [4.9 Regression] ICE with c_f_pointer and android cross compiler +! +! Contributed by Valery Weber + +subroutine reshape_inplace_c2_c2 (new_shape) + use, intrinsic :: iso_c_binding + implicit none + integer :: new_shape(:) + complex, pointer :: ptr_x(:) + type(c_ptr) :: loc_x + call c_f_pointer (loc_x, ptr_x, new_shape) +end subroutine diff --git a/Fortran/gfortran/regression/c_f_pointer_tests.f90 b/Fortran/gfortran/regression/c_f_pointer_tests.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_f_pointer_tests.f90 @@ -0,0 +1,68 @@ +! { dg-do run } +! { dg-additional-sources c_f_tests_driver.c } +module c_f_pointer_tests + use, intrinsic :: iso_c_binding + + type myF90Derived + integer(c_int) :: cInt + real(c_double) :: cDouble + real(c_float) :: cFloat + integer(c_short) :: cShort + type(c_funptr) :: myFunPtr + end type myF90Derived + + type dummyDerived + integer(c_int) :: myInt + end type dummyDerived + + contains + + subroutine testDerivedPtrs(myCDerived, derivedArray, arrayLen, & + derived2DArray, dim1, dim2) & + bind(c, name="testDerivedPtrs") + implicit none + type(c_ptr), value :: myCDerived + type(c_ptr), value :: derivedArray + integer(c_int), value :: arrayLen + type(c_ptr), value :: derived2DArray + integer(c_int), value :: dim1 + integer(c_int), value :: dim2 + type(myF90Derived), pointer :: myF90Type + type(myF90Derived), dimension(:), pointer :: myF90DerivedArray + type(myF90Derived), dimension(:,:), pointer :: derivedArray2D + ! one dimensional array coming in (derivedArray) + integer(c_int), dimension(1:1) :: shapeArray + integer(c_int), dimension(1:2) :: shapeArray2 + type(myF90Derived), dimension(1:10), target :: tmpArray + + call c_f_pointer(myCDerived, myF90Type) + ! make sure numbers are ok. initialized in c_f_tests_driver.c + if(myF90Type%cInt .ne. 1) then + STOP 1 + endif + if(myF90Type%cDouble .ne. 2.0d0) then + STOP 2 + endif + if(myF90Type%cFloat .ne. 3.0) then + STOP 3 + endif + if(myF90Type%cShort .ne. 4) then + STOP 4 + endif + + shapeArray(1) = arrayLen + call c_f_pointer(derivedArray, myF90DerivedArray, shapeArray) + + ! upper bound of each dim is arrayLen2 + shapeArray2(1) = dim1 + shapeArray2(2) = dim2 + call c_f_pointer(derived2DArray, derivedArray2D, shapeArray2) + ! make sure the last element is ok + if((derivedArray2D(dim1, dim2)%cInt .ne. 4) .or. & + (derivedArray2D(dim1, dim2)%cDouble .ne. 4.0d0) .or. & + (derivedArray2D(dim1, dim2)%cFloat .ne. 4.0) .or. & + (derivedArray2D(dim1, dim2)%cShort .ne. 4)) then + STOP 5 + endif + end subroutine testDerivedPtrs +end module c_f_pointer_tests diff --git a/Fortran/gfortran/regression/c_f_pointer_tests_2.f03 b/Fortran/gfortran/regression/c_f_pointer_tests_2.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_f_pointer_tests_2.f03 @@ -0,0 +1,20 @@ +! { dg-do compile } +! This should compile. There was a bug in resolving c_f_pointer that was +! caused by not sorting the actual args to match the order of the formal args. +! PR fortran/32800 +! +FUNCTION C_F_STRING(CPTR) RESULT(FPTR) + USE ISO_C_BINDING + implicit none + TYPE(C_PTR), INTENT(IN) :: CPTR ! The C address + CHARACTER(KIND=C_CHAR), DIMENSION(:), POINTER :: FPTR + INTERFACE + FUNCTION strlen(string) RESULT(len) BIND(C,NAME="strlen") + import + TYPE(C_PTR), VALUE :: string ! A C pointer + integer(c_int) :: len + END FUNCTION strlen + END INTERFACE + CALL C_F_POINTER(FPTR=FPTR, CPTR=CPTR,SHAPE=[strlen(cptr)]) +END FUNCTION C_F_STRING + diff --git a/Fortran/gfortran/regression/c_f_pointer_tests_3.f90 b/Fortran/gfortran/regression/c_f_pointer_tests_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_f_pointer_tests_3.f90 @@ -0,0 +1,41 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } +! +! PR fortran/32600 c_f_pointer w/o shape +! PR fortran/32580 c_f_procpointer +! +! Verify that c_f_prointer [w/o shape] and c_f_procpointer generate +! the right code - and no library call + +program test + use iso_c_binding + implicit none + type(c_ptr) :: cptr + type(c_funptr) :: cfunptr + integer(4), pointer :: fptr + integer(4), pointer :: fptr_array(:) + procedure(integer(4)), pointer :: fprocptr + + call c_f_pointer(cptr, fptr) + call c_f_pointer(cptr, fptr_array, [ 1 ]) + call c_f_procpointer(cfunptr, fprocptr) +end program test + +! Make sure there is no function call: +! { dg-final { scan-tree-dump-times "c_f" 0 "original" } } +! { dg-final { scan-tree-dump-times "c_f_pointer" 0 "original" } } +! { dg-final { scan-tree-dump-times "c_f_pointer_i4" 0 "original" } } +! +! Check scalar c_f_pointer +! { dg-final { scan-tree-dump-times " fptr = .integer.kind=4. .. cptr" 1 "original" } } +! +! Array c_f_pointer: +! +! { dg-final { scan-tree-dump-times " fptr_array.data = cptr;" 1 "original" } } +! { dg-final { scan-tree-dump-times " fptr_array.dim\\\[S..\\\].lbound = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times " fptr_array.dim\\\[S..\\\].ubound = " 1 "original" } } +! { dg-final { scan-tree-dump-times " fptr_array.dim\\\[S..\\\].stride = " 1 "original" } } +! +! Check c_f_procpointer +! { dg-final { scan-tree-dump-times " fprocptr = .integer.kind=4. .\\*<.*>. ... cfunptr;" 1 "original" } } +! diff --git a/Fortran/gfortran/regression/c_f_pointer_tests_4.f90 b/Fortran/gfortran/regression/c_f_pointer_tests_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_f_pointer_tests_4.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +program main + use iso_c_binding, only: c_ptr, c_loc, c_f_pointer + implicit none + integer, dimension(2,1,2), target :: table + table = reshape ( (/ 1,2,-1,-2/), (/2,1,2/)) + call set_table (c_loc (table)) +contains + subroutine set_table (cptr) + type(c_ptr), intent(in) :: cptr + integer, dimension(:,:,:), pointer :: table_tmp + call c_f_pointer (cptr, table_tmp, (/2,1,2/)) + if (any(table_tmp /= table)) STOP 1 + end subroutine set_table +end program main diff --git a/Fortran/gfortran/regression/c_f_pointer_tests_5.f90 b/Fortran/gfortran/regression/c_f_pointer_tests_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_f_pointer_tests_5.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! +! PR 54667: [OOP] gimplification failure with c_f_pointer +! +! Contributed by Andrew Benson + +use, intrinsic :: ISO_C_Binding +type :: nc +end type +type(c_ptr) :: cSelf +class(nc), pointer :: self +call c_f_pointer(cSelf, self) ! { dg-error "shall not be polymorphic" } +end diff --git a/Fortran/gfortran/regression/c_f_pointer_tests_6.f90 b/Fortran/gfortran/regression/c_f_pointer_tests_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_f_pointer_tests_6.f90 @@ -0,0 +1,43 @@ +! { dg-do compile } +! +! PR fortran/38894 +! +! + +subroutine test2 +use iso_c_binding +type(c_funptr) :: fun +type(c_ptr) :: fptr +procedure(), pointer :: bar +integer, pointer :: bari +call c_f_procpointer(fptr,bar) ! { dg-error "Argument CPTR at .1. to C_F_PROCPOINTER shall have the type TYPE.C_FUNPTR." } +call c_f_pointer(fun,bari) ! { dg-error "Argument CPTR at .1. to C_F_POINTER shall have the type TYPE.C_PTR." } +fun = fptr ! { dg-error "Cannot convert TYPE.c_ptr. to TYPE.c_funptr." } +end + +subroutine test() +use iso_c_binding, c_ptr2 => c_ptr +type(c_ptr2) :: fun +procedure(), pointer :: bar +integer, pointer :: foo +call c_f_procpointer(fun,bar) ! { dg-error "Argument CPTR at .1. to C_F_PROCPOINTER shall have the type TYPE.C_FUNPTR." } +call c_f_pointer(fun,foo) ! OK +end + +module rename + use, intrinsic :: iso_c_binding, only: my_c_ptr_0 => c_ptr +end module rename + +program p + use, intrinsic :: iso_c_binding, my_c_ptr => c_ptr + type(my_c_ptr) :: my_ptr + print *,c_associated(my_ptr) +contains + subroutine sub() + use rename ! (***) + type(my_c_ptr_0) :: my_ptr2 + type(c_funptr) :: myfun + print *,c_associated(my_ptr,my_ptr2) + print *,c_associated(my_ptr,myfun) ! { dg-error "Argument C_PTR_2 at .1. to C_ASSOCIATED shall have the same type as C_PTR_1: TYPE.c_ptr. instead of TYPE.c_funptr." } + end subroutine +end diff --git a/Fortran/gfortran/regression/c_f_pointer_tests_7.f90 b/Fortran/gfortran/regression/c_f_pointer_tests_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_f_pointer_tests_7.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! +! PR fortran/54263 +! +use iso_c_binding +type(c_ptr) :: cp +integer, pointer :: p +call c_f_pointer (cp, p, shape=[2]) ! { dg-error "Unexpected SHAPE argument at .1. to C_F_POINTER with scalar FPTR" } +end diff --git a/Fortran/gfortran/regression/c_f_pointer_tests_8.f90 b/Fortran/gfortran/regression/c_f_pointer_tests_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_f_pointer_tests_8.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/57834 +! +! (Gave a bogus warning before.) +! +program main + + use iso_c_binding + use iso_fortran_env + + implicit none + + interface + function strerror(errno) bind(C, NAME = 'strerror') + import + type(C_PTR) :: strerror + integer(C_INT), value :: errno + end function + end interface + + integer :: i + type(C_PTR) :: cptr + character(KIND=C_CHAR), pointer :: str(:) + + cptr = strerror(INT(42, KIND = C_INT)) + call C_F_POINTER(cptr, str, [255]) + + do i = 1, SIZE(str) + if (str(i) == C_NULL_CHAR) exit + write (ERROR_UNIT, '(A1)', ADVANCE = 'NO') str(i:i) + enddo + + write (ERROR_UNIT, '(1X)') + +end program main diff --git a/Fortran/gfortran/regression/c_f_tests_driver.c b/Fortran/gfortran/regression/c_f_tests_driver.c --- /dev/null +++ b/Fortran/gfortran/regression/c_f_tests_driver.c @@ -0,0 +1,66 @@ +extern void abort(void); + +typedef struct myCDerived +{ + int cInt; + double cDouble; + float cFloat; + short cShort; + void *ptr; +}myCDerived_t; + +#define DERIVED_ARRAY_LEN 10 +#define ARRAY_LEN_2 3 +#define DIM1 2 +#define DIM2 3 + +void testDerivedPtrs(myCDerived_t *cDerivedPtr, + myCDerived_t *derivedArray, int arrayLen, + myCDerived_t *derived2d, int dim1, int dim2); + +int main(int argc, char **argv) +{ + myCDerived_t cDerived; + myCDerived_t derivedArray[DERIVED_ARRAY_LEN]; + myCDerived_t derived2DArray[DIM1][DIM2]; + int i = 0; + int j = 0; + + cDerived.cInt = 1; + cDerived.cDouble = 2.0; + cDerived.cFloat = 3.0; + cDerived.cShort = 4; +/* cDerived.ptr = NULL; */ + /* nullify the ptr */ + cDerived.ptr = 0; + + for(i = 0; i < DERIVED_ARRAY_LEN; i++) + { + derivedArray[i].cInt = (i+1) * 1; + derivedArray[i].cDouble = (i+1) * 1.0; /* 2.0; */ + derivedArray[i].cFloat = (i+1) * 1.0; /* 3.0; */ + derivedArray[i].cShort = (i+1) * 1; /* 4; */ +/* derivedArray[i].ptr = NULL; */ + derivedArray[i].ptr = 0; + } + + for(i = 0; i < DIM1; i++) + { + for(j = 0; j < DIM2; j++) + { + derived2DArray[i][j].cInt = ((i*DIM1) * 1) + j; + derived2DArray[i][j].cDouble = ((i*DIM1) * 1.0) + j; + derived2DArray[i][j].cFloat = ((i*DIM1) * 1.0) + j; + derived2DArray[i][j].cShort = ((i*DIM1) * 1) + j; +/* derived2DArray[i][j].ptr = NULL; */ + derived2DArray[i][j].ptr = 0; + } + } + + /* send in the transpose size (dim2 is dim1, dim1 is dim2) */ + testDerivedPtrs(&cDerived, derivedArray, DERIVED_ARRAY_LEN, + derived2DArray[0], DIM2, DIM1); + + return 0; +}/* end main() */ + diff --git a/Fortran/gfortran/regression/c_funloc_tests.f03 b/Fortran/gfortran/regression/c_funloc_tests.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_funloc_tests.f03 @@ -0,0 +1,19 @@ +! { dg-do run } +! This test case simply checks that c_funloc exists, accepts arguments of +! flavor FL_PROCEDURE, and returns the type c_funptr +module c_funloc_tests + use, intrinsic :: iso_c_binding, only: c_funptr, c_funloc + +contains + recursive subroutine sub0() bind(c) + type(c_funptr) :: my_c_funptr + + my_c_funptr = c_funloc(sub0) + end subroutine sub0 +end module c_funloc_tests + +program driver + use c_funloc_tests + + call sub0() +end program driver diff --git a/Fortran/gfortran/regression/c_funloc_tests_2.f03 b/Fortran/gfortran/regression/c_funloc_tests_2.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_funloc_tests_2.f03 @@ -0,0 +1,16 @@ +! { dg-do compile } +module c_funloc_tests_2 + use, intrinsic :: iso_c_binding, only: c_funptr, c_funloc + implicit none + +contains + recursive subroutine sub0() bind(c) + type(c_funptr) :: my_c_funptr + integer :: my_local_variable + + my_c_funptr = c_funloc() ! { dg-error "Missing actual argument 'x' in call to 'c_funloc'" } + my_c_funptr = c_funloc(sub0) + my_c_funptr = c_funloc(sub0, sub0) ! { dg-error "Too many arguments in call to 'c_funloc'" } + my_c_funptr = c_funloc(my_local_variable) ! { dg-error "Argument X at .1. to C_FUNLOC shall be a procedure or a procedure pointer" } + end subroutine sub0 +end module c_funloc_tests_2 diff --git a/Fortran/gfortran/regression/c_funloc_tests_3.f03 b/Fortran/gfortran/regression/c_funloc_tests_3.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_funloc_tests_3.f03 @@ -0,0 +1,35 @@ +! { dg-do run } +! { dg-additional-sources c_funloc_tests_3_funcs.c } +! This testcase tests c_funloc and c_funptr from iso_c_binding. It uses +! functions defined in c_funloc_tests_3_funcs.c. +module c_funloc_tests_3 + implicit none +contains + function ffunc(j) bind(c) + use iso_c_binding, only: c_funptr, c_int + integer(c_int) :: ffunc + integer(c_int), value :: j + ffunc = -17_c_int*j + end function ffunc +end module c_funloc_tests_3 +program main + use iso_c_binding, only: c_funptr, c_funloc, c_int + use c_funloc_tests_3, only: ffunc + implicit none + interface + function returnFunc() bind(c,name="returnFunc") + use iso_c_binding, only: c_funptr + type(c_funptr) :: returnFunc + end function returnFunc + subroutine callFunc(func,pass,compare) bind(c,name="callFunc") + use iso_c_binding, only: c_funptr, c_int + type(c_funptr), value :: func + integer(c_int), value :: pass,compare + end subroutine callFunc + end interface + type(c_funptr) :: p + p = returnFunc() + call callFunc(p, 13_c_int, 3_c_int*13_c_int) + p = c_funloc(ffunc) + call callFunc(p, 21_c_int, -17_c_int*21_c_int) +end program main diff --git a/Fortran/gfortran/regression/c_funloc_tests_3_funcs.c b/Fortran/gfortran/regression/c_funloc_tests_3_funcs.c --- /dev/null +++ b/Fortran/gfortran/regression/c_funloc_tests_3_funcs.c @@ -0,0 +1,25 @@ +/* These functions support the test case c_funloc_tests_3. */ +#include +#include + +int printIntC(int i) +{ + return 3*i; +} + +int (*returnFunc(void))(int) +{ + return &printIntC; +} + +void callFunc(int(*func)(int), int pass, int compare) +{ + int result = (*func)(pass); + if(result != compare) + { + printf("FAILED: Got %d, expected %d\n", result, compare); + abort(); + } + else + printf("SUCCESS: Got %d, expected %d\n", result, compare); +} diff --git a/Fortran/gfortran/regression/c_funloc_tests_4.f03 b/Fortran/gfortran/regression/c_funloc_tests_4.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_funloc_tests_4.f03 @@ -0,0 +1,38 @@ +! { dg-do run } +! { dg-additional-sources c_funloc_tests_4_driver.c } +! Test that the inlined c_funloc works. +module c_funloc_tests_4 + use, intrinsic :: iso_c_binding, only: c_funloc, c_funptr + interface + subroutine c_sub0(fsub_ptr) bind(c) + use, intrinsic :: iso_c_binding, only: c_funptr + type(c_funptr), value :: fsub_ptr + end subroutine c_sub0 + subroutine c_sub1(ffunc_ptr) bind(c) + use, intrinsic :: iso_c_binding, only: c_funptr + type(c_funptr), value :: ffunc_ptr + end subroutine c_sub1 + end interface +contains + subroutine sub0() bind(c) + type(c_funptr) :: my_c_funptr + + my_c_funptr = c_funloc(sub1) + call c_sub0(my_c_funptr) + + my_c_funptr = c_funloc(func0) + call c_sub1(my_c_funptr) + end subroutine sub0 + + subroutine sub1() bind(c) + print *, 'hello from sub1' + end subroutine sub1 + + function func0(desired_retval) bind(c) + use, intrinsic :: iso_c_binding, only: c_int + integer(c_int), value :: desired_retval + integer(c_int) :: func0 + print *, 'hello from func0' + func0 = desired_retval + end function func0 +end module c_funloc_tests_4 diff --git a/Fortran/gfortran/regression/c_funloc_tests_4_driver.c b/Fortran/gfortran/regression/c_funloc_tests_4_driver.c --- /dev/null +++ b/Fortran/gfortran/regression/c_funloc_tests_4_driver.c @@ -0,0 +1,39 @@ +#include + +void sub0(void); +void c_sub0(void (*sub)(void)); +void c_sub1(int (*func)(int)); + +extern void abort(void); + +int main(int argc, char **argv) +{ + printf("hello from C main\n"); + + sub0(); + return 0; +} + +void c_sub0(void (*sub)(void)) +{ + printf("hello from c_sub0\n"); + sub(); + + return; +} + +void c_sub1(int (*func)(int)) +{ + int retval; + + printf("hello from c_sub1\n"); + + retval = func(10); + if(retval != 10) + { + fprintf(stderr, "Fortran function did not return expected value!\n"); + abort(); + } + + return; +} diff --git a/Fortran/gfortran/regression/c_funloc_tests_5.f03 b/Fortran/gfortran/regression/c_funloc_tests_5.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_funloc_tests_5.f03 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! Test that the arg checking for c_funloc verifies the procedures are +! C interoperable. +module c_funloc_tests_5 + use, intrinsic :: iso_c_binding, only: c_funloc, c_funptr +contains + subroutine sub0() bind(c) + type(c_funptr) :: my_c_funptr + + my_c_funptr = c_funloc(sub1) ! { dg-error "Fortran 2018: Noninteroperable procedure at .1. to C_FUNLOC" } + + my_c_funptr = c_funloc(func0) ! { dg-error "Fortran 2018: Noninteroperable procedure at .1. to C_FUNLOC" } + end subroutine sub0 + + subroutine sub1() + end subroutine sub1 + + function func0(desired_retval) + use, intrinsic :: iso_c_binding, only: c_int + integer(c_int), value :: desired_retval + integer(c_int) :: func0 + func0 = desired_retval + end function func0 +end module c_funloc_tests_5 + + diff --git a/Fortran/gfortran/regression/c_funloc_tests_6.f90 b/Fortran/gfortran/regression/c_funloc_tests_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_funloc_tests_6.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +! Check relaxed TS29113 constraints for procedures +! and c_f_*pointer argument checking for c_ptr/c_funptr. +! + +use iso_c_binding +implicit none +type(c_ptr) :: cp +type(c_funptr) :: cfp + +interface + subroutine sub() bind(C) + end subroutine sub +end interface +integer(c_int), pointer :: int +procedure(sub), pointer :: fsub + +integer, external :: noCsub +procedure(integer), pointer :: fint + +cp = c_funloc (sub) ! { dg-error "Cannot convert TYPE.c_funptr. to TYPE.c_ptr." }) +cfp = c_loc (int) ! { dg-error "Cannot convert TYPE.c_ptr. to TYPE.c_funptr." } + +call c_f_pointer (cfp, int) ! { dg-error "Argument CPTR at .1. to C_F_POINTER shall have the type TYPE.C_PTR." } +call c_f_procpointer (cp, fsub) ! { dg-error "Argument CPTR at .1. to C_F_PROCPOINTER shall have the type TYPE.C_FUNPTR." } + +cfp = c_funloc (noCsub) ! { dg-error "Fortran 2018: Noninteroperable procedure at .1. to C_FUNLOC" } +call c_f_procpointer (cfp, fint) ! { dg-error "Fortran 2018: Noninteroperable procedure pointer at .1. to C_F_PROCPOINTER" } +end diff --git a/Fortran/gfortran/regression/c_funloc_tests_7.f90 b/Fortran/gfortran/regression/c_funloc_tests_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_funloc_tests_7.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-std=f2008ts -fdump-tree-original" } +! +! Check relaxed TS29113 constraints for procedures +! and c_f_*pointer argument checking for c_ptr/c_funptr. +! + +use iso_c_binding +implicit none +type(c_funptr) :: cfp + +integer, external :: noCsub +procedure(integer), pointer :: fint + +cfp = c_funloc (noCsub) +call c_f_procpointer (cfp, fint) +end + +! { dg-final { scan-tree-dump-times "cfp =\[^;\]+ nocsub;" 1 "original" } } +! { dg-final { scan-tree-dump-times "fint =\[^;\]+ cfp;" 1 "original" } } + diff --git a/Fortran/gfortran/regression/c_funloc_tests_8.f90 b/Fortran/gfortran/regression/c_funloc_tests_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_funloc_tests_8.f90 @@ -0,0 +1,49 @@ +! { dg-do compile } +! +! PR fortran/50612 +! PR fortran/47023 +! +subroutine test + use iso_c_binding + implicit none + external foo + procedure(), pointer :: pp + print *, c_sizeof(pp) ! { dg-error "Procedure unexpected as argument" } + print *, c_sizeof(foo) ! { dg-error "Procedure unexpected as argument" } + print *, c_sizeof(bar) ! { dg-error "Procedure unexpected as argument" } +contains + subroutine bar() + end subroutine bar +end + +integer function foo2() + procedure(), pointer :: ptr + ptr => foo2 ! { dg-error "Function result 'foo2' is invalid as proc-target in procedure pointer assignment" } + foo2 = 7 + block + ptr => foo2 ! { dg-error "Function result 'foo2' is invalid as proc-target in procedure pointer assignment" } + end block +contains + subroutine foo() + ptr => foo2 ! { dg-error "Function result 'foo2' is invalid as proc-target in procedure pointer assignment" } + end subroutine foo +end function foo2 + +module m2 +contains +integer function foo(i, fptr) bind(C) + use iso_c_binding + implicit none + integer :: i + type(c_funptr) :: fptr + fptr = c_funloc(foo) ! { dg-error "Function result 'foo' at .1. is invalid as X argument to C_FUNLOC" } + block + fptr = c_funloc(foo) ! { dg-error "Function result 'foo' at .1. is invalid as X argument to C_FUNLOC" } + end block + foo = 42*i +contains + subroutine bar() + fptr = c_funloc(foo) ! { dg-error "Function result 'foo' at .1. is invalid as X argument to C_FUNLOC" } + end subroutine bar +end function foo +end module m2 diff --git a/Fortran/gfortran/regression/c_funptr_1.f90 b/Fortran/gfortran/regression/c_funptr_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_funptr_1.f90 @@ -0,0 +1,38 @@ +! { dg-do preprocess } +! { dg-additional-options "-cpp" } +! PR 57048 - this used not to compile. Original test case by Angelo +! Graziosi. Only works if compiled c_funptr_1_mod.f90, hence the +! do-nothing directive above. +module procs + + implicit none + private + + public WndProc + +contains + function WndProc() + integer :: WndProc + + WndProc = 0 + end function WndProc +end module procs + +function WinMain() + use, intrinsic :: iso_c_binding, only: C_INT,c_sizeof,c_funloc + use win32_types + use procs + implicit none + + integer :: WinMain + + type(WNDCLASSEX_T) :: WndClass + + WndClass%cbSize = int(c_sizeof(Wndclass),C_INT) + WndClass%lpfnWndProc = c_funloc(WndProc) + + WinMain = 0 +end function WinMain + +program main +end diff --git a/Fortran/gfortran/regression/c_funptr_1_mod.f90 b/Fortran/gfortran/regression/c_funptr_1_mod.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_funptr_1_mod.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-additional-sources c_funptr_1.f90 } +! Additional module to go with c_funptr_1.f90 +module win32_types + use, intrinsic :: iso_c_binding, only: C_INT,C_FUNPTR + implicit none + private + + public WNDCLASSEX_T + type, bind(C) :: WNDCLASSEX_T + integer(C_INT) :: cbSize + type(C_FUNPTR) :: lpfnWndProc + + end type WNDCLASSEX_T + +end module win32_types diff --git a/Fortran/gfortran/regression/c_kind_int128_test1.f03 b/Fortran/gfortran/regression/c_kind_int128_test1.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_kind_int128_test1.f03 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! { dg-require-effective-target fortran_integer_16 } +! + +subroutine c_kind_int128_1 + use, intrinsic :: iso_c_binding + implicit none + + integer(c_int128_t) :: a ! { dg-error "has no IMPLICIT type" } + integer(c_int_least128_t) :: b ! { dg-error "has no IMPLICIT type" } + integer(c_int_fast128_t) :: c ! { dg-error "has no IMPLICIT type" } + +end subroutine c_kind_int128_1 + + +subroutine c_kind_int128_2 + use, intrinsic :: iso_c_binding + + integer(c_int128_t) :: a ! { dg-error "has not been declared or is a variable" } + integer(c_int_least128_t) :: b ! { dg-error "has not been declared or is a variable" } + integer(c_int_fast128_t) :: c ! { dg-error "has not been declared or is a variable" } + +end subroutine c_kind_int128_2 diff --git a/Fortran/gfortran/regression/c_kind_int128_test2.f03 b/Fortran/gfortran/regression/c_kind_int128_test2.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_kind_int128_test2.f03 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-std=gnu" } +! { dg-require-effective-target fortran_integer_16 } +! +! Note: int_fast128_t currently not supported. + +program c_kind_int128 + use, intrinsic :: iso_c_binding + integer(c_int128_t) :: a + integer(c_int_least128_t) :: b +! integer(c_int_fast128_t) :: c + + if (sizeof (a) /= 16) STOP 1 + if (sizeof (b) /= 16) STOP 2 +! if (sizeof (c) /= 16) STOP 3 +end program c_kind_int128 diff --git a/Fortran/gfortran/regression/c_kind_params.f90 b/Fortran/gfortran/regression/c_kind_params.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_kind_params.f90 @@ -0,0 +1,76 @@ +! { dg-do run } +! { dg-require-effective-target stdint_types } +! { dg-additional-sources c_kinds.c } +! { dg-options "-w -std=c99" } +! the -w option is needed to make f951 not report a warning for +! the -std=c99 option that the C file needs. +! +module c_kind_params + use, intrinsic :: iso_c_binding + implicit none + +contains + subroutine param_test(my_short, my_int, my_long, my_long_long, & + my_int8_t, my_int_least8_t, my_int_fast8_t, & + my_int16_t, my_int_least16_t, my_int_fast16_t, & + my_int32_t, my_int_least32_t, my_int_fast32_t, & + my_int64_t, my_int_least64_t, my_int_fast64_t, & + my_intmax_t, my_intptr_t, my_float, my_double, my_long_double, & + my_char, my_bool) bind(c) + integer(c_short), value :: my_short + integer(c_int), value :: my_int + integer(c_long), value :: my_long + integer(c_long_long), value :: my_long_long + integer(c_int8_t), value :: my_int8_t + integer(c_int_least8_t), value :: my_int_least8_t + integer(c_int_fast8_t), value :: my_int_fast8_t + integer(c_int16_t), value :: my_int16_t + integer(c_int_least16_t), value :: my_int_least16_t + integer(c_int_fast16_t), value :: my_int_fast16_t + integer(c_int32_t), value :: my_int32_t + integer(c_int_least32_t), value :: my_int_least32_t + integer(c_int_fast32_t), value :: my_int_fast32_t + integer(c_int64_t), value :: my_int64_t + integer(c_int_least64_t), value :: my_int_least64_t + integer(c_int_fast64_t), value :: my_int_fast64_t + integer(c_intmax_t), value :: my_intmax_t + integer(c_intptr_t), value :: my_intptr_t + real(c_float), value :: my_float + real(c_double), value :: my_double + real(c_long_double), value :: my_long_double + character(c_char), value :: my_char + logical(c_bool), value :: my_bool + + if(my_short /= 1_c_short) STOP 1 + if(my_int /= 2_c_int) STOP 2 + if(my_long /= 3_c_long) STOP 3 + if(my_long_long /= 4_c_long_long) STOP 4 + + if(my_int8_t /= 1_c_int8_t) STOP 5 + if(my_int_least8_t /= 2_c_int_least8_t ) STOP 6 + if(my_int_fast8_t /= 3_c_int_fast8_t ) STOP 7 + + if(my_int16_t /= 1_c_int16_t) STOP 8 + if(my_int_least16_t /= 2_c_int_least16_t) STOP 9 + if(my_int_fast16_t /= 3_c_int_fast16_t ) STOP 10 + + if(my_int32_t /= 1_c_int32_t) STOP 11 + if(my_int_least32_t /= 2_c_int_least32_t) STOP 12 + if(my_int_fast32_t /= 3_c_int_fast32_t ) STOP 13 + + if(my_int64_t /= 1_c_int64_t) STOP 14 + if(my_int_least64_t /= 2_c_int_least64_t) STOP 15 + if(my_int_fast64_t /= 3_c_int_fast64_t ) STOP 16 + + if(my_intmax_t /= 1_c_intmax_t) STOP 17 + if(my_intptr_t /= 0_c_intptr_t) STOP 18 + + if(my_float /= 1.0_c_float) STOP 19 + if(my_double /= 2.0_c_double) STOP 20 + if(my_long_double /= 3.0_c_long_double) STOP 21 + + if(my_char /= c_char_'y') STOP 22 + if(my_bool .neqv. .true._c_bool) STOP 23 + end subroutine param_test + +end module c_kind_params diff --git a/Fortran/gfortran/regression/c_kind_tests_2.f03 b/Fortran/gfortran/regression/c_kind_tests_2.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_kind_tests_2.f03 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-Wc-binding-type" } +module c_kind_tests_2 + use, intrinsic :: iso_c_binding + + integer, parameter :: myF = c_float + real(myF), bind(c) :: myCFloat + integer(myF), bind(c) :: myCInt ! { dg-warning "is for type REAL" } + integer(c_double), bind(c) :: myCInt2 ! { dg-warning "is for type REAL" } + + integer, parameter :: myI = c_int + real(myI) :: myReal ! { dg-warning "is for type INTEGER" } + real(myI), bind(c) :: myCFloat2 ! { dg-warning "is for type INTEGER" } + real(4), bind(c) :: myFloat ! { dg-warning "may not be a C interoperable" } +end module c_kind_tests_2 diff --git a/Fortran/gfortran/regression/c_kind_tests_3.f03 b/Fortran/gfortran/regression/c_kind_tests_3.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_kind_tests_3.f03 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! PR 47023: [4.6/4.7 regression] C_Sizeof: Rejects valid code +! +! Contributed by + + use iso_c_binding + real(c_double) x + print *, c_sizeof(x) + print *, c_sizeof(0.0_c_double) +end diff --git a/Fortran/gfortran/regression/c_kinds.c b/Fortran/gfortran/regression/c_kinds.c --- /dev/null +++ b/Fortran/gfortran/regression/c_kinds.c @@ -0,0 +1,53 @@ +/* { dg-do compile } */ +/* { dg-options "-std=c99" } */ + +#include + +void param_test(short int my_short, int my_int, long int my_long, + long long int my_long_long, int8_t my_int8_t, + int_least8_t my_int_least8_t, int_fast8_t my_int_fast8_t, + int16_t my_int16_t, int_least16_t my_int_least16_t, + int_fast16_t my_int_fast16_t, int32_t my_int32_t, + int_least32_t my_int_least32_t, int_fast32_t my_int_fast32_t, + int64_t my_int64_t, int_least64_t my_int_least64_t, + int_fast64_t my_int_fast64_t, intmax_t my_intmax_t, + intptr_t my_intptr_t, float my_float, double my_double, + long double my_long_double, char my_char, _Bool my_bool); + + +int main(int argc, char **argv) +{ + short int my_short = 1; + int my_int = 2; + long int my_long = 3; + long long int my_long_long = 4; + int8_t my_int8_t = 1; + int_least8_t my_int_least8_t = 2; + int_fast8_t my_int_fast8_t = 3; + int16_t my_int16_t = 1; + int_least16_t my_int_least16_t = 2; + int_fast16_t my_int_fast16_t = 3; + int32_t my_int32_t = 1; + int_least32_t my_int_least32_t = 2; + int_fast32_t my_int_fast32_t = 3; + int64_t my_int64_t = 1; + int_least64_t my_int_least64_t = 2; + int_fast64_t my_int_fast64_t = 3; + intmax_t my_intmax_t = 1; + intptr_t my_intptr_t = 0; + float my_float = 1.0; + double my_double = 2.0; + long double my_long_double = 3.0; + char my_char = 'y'; + _Bool my_bool = 1; + + param_test(my_short, my_int, my_long, my_long_long, my_int8_t, + my_int_least8_t, my_int_fast8_t, my_int16_t, + my_int_least16_t, my_int_fast16_t, my_int32_t, + my_int_least32_t, my_int_fast32_t, my_int64_t, + my_int_least64_t, my_int_fast64_t, my_intmax_t, + my_intptr_t, my_float, my_double, my_long_double, my_char, + my_bool); + + return 0; +}/* end main() */ diff --git a/Fortran/gfortran/regression/c_loc_driver.c b/Fortran/gfortran/regression/c_loc_driver.c --- /dev/null +++ b/Fortran/gfortran/regression/c_loc_driver.c @@ -0,0 +1,17 @@ +/* in fortran module */ +void test0(void); + +extern void abort(void); + +int main(int argc, char **argv) +{ + test0(); + return 0; +}/* end main() */ + +void test_address(void *c_ptr, int expected_value) +{ + if((*(int *)(c_ptr)) != expected_value) + abort(); + return; +}/* end test_address() */ diff --git a/Fortran/gfortran/regression/c_loc_pure_1.f90 b/Fortran/gfortran/regression/c_loc_pure_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_loc_pure_1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-Wimplicit-interface" } +! PR 38220 - c_loc is pure and has an explicit interface +USE ISO_C_BINDING, ONLY: C_PTR, C_LOC +CONTAINS + PURE SUBROUTINE F(x) + INTEGER, INTENT(in), TARGET :: x + TYPE(C_PTR) :: px + px = C_LOC(x) + END SUBROUTINE +END diff --git a/Fortran/gfortran/regression/c_loc_test.f90 b/Fortran/gfortran/regression/c_loc_test.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_loc_test.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! { dg-additional-sources c_loc_driver.c } +module c_loc_test +implicit none + +contains + subroutine test0() bind(c) + use, intrinsic :: iso_c_binding + implicit none + integer(c_int), target :: x + type(c_ptr) :: my_c_ptr + interface + subroutine test_address(x, expected_value) bind(c) + use, intrinsic :: iso_c_binding + type(c_ptr), value :: x + integer(c_int), value :: expected_value + end subroutine test_address + end interface + x = 100_c_int + my_c_ptr = c_loc(x) + call test_address(my_c_ptr, 100_c_int) + end subroutine test0 +end module c_loc_test diff --git a/Fortran/gfortran/regression/c_loc_test_17.f90 b/Fortran/gfortran/regression/c_loc_test_17.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_loc_test_17.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-options "" } +! +! PR fortran/56378 +! PR fortran/52426 +! +! Contributed by David Sagan & Joost VandeVondele +! + +module t + use, intrinsic :: iso_c_binding + interface fvec2vec + module procedure int_fvec2vec + end interface +contains + function int_fvec2vec (f_vec, n) result (c_vec) + integer f_vec(:) + integer(c_int), target :: c_vec(n) + end function int_fvec2vec + subroutine lat_to_c (Fp, C) bind(c) + integer, allocatable :: ic(:) + call lat_to_c2 (c_loc(fvec2vec(ic, n1_ic))) ! { dg-error "Argument X at .1. to C_LOC shall have either the POINTER or the TARGET attribute" } + end subroutine lat_to_c +end module + +use iso_c_binding +print *, c_loc([1]) ! { dg-error "Argument X at .1. to C_LOC shall have either the POINTER or the TARGET attribute" } +end diff --git a/Fortran/gfortran/regression/c_loc_test_18.f90 b/Fortran/gfortran/regression/c_loc_test_18.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_loc_test_18.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! +! PR fortran/39288 +! +! From IR F03/0129, cf. +! Fortran 2003, Technical Corrigendum 5 +! +! Was invalid before. + + SUBROUTINE S(A,I,K) + USE ISO_C_BINDING + CHARACTER(*),TARGET :: A + CHARACTER(:),ALLOCATABLE,TARGET :: B + TYPE(C_PTR) P1,P2,P3,P4,P5 + P1 = C_LOC(A(1:1)) ! *1 + P2 = C_LOC(A(I:I)) ! *2 + P3 = C_LOC(A(1:)) ! *3 + P4 = C_LOC(A(I:K)) ! *4 + ALLOCATE(CHARACTER(1)::B) + P5 = C_LOC(B) ! *5 + END SUBROUTINE diff --git a/Fortran/gfortran/regression/c_loc_test_19.f90 b/Fortran/gfortran/regression/c_loc_test_19.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_loc_test_19.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/50269 +! +Program gf + Use iso_c_binding + Real( c_double ), Dimension( 1:10 ), Target :: a + Call test( a ) +Contains + Subroutine test( aa ) + Real( c_double ), Dimension( : ), Target :: aa + Type( c_ptr ), Pointer :: b + b = c_loc( aa( 1 ) ) ! was rejected before. + b = c_loc( aa ) ! { dg-error "Fortran 2008: Array of interoperable type at .1. to C_LOC which is nonallocatable and neither assumed size nor explicit size" } + End Subroutine test +End Program gf diff --git a/Fortran/gfortran/regression/c_loc_test_20.f90 b/Fortran/gfortran/regression/c_loc_test_20.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_loc_test_20.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! +! PR fortran/38829 +! PR fortran/40963 +! PR fortran/38813 +! +! +program testcloc + use, intrinsic :: iso_c_binding + implicit none + + type obj + real :: array(10,10) + real, allocatable :: array2(:,:) + end type + + type(obj), target :: obj1 + type(c_ptr) :: cptr + integer :: i + real, pointer :: array(:) + + allocate (obj1%array2(10,10)) + obj1%array = reshape ([(i, i=1,100)], shape (obj1%array)) + obj1%array2 = reshape ([(i, i=1,100)], shape (obj1%array)) + + cptr = c_loc (obj1%array) + call c_f_pointer (cptr, array, shape=[100]) + if (any (array /= [(i, i=1,100)])) STOP 1 + + cptr = c_loc (obj1%array2) + call c_f_pointer (cptr, array, shape=[100]) + if (any (array /= [(i, i=1,100)])) STOP 2 +end program testcloc + diff --git a/Fortran/gfortran/regression/c_loc_test_21.f90 b/Fortran/gfortran/regression/c_loc_test_21.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_loc_test_21.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } + +subroutine foo(a,b,c,d) + use iso_c_binding, only: c_loc, c_ptr + implicit none + real, intent(in), target :: a(:) + real, intent(in), target :: b(5) + real, intent(in), target :: c(*) + real, intent(in), target, allocatable :: d(:) + type(c_ptr) :: ptr + ptr = C_LOC(b) + ptr = C_LOC(c) + ptr = C_LOC(d) + ptr = C_LOC(a) ! { dg-error "Fortran 2008: Array of interoperable type at .1. to C_LOC which is nonallocatable and neither assumed size nor explicit size" } +end subroutine foo diff --git a/Fortran/gfortran/regression/c_loc_test_22.f90 b/Fortran/gfortran/regression/c_loc_test_22.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_loc_test_22.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-O0 -fdump-tree-original" } +! +! PR fortran/56907 +! +subroutine sub(xxx, yyy) + use iso_c_binding + implicit none + integer, target, contiguous :: xxx(:) + integer, target :: yyy(:) + type(c_ptr) :: ptr1, ptr2, ptr3, ptr4 + ptr1 = c_loc (xxx) + ptr2 = c_loc (xxx(5:)) + ptr3 = c_loc (yyy) + ptr4 = c_loc (yyy(5:)) +end +! { dg-final { scan-tree-dump-not " _gfortran_internal_pack" "original" } } +! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) &\\(.xxx.\[0-9\]+\\)\\\[0\\\];" 1 "original" } } +! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) &\\(.xxx.\[0-9\]+\\)\\\[D.\[0-9\]+ \\* 4\\\];" 1 "original" } } +! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) yyy.\[0-9\]+;" 1 "original" } } +! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) yyy.\[0-9\]+ \\+ \\(sizetype\\) \\(D.\[0-9\]+ \\* 16\\);" 1 "original" } } + +! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = parm.\[0-9\]+.data;\[^;]+ptr\[1-4\] = D.\[0-9\]+;" 4 "original" } } diff --git a/Fortran/gfortran/regression/c_loc_tests_10.f03 b/Fortran/gfortran/regression/c_loc_tests_10.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_loc_tests_10.f03 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +subroutine aaa(in) + use iso_c_binding + implicit none + integer(KIND=C_int), DIMENSION(:), TARGET :: in + type(c_ptr) :: cptr + cptr = c_loc(in) ! { dg-error "Fortran 2008: Array of interoperable type at .1. to C_LOC which is nonallocatable and neither assumed size nor explicit size" } +end subroutine aaa diff --git a/Fortran/gfortran/regression/c_loc_tests_11.f03 b/Fortran/gfortran/regression/c_loc_tests_11.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_loc_tests_11.f03 @@ -0,0 +1,51 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +! Test argument checking for C_LOC with subcomponent parameters. +module c_vhandle_mod + use iso_c_binding + + type double_vector_item + real(kind(1.d0)), allocatable :: v(:) + end type double_vector_item + type(double_vector_item), allocatable, target :: dbv_pool(:) + real(kind(1.d0)), allocatable, target :: vv(:) + + type foo + integer :: i + end type foo + type foo_item + type(foo), pointer :: v => null() + end type foo_item + type(foo_item), allocatable :: foo_pool(:) + + type foo_item2 + type(foo), pointer :: v(:) => null() + end type foo_item2 + type(foo_item2), allocatable :: foo_pool2(:) + + +contains + + type(c_ptr) function get_double_vector_address(handle) + integer(c_int), intent(in) :: handle + + if (.true.) then ! The ultimate component is an allocatable target + get_double_vector_address = c_loc(dbv_pool(handle)%v) ! OK: Interop type and allocatable + else + get_double_vector_address = c_loc(vv) ! OK: Interop type and allocatable + endif + + end function get_double_vector_address + + + type(c_ptr) function get_foo_address(handle) + integer(c_int), intent(in) :: handle + get_foo_address = c_loc(foo_pool(handle)%v) + + get_foo_address = c_loc(foo_pool2(handle)%v) ! { dg-error "Fortran 2018: Noninteroperable array at .1. as argument to C_LOC: Expression is a noninteroperable derived type" } + end function get_foo_address + + +end module c_vhandle_mod + diff --git a/Fortran/gfortran/regression/c_loc_tests_12.f03 b/Fortran/gfortran/regression/c_loc_tests_12.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_loc_tests_12.f03 @@ -0,0 +1,31 @@ +! { dg-do compile } +! +! Test for PR 35150, reduced testcases by Tobias Burnus +! +module test1 + use, intrinsic :: iso_c_binding + implicit none +contains + subroutine sub1(argv) bind(c,name="sub1") + type(c_ptr), intent(in) :: argv + end subroutine + + subroutine sub2 + type(c_ptr), dimension(1), target :: argv = c_null_ptr + character(c_char), dimension(1), target :: s = c_null_char + call sub1(c_loc(argv)) + end subroutine +end module test1 + +program test2 + use iso_c_binding + type(c_ptr), target, save :: argv + interface + subroutine sub1(argv) bind(c) + import + type(c_ptr), intent(in) :: argv + end subroutine sub1 + end interface + call sub1(c_loc(argv)) +end program test2 +! diff --git a/Fortran/gfortran/regression/c_loc_tests_13.f90 b/Fortran/gfortran/regression/c_loc_tests_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_loc_tests_13.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR fortran/38536 +! Consecutive array and substring references rejected as C_LOC argument +! +! contributed by Scot Breitenfield + + USE ISO_C_BINDING + TYPE test + CHARACTER(LEN=2), DIMENSION(1:2) :: c + END TYPE test + TYPE(test), TARGET :: chrScalar + TYPE(C_PTR) :: f_ptr + + f_ptr = C_LOC(chrScalar%c(1)(1:1)) + END diff --git a/Fortran/gfortran/regression/c_loc_tests_14.f90 b/Fortran/gfortran/regression/c_loc_tests_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_loc_tests_14.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! +! PR fortran/38536 +! Accept as argument to C_LOC a subcomponent accessed through a pointer. + + USE ISO_C_BINDING + + IMPLICIT NONE + TYPE test3 + INTEGER, DIMENSION(5) :: b + END TYPE test3 + + TYPE test2 + TYPE(test3), DIMENSION(:), POINTER :: a + END TYPE test2 + + TYPE test + TYPE(test2), DIMENSION(2) :: c + END TYPE test + + TYPE(test) :: chrScalar + TYPE(C_PTR) :: f_ptr + TYPE(test3), TARGET :: d(3) + + + chrScalar%c(1)%a => d + f_ptr = C_LOC(chrScalar%c(1)%a(1)%b(1)) + end + diff --git a/Fortran/gfortran/regression/c_loc_tests_15.f90 b/Fortran/gfortran/regression/c_loc_tests_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_loc_tests_15.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR 44925: [OOP] C_LOC with CLASS pointer +! +! Contributed by Barron Bichon + + use iso_c_binding + + type :: t + end type t + + type(c_ptr) :: tt_cptr + class(t), pointer :: tt_fptr + if (associated(tt_fptr)) tt_cptr = c_loc(tt_fptr) ! { dg-error "shall not be polymorphic" } + +end diff --git a/Fortran/gfortran/regression/c_loc_tests_16.f90 b/Fortran/gfortran/regression/c_loc_tests_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_loc_tests_16.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single -std=f2008" } +! PR 38536 - array sections as arguments to c_loc are illegal. + use iso_c_binding + type, bind(c) :: t1 + integer(c_int) :: i(5) + end type t1 + type, bind(c):: t2 + type(t1) :: t(5) + end type t2 + type, bind(c) :: t3 + type(t1) :: t(5,5) + end type t3 + + type(t2), target :: tt + type(t3), target :: ttt + integer(c_int), target :: n(3) + integer(c_int), target :: x[*] + type(C_PTR) :: p + + p = c_loc(tt%t%i(1)) + p = c_loc(n(1:2)) ! OK: interop type + contiguous + p = c_loc(ttt%t(5,1:2)%i(1)) ! FIXME: Noncontiguous (invalid) - compile-time testable + p = c_loc(x[1]) ! { dg-error "shall not be coindexed" } + end diff --git a/Fortran/gfortran/regression/c_loc_tests_17.f90 b/Fortran/gfortran/regression/c_loc_tests_17.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_loc_tests_17.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! PR fortran/55574 +! The following code used to be accepted because C_LOC pulls in C_PTR +! implicitly. +! +! Contributed by Valery Weber +! +program aaaa + use iso_c_binding, only : c_loc + integer, target :: i + type(C_PTR) :: f_ptr ! { dg-error "being used before it is defined" } + f_ptr=c_loc(i) ! { dg-error "Cannot convert" } +end program aaaa diff --git a/Fortran/gfortran/regression/c_loc_tests_2.f03 b/Fortran/gfortran/regression/c_loc_tests_2.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_loc_tests_2.f03 @@ -0,0 +1,87 @@ +! { dg-do run } +! { dg-additional-sources c_loc_tests_2_funcs.c } +module c_loc_tests_2 +use, intrinsic :: iso_c_binding +implicit none + +interface + function test_scalar_address(cptr) bind(c) + use, intrinsic :: iso_c_binding, only: c_ptr, c_int + type(c_ptr), value :: cptr + integer(c_int) :: test_scalar_address + end function test_scalar_address + + function test_array_address(cptr, num_elements) bind(c) + use, intrinsic :: iso_c_binding, only: c_ptr, c_int + type(c_ptr), value :: cptr + integer(c_int), value :: num_elements + integer(c_int) :: test_array_address + end function test_array_address + + function test_type_address(cptr) bind(c) + use, intrinsic :: iso_c_binding, only: c_ptr, c_int + type(c_ptr), value :: cptr + integer(c_int) :: test_type_address + end function test_type_address +end interface + +contains + subroutine test0() bind(c) + integer, target :: xtar + integer, pointer :: xptr + type(c_ptr) :: my_c_ptr_1 = c_null_ptr + type(c_ptr) :: my_c_ptr_2 = c_null_ptr + xtar = 100 + xptr => xtar + my_c_ptr_1 = c_loc(xtar) + my_c_ptr_2 = c_loc(xptr) + if(test_scalar_address(my_c_ptr_1) .ne. 1) then + STOP 1 + end if + if(test_scalar_address(my_c_ptr_2) .ne. 1) then + STOP 2 + end if + end subroutine test0 + + subroutine test1() bind(c) + integer(c_int), target, dimension(100) :: int_array_tar + type(c_ptr) :: my_c_ptr_1 = c_null_ptr + type(c_ptr) :: my_c_ptr_2 = c_null_ptr + + int_array_tar = 100_c_int + my_c_ptr_1 = c_loc(int_array_tar) + if(test_array_address(my_c_ptr_1, 100_c_int) .ne. 1) then + STOP 3 + end if + end subroutine test1 + + subroutine test2() bind(c) + type, bind(c) :: f90type + integer(c_int) :: i + real(c_double) :: x + end type f90type + type(f90type), target :: type_tar + type(f90type), pointer :: type_ptr + type(c_ptr) :: my_c_ptr_1 = c_null_ptr + type(c_ptr) :: my_c_ptr_2 = c_null_ptr + + type_ptr => type_tar + type_tar%i = 100 + type_tar%x = 1.0d0 + my_c_ptr_1 = c_loc(type_tar) + my_c_ptr_2 = c_loc(type_ptr) + if(test_type_address(my_c_ptr_1) .ne. 1) then + STOP 4 + end if + if(test_type_address(my_c_ptr_2) .ne. 1) then + STOP 5 + end if + end subroutine test2 +end module c_loc_tests_2 + +program driver + use c_loc_tests_2 + call test0() + call test1() + call test2() +end program driver diff --git a/Fortran/gfortran/regression/c_loc_tests_2_funcs.c b/Fortran/gfortran/regression/c_loc_tests_2_funcs.c --- /dev/null +++ b/Fortran/gfortran/regression/c_loc_tests_2_funcs.c @@ -0,0 +1,42 @@ +double fabs (double); + +typedef struct ctype +{ + int i; + double x; +}ctype_t; + +int test_scalar_address(int *ptr) +{ + /* The value in Fortran should be initialized to 100. */ + if(*ptr != 100) + return 0; + else + return 1; +} + +int test_array_address(int *int_array, int num_elements) +{ + int i = 0; + + for(i = 0; i < num_elements; i++) + /* Fortran will init all of the elements to 100; verify that here. */ + if(int_array[i] != 100) + return 0; + + /* all elements were equal to 100 */ + return 1; +} + +int test_type_address(ctype_t *type_ptr) +{ + /* i was set to 100 by Fortran */ + if(type_ptr->i != 100) + return 0; + + /* x was set to 1.0d0 by Fortran */ + if(fabs(type_ptr->x - 1.0) > 0.00000000) + return 0; + + return 1; +} diff --git a/Fortran/gfortran/regression/c_loc_tests_3.f03 b/Fortran/gfortran/regression/c_loc_tests_3.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_loc_tests_3.f03 @@ -0,0 +1,8 @@ +! { dg-do compile } +use iso_c_binding +implicit none +character(kind=c_char,len=256),target :: arg +type(c_ptr),pointer :: c +c = c_loc(arg) ! OK since Fortran 2003, Tech Corrigenda 5; IR F03/0129 + +end diff --git a/Fortran/gfortran/regression/c_loc_tests_4.f03 b/Fortran/gfortran/regression/c_loc_tests_4.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_loc_tests_4.f03 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +module c_loc_tests_4 + use, intrinsic :: iso_c_binding + implicit none + +contains + subroutine sub0() bind(c) + integer(c_int), target, dimension(10) :: my_array + integer(c_int), pointer, dimension(:) :: my_array_ptr + type(c_ptr) :: my_c_ptr + + my_array_ptr => my_array + my_c_ptr = c_loc(my_array_ptr) ! { dg-error "Fortran 2008: Array of interoperable type at .1. to C_LOC which is nonallocatable and neither assumed size nor explicit size" } + end subroutine sub0 +end module c_loc_tests_4 diff --git a/Fortran/gfortran/regression/c_loc_tests_5.f03 b/Fortran/gfortran/regression/c_loc_tests_5.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_loc_tests_5.f03 @@ -0,0 +1,18 @@ +! { dg-do compile } +module c_loc_tests_5 + use, intrinsic :: iso_c_binding, only: c_char, c_ptr, c_loc, c_int + +contains + subroutine sub0() bind(c) + type(c_ptr) :: f_ptr, my_c_ptr + character(kind=c_char, len=20), target :: format + integer(c_int), dimension(:), pointer :: int_ptr + integer(c_int), dimension(10), target :: int_array + + f_ptr = c_loc(format(1:1)) + + int_ptr => int_array + my_c_ptr = c_loc(int_ptr(0)) + + end subroutine sub0 +end module c_loc_tests_5 diff --git a/Fortran/gfortran/regression/c_loc_tests_6.f03 b/Fortran/gfortran/regression/c_loc_tests_6.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_loc_tests_6.f03 @@ -0,0 +1,12 @@ +! { dg-do compile } +! Verifies that the c_loc scalar pointer tests recognize the string of length +! one as being allowable for the parameter to c_loc. +module x +use iso_c_binding +contains +SUBROUTINE glutInit_f03() + TYPE(C_PTR), DIMENSION(1), TARGET :: argv=C_NULL_PTR + CHARACTER(C_CHAR), DIMENSION(10), TARGET :: empty_string=C_NULL_CHAR + argv(1)=C_LOC(empty_string) +END SUBROUTINE +end module x diff --git a/Fortran/gfortran/regression/c_loc_tests_7.f03 b/Fortran/gfortran/regression/c_loc_tests_7.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_loc_tests_7.f03 @@ -0,0 +1,10 @@ +! { dg-do compile } +module c_loc_tests_7 +use iso_c_binding +contains +SUBROUTINE glutInit_f03() + TYPE(C_PTR), DIMENSION(1), TARGET :: argv=C_NULL_PTR + CHARACTER(C_CHAR), DIMENSION(1), TARGET :: empty_string=C_NULL_CHAR + argv(1)=C_LOC(empty_string) +END SUBROUTINE +end module c_loc_tests_7 diff --git a/Fortran/gfortran/regression/c_loc_tests_8.f03 b/Fortran/gfortran/regression/c_loc_tests_8.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_loc_tests_8.f03 @@ -0,0 +1,13 @@ +! { dg-do compile } +! Verifies that the c_loc scalar pointer tests recognize the string of length +! greater than one as not being allowable for the parameter to c_loc. +module x +use iso_c_binding +contains +SUBROUTINE glutInit_f03() + TYPE(C_PTR), DIMENSION(1), TARGET :: argv=C_NULL_PTR + character(kind=c_char, len=5), target :: string="hello" + argv(1)=C_LOC(string) ! OK since Fortran 2003, Tech Corrigenda 5; IR F03/0129 +END SUBROUTINE +end module x + diff --git a/Fortran/gfortran/regression/c_loc_tests_9.f03 b/Fortran/gfortran/regression/c_loc_tests_9.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_loc_tests_9.f03 @@ -0,0 +1,10 @@ +! { dg-do compile } +subroutine aaa(in) + use iso_c_binding + implicit none + CHARACTER(KIND=C_CHAR), DIMENSION(*), TARGET :: in + type(c_ptr) :: cptr + cptr = c_loc(in) +end subroutine aaa + + diff --git a/Fortran/gfortran/regression/c_ptr_tests.f03 b/Fortran/gfortran/regression/c_ptr_tests.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_ptr_tests.f03 @@ -0,0 +1,44 @@ +! { dg-do run } +! { dg-additional-sources c_ptr_tests_driver.c } +module c_ptr_tests + use, intrinsic :: iso_c_binding + + ! TODO:: + ! in order to be associated with a C address, + ! the derived type needs to be C interoperable, + ! which requires bind(c) and all fields interoperable. + type, bind(c) :: myType + type(c_ptr) :: myServices + type(c_funptr) :: mySetServices + type(c_ptr) :: myPort + end type myType + + type, bind(c) :: f90Services + integer(c_int) :: compId + type(c_ptr) :: globalServices = c_null_ptr + end type f90Services + + contains + + subroutine sub0(c_self, services) bind(c) + use, intrinsic :: iso_c_binding + implicit none + type(c_ptr), value :: c_self, services + type(myType), pointer :: self + type(f90Services), pointer :: localServices +! type(c_ptr) :: my_cptr + type(c_ptr), save :: my_cptr = c_null_ptr + + call c_f_pointer(c_self, self) + if(.not. associated(self)) then + print *, 'self is not associated' + end if + self%myServices = services + + ! c_null_ptr is defined in iso_c_binding + my_cptr = c_null_ptr + + ! get access to the local services obj from C + call c_f_pointer(self%myServices, localServices) + end subroutine sub0 +end module c_ptr_tests diff --git a/Fortran/gfortran/regression/c_ptr_tests_10.f03 b/Fortran/gfortran/regression/c_ptr_tests_10.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_ptr_tests_10.f03 @@ -0,0 +1,17 @@ +! { dg-do run } +! { dg-options "-std=gnu" } +! This test case exists because gfortran had an error in converting the +! expressions for the derived types from iso_c_binding in some cases. +module c_ptr_tests_10 + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr + +contains + subroutine sub0() bind(c) + print *, 'c_null_ptr is: ', c_null_ptr + end subroutine sub0 +end module c_ptr_tests_10 + +program main + use c_ptr_tests_10 + call sub0() +end program main diff --git a/Fortran/gfortran/regression/c_ptr_tests_11.f03 b/Fortran/gfortran/regression/c_ptr_tests_11.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_ptr_tests_11.f03 @@ -0,0 +1,40 @@ +! { dg-do compile } +! Verify that initialization of c_ptr components works. +module fgsl + use, intrinsic :: iso_c_binding + implicit none + type, public :: fgsl_matrix + private + type(c_ptr) :: gsl_matrix = c_null_ptr + end type fgsl_matrix + type, public :: fgsl_multifit_fdfsolver + private + type(c_ptr) :: gsl_multifit_fdfsolver = c_null_ptr + end type fgsl_multifit_fdfsolver +interface + function gsl_multifit_fdfsolver_jac(s) bind(c) + import :: c_ptr + type(c_ptr), value :: s + type(c_ptr) :: gsl_multifit_fdfsolver_jac + end function gsl_multifit_fdfsolver_jac +end interface +contains + function fgsl_multifit_fdfsolver_jac(s) + type(fgsl_multifit_fdfsolver), intent(in) :: s + type(fgsl_matrix) :: fgsl_multifit_fdfsolver_jac + fgsl_multifit_fdfsolver_jac%gsl_matrix = & + gsl_multifit_fdfsolver_jac(s%gsl_multifit_fdfsolver) + end function fgsl_multifit_fdfsolver_jac +end module fgsl + +module m + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr + implicit none + type t + type(c_ptr) :: matrix = c_null_ptr + end type t +contains + subroutine func(a) + type(t), intent(out) :: a + end subroutine func +end module m diff --git a/Fortran/gfortran/regression/c_ptr_tests_12.f03 b/Fortran/gfortran/regression/c_ptr_tests_12.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_ptr_tests_12.f03 @@ -0,0 +1,42 @@ +! { dg-do compile } +! Verify that initialization of c_ptr components works. This is based on +! code from fgsl: +! http://www.lrz-muenchen.de/services/software/mathematik/gsl/fortran/ +! and tests PR 33395. +module fgsl + use, intrinsic :: iso_c_binding + implicit none +! +! +! Kind and length parameters are default integer +! + integer, parameter, public :: fgsl_double = c_double + +! +! Types : Array support +! + type, public :: fgsl_vector + private + type(c_ptr) :: gsl_vector = c_null_ptr + end type fgsl_vector + +contains + function fgsl_vector_align(p_x, f_x) + real(fgsl_double), pointer :: p_x(:) + type(fgsl_vector) :: f_x + integer :: fgsl_vector_align + fgsl_vector_align = 4 + end function fgsl_vector_align +end module fgsl + +module tmod + use fgsl + implicit none +contains + subroutine expb_df() bind(c) + type(fgsl_vector) :: f_x + real(fgsl_double), pointer :: p_x(:) + integer :: status + status = fgsl_vector_align(p_x, f_x) + end subroutine expb_df +end module tmod diff --git a/Fortran/gfortran/regression/c_ptr_tests_13.f03 b/Fortran/gfortran/regression/c_ptr_tests_13.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_ptr_tests_13.f03 @@ -0,0 +1,15 @@ +! { dg-do compile } +! Ensure that the user cannot call the structure constructor for one of +! the iso_c_binding derived types. +! +! PR fortran/33760 +! +program main + use ISO_C_BINDING + implicit none + integer(C_INTPTR_T) p + type(C_PTR) cptr + p = 0 + cptr = C_PTR(p+1) ! { dg-error "is a PRIVATE component of 'c_ptr'" } + cptr = C_PTR(1) ! { dg-error "is a PRIVATE component of 'c_ptr'" } +end program main diff --git a/Fortran/gfortran/regression/c_ptr_tests_14.f90 b/Fortran/gfortran/regression/c_ptr_tests_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_ptr_tests_14.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/41298 +! +! Check that c_null_ptr default initializer is really applied + +module m + use iso_c_binding + type, public :: fgsl_file + type(c_ptr) :: gsl_file = c_null_ptr + type(c_funptr) :: gsl_func = c_null_funptr + type(c_ptr) :: NIptr + type(c_funptr) :: NIfunptr + end type fgsl_file +contains + subroutine sub(aaa,bbb) + type(fgsl_file), intent(out) :: aaa + type(fgsl_file), intent(inout) :: bbb + end subroutine + subroutine proc() bind(C) + end subroutine proc +end module m + +program test + use m + implicit none + type(fgsl_file) :: file, noreinit + integer, target :: tgt + + call sub(file, noreinit) + if(c_associated(file%gsl_file)) STOP 1 + if(c_associated(file%gsl_func)) STOP 2 + + file%gsl_file = c_loc(tgt) + file%gsl_func = c_funloc(proc) + call sub(file, noreinit) + if(c_associated(file%gsl_file)) STOP 3 + if(c_associated(file%gsl_func)) STOP 4 +end program test + +! { dg-final { scan-tree-dump-times "c_funptr.\[0-9\]+ = 0B;" 1 "original" } } +! { dg-final { scan-tree-dump-times "fgsl_file.\[0-9\]+.gsl_func = c_funptr.\[0-9\]+;" 1 "original" } } +! { dg-final { scan-tree-dump-times "c_ptr.\[0-9\]+ = 0B;" 1 "original" } } +! { dg-final { scan-tree-dump-times "fgsl_file.\[0-9\]+.gsl_file = c_ptr.\[0-9\]+;" 1 "original" } } + +! { dg-final { scan-tree-dump-times "NIptr = 0B" 0 "original" } } +! { dg-final { scan-tree-dump-times "NIfunptr = 0B" 0 "original" } } + +! { dg-final { scan-tree-dump-times "bbb =" 0 "original" } } + diff --git a/Fortran/gfortran/regression/c_ptr_tests_15.f90 b/Fortran/gfortran/regression/c_ptr_tests_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_ptr_tests_15.f90 @@ -0,0 +1,53 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/43042 - fix ICE with c_null_ptr when using +! -fwhole-file (or -flto, which implies -fwhole-file). +! +! Testcase based on c_ptr_tests_14.f90 (PR fortran/41298) +! Check that c_null_ptr default initializer is really applied + +module m + use iso_c_binding + type, public :: fgsl_file + type(c_ptr) :: gsl_file = c_null_ptr + type(c_funptr) :: gsl_func = c_null_funptr + type(c_ptr) :: NIptr + type(c_funptr) :: NIfunptr + end type fgsl_file +contains + subroutine sub(aaa,bbb) + type(fgsl_file), intent(out) :: aaa + type(fgsl_file), intent(inout) :: bbb + end subroutine + subroutine proc() bind(C) + end subroutine proc +end module m + +program test + use m + implicit none + type(fgsl_file) :: file, noreinit + integer, target :: tgt + + call sub(file, noreinit) + if(c_associated(file%gsl_file)) STOP 1 + if(c_associated(file%gsl_func)) STOP 2 + + file%gsl_file = c_loc(tgt) + file%gsl_func = c_funloc(proc) + call sub(file, noreinit) + if(c_associated(file%gsl_file)) STOP 3 + if(c_associated(file%gsl_func)) STOP 4 +end program test + +! { dg-final { scan-tree-dump-times "c_funptr.\[0-9\]+ = 0B;" 1 "original" } } +! { dg-final { scan-tree-dump-times "fgsl_file.\[0-9\]+.gsl_func = c_funptr.\[0-9\]+;" 1 "original" } } +! { dg-final { scan-tree-dump-times "c_ptr.\[0-9\]+ = 0B;" 1 "original" } } +! { dg-final { scan-tree-dump-times "fgsl_file.\[0-9\]+.gsl_file = c_ptr.\[0-9\]+;" 1 "original" } } + +! { dg-final { scan-tree-dump-times "NIptr = 0B" 0 "original" } } +! { dg-final { scan-tree-dump-times "NIfunptr = 0B" 0 "original" } } + +! { dg-final { scan-tree-dump-times "bbb =" 0 "original" } } + diff --git a/Fortran/gfortran/regression/c_ptr_tests_16.f90 b/Fortran/gfortran/regression/c_ptr_tests_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_ptr_tests_16.f90 @@ -0,0 +1,61 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-optimized -O" } +! +! PR fortran/46974 + +program test + use ISO_C_BINDING + implicit none + type(c_ptr) :: m + integer(c_intptr_t) :: a + integer(transfer(transfer(4_c_intptr_t, c_null_ptr),1_c_intptr_t)) :: b + a = transfer (transfer("ABCE", m), 1_c_intptr_t) + print '(z8)', a + if ( int(z'45434241') /= a & + .and. int(z'41424345') /= a & + .and. int(z'4142434500000000',kind=8) /= a) & + call i_do_not_exist() +end program test + +! Examples contributed by Steve Kargl and James Van Buskirk + +subroutine bug1 + use ISO_C_BINDING + implicit none + type(c_ptr) :: m + type mytype + integer a, b, c + end type mytype + type(mytype) x + print *, transfer(32512, x) ! Works. + print *, transfer(32512, m) ! Caused ICE. +end subroutine bug1 + +subroutine bug6 + use ISO_C_BINDING + implicit none + interface + function fun() + use ISO_C_BINDING + implicit none + type(C_FUNPTR) fun + end function fun + end interface + type(C_PTR) array(2) + type(C_FUNPTR) result + integer(C_INTPTR_T), parameter :: const(*) = [32512,32520] + + result = fun() + array = transfer([integer(C_INTPTR_T)::32512,32520],array) +! write(*,*) transfer(result,const) +! write(*,*) transfer(array,const) +end subroutine bug6 + +function fun() + use ISO_C_BINDING + implicit none + type(C_FUNPTR) fun + fun = transfer(32512_C_INTPTR_T,fun) +end function fun + +! { dg-final { scan-tree-dump-times "i_do_not_exist" 0 "optimized" } } diff --git a/Fortran/gfortran/regression/c_ptr_tests_17.f90 b/Fortran/gfortran/regression/c_ptr_tests_17.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_ptr_tests_17.f90 @@ -0,0 +1,86 @@ +! { dg-do compile } +! +! PR fortran/37829 +! +! Contributed by James Van Buskirk and Jerry DeLisle. +! +! Fix derived-type loading with ISO_BIND_C's C_PTR/C_FUNPTR. + +module m3 + use ISO_C_BINDING + implicit none + private + + public kill_C_PTR + interface + function kill_C_PTR() bind(C) + import + implicit none + type(C_PTR) kill_C_PTR + end function kill_C_PTR + end interface + + public kill_C_FUNPTR + interface + function kill_C_FUNPTR() bind(C) + import + implicit none + type(C_FUNPTR) kill_C_FUNPTR + end function kill_C_FUNPTR + end interface +end module m3 + +module m1 + use m3 +end module m1 + +program X + use m1 + use ISO_C_BINDING + implicit none + type(C_PTR) cp + type(C_FUNPTR) fp + integer(C_INT),target :: i + interface + function fun() bind(C) + use ISO_C_BINDING + implicit none + real(C_FLOAT) fun + end function fun + end interface + + cp = C_NULL_PTR + cp = C_LOC(i) + fp = C_NULL_FUNPTR + fp = C_FUNLOC(fun) +end program X + +function fun() bind(C) + use ISO_C_BINDING + implicit none + real(C_FLOAT) fun + fun = 1.0 +end function fun + +function kill_C_PTR() bind(C) + use ISO_C_BINDING + implicit none + type(C_PTR) kill_C_PTR + integer(C_INT), pointer :: p + allocate(p) + kill_C_PTR = C_LOC(p) +end function kill_C_PTR + +function kill_C_FUNPTR() bind(C) + use ISO_C_BINDING + implicit none + type(C_FUNPTR) kill_C_FUNPTR + interface + function fun() bind(C) + use ISO_C_BINDING + implicit none + real(C_FLOAT) fun + end function fun + end interface + kill_C_FUNPTR = C_FUNLOC(fun) +end function kill_C_FUNPTR diff --git a/Fortran/gfortran/regression/c_ptr_tests_18.f90 b/Fortran/gfortran/regression/c_ptr_tests_18.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_ptr_tests_18.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! +! PR fortran/37829 +! PR fortran/45190 +! +! Contributed by Mat Cross +! +! Fix derived-type loading with ISO_BIND_C's C_PTR/C_FUNPTR. + +MODULE NAG_J_TYPES + USE ISO_C_BINDING, ONLY : C_PTR + IMPLICIT NONE + TYPE :: NAG_IMAGE + INTEGER :: WIDTH, HEIGHT, PXFMT, NCHAN + TYPE (C_PTR) :: PIXELS + END TYPE NAG_IMAGE +END MODULE NAG_J_TYPES +program cfpointerstress + use nag_j_types + use iso_c_binding + implicit none + type(nag_image),pointer :: img + type(C_PTR) :: ptr + real, pointer :: r + allocate(r) + allocate(img) + r = 12 + ptr = c_loc(img) + write(*,*) 'C_ASSOCIATED =', C_ASSOCIATED(ptr) + call c_f_pointer(ptr, img) + write(*,*) 'ASSOCIATED =', associated(img) + deallocate(r) +end program cfpointerstress diff --git a/Fortran/gfortran/regression/c_ptr_tests_19.f90 b/Fortran/gfortran/regression/c_ptr_tests_19.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_ptr_tests_19.f90 @@ -0,0 +1,36 @@ +! { dg-do run } + +! PR 71544 - this failed with some optimization options due to a +! pointer not being marked as escaping. + +module store_cptr + use, intrinsic :: iso_c_binding + implicit none + public + type(c_ptr), save :: cptr +end module store_cptr + +subroutine init() + use, intrinsic :: iso_c_binding + implicit none + integer(c_int), pointer :: a + allocate(a) + call save_cptr(c_loc(a)) + a = 100 +end subroutine init + +subroutine save_cptr(cptr_in) + use store_cptr + implicit none + type(c_ptr), intent(in) :: cptr_in + cptr = cptr_in +end subroutine save_cptr + +program init_fails + use store_cptr + implicit none + integer(c_int), pointer :: val + call init() + call c_f_pointer(cptr,val) + if (val /= 100) stop 1 +end program init_fails diff --git a/Fortran/gfortran/regression/c_ptr_tests_5.f03 b/Fortran/gfortran/regression/c_ptr_tests_5.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_ptr_tests_5.f03 @@ -0,0 +1,16 @@ +! { dg-do compile } +module c_ptr_tests_5 +use, intrinsic :: iso_c_binding + +type, bind(c) :: my_f90_type + integer(c_int) :: i +end type my_f90_type + +contains + subroutine sub0(c_struct) bind(c) + type(c_ptr), value :: c_struct + type(my_f90_type) :: f90_type + + call c_f_pointer(c_struct, f90_type) ! { dg-error "must be a pointer" } + end subroutine sub0 +end module c_ptr_tests_5 diff --git a/Fortran/gfortran/regression/c_ptr_tests_7.f03 b/Fortran/gfortran/regression/c_ptr_tests_7.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_ptr_tests_7.f03 @@ -0,0 +1,11 @@ +! { dg-do run } +! { dg-additional-sources c_ptr_tests_7_driver.c } +module c_ptr_tests_7 + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr + +contains + function func0() bind(c) + type(c_ptr) :: func0 + func0 = c_null_ptr + end function func0 +end module c_ptr_tests_7 diff --git a/Fortran/gfortran/regression/c_ptr_tests_7_driver.c b/Fortran/gfortran/regression/c_ptr_tests_7_driver.c --- /dev/null +++ b/Fortran/gfortran/regression/c_ptr_tests_7_driver.c @@ -0,0 +1,14 @@ +/* This is the driver for c_ptr_test_7. */ +extern void abort(void); + +void *func0(); + +int main(int argc, char **argv) +{ + /* The Fortran module c_ptr_tests_7 contains function func0, which has + return type of c_ptr, and should set the return value to c_null_ptr. */ + if (func0() != 0) + abort(); + + return 0; +} diff --git a/Fortran/gfortran/regression/c_ptr_tests_8.f03 b/Fortran/gfortran/regression/c_ptr_tests_8.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_ptr_tests_8.f03 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-additional-sources c_ptr_tests_8_funcs.c } +program main +use iso_c_binding, only: c_ptr +implicit none +interface + function create() bind(c) + use iso_c_binding, only: c_ptr + type(c_ptr) :: create + end function create + subroutine show(a) bind(c) + import :: c_ptr + type(c_ptr), VALUE :: a + end subroutine show +end interface + +type(c_ptr) :: ptr +ptr = create() +call show(ptr) +end program main diff --git a/Fortran/gfortran/regression/c_ptr_tests_8_funcs.c b/Fortran/gfortran/regression/c_ptr_tests_8_funcs.c --- /dev/null +++ b/Fortran/gfortran/regression/c_ptr_tests_8_funcs.c @@ -0,0 +1,26 @@ +/* This file provides auxiliary functions for c_ptr_tests_8. */ + +#include +#include + +extern void abort (void); + +void *create (void) +{ + int *a; + a = malloc (sizeof (a)); + *a = 444; + return a; + +} + +void show (int *a) +{ + if (*a == 444) + printf ("SUCCESS (%d)\n", *a); + else + { + printf ("FAILED: Expected 444, received %d\n", *a); + abort (); + } +} diff --git a/Fortran/gfortran/regression/c_ptr_tests_9.f03 b/Fortran/gfortran/regression/c_ptr_tests_9.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_ptr_tests_9.f03 @@ -0,0 +1,30 @@ +! { dg-do run } +! { dg-options "-std=gnu" } +! This test is pretty simple but is here just to make sure that the changes +! done to c_ptr and c_funptr (translating them to void *) works in the case +! where a component of a type is of type c_ptr or c_funptr. +module c_ptr_tests_9 + use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr + + type myF90Derived + type(c_ptr) :: my_c_ptr + end type myF90Derived + +contains + subroutine sub0() bind(c) + type(myF90Derived), target :: my_f90_type + type(myF90Derived), pointer :: my_f90_type_ptr + + my_f90_type%my_c_ptr = c_null_ptr + print *, 'my_f90_type is: ', my_f90_type%my_c_ptr + my_f90_type_ptr => my_f90_type + print *, 'my_f90_type_ptr is: ', my_f90_type_ptr%my_c_ptr + end subroutine sub0 +end module c_ptr_tests_9 + + +program main + use c_ptr_tests_9 + + call sub0() +end program main diff --git a/Fortran/gfortran/regression/c_ptr_tests_driver.c b/Fortran/gfortran/regression/c_ptr_tests_driver.c --- /dev/null +++ b/Fortran/gfortran/regression/c_ptr_tests_driver.c @@ -0,0 +1,34 @@ +/* this is the driver for c_ptr_test.f03 */ + +typedef struct services +{ + int compId; + void *globalServices; +}services_t; + +typedef struct comp +{ + void *myServices; + void (*setServices)(struct comp *self, services_t *myServices); + void *myPort; +}comp_t; + +/* prototypes for f90 functions */ +void sub0(comp_t *self, services_t *myServices); + +int main(int argc, char **argv) +{ + services_t servicesObj; + comp_t myComp; + + servicesObj.compId = 17; + servicesObj.globalServices = 0; /* NULL; */ + myComp.myServices = &servicesObj; + myComp.setServices = 0; /* NULL; */ + myComp.myPort = 0; /* NULL; */ + + sub0(&myComp, &servicesObj); + + return 0; +}/* end main() */ + diff --git a/Fortran/gfortran/regression/c_size_t_driver.c b/Fortran/gfortran/regression/c_size_t_driver.c --- /dev/null +++ b/Fortran/gfortran/regression/c_size_t_driver.c @@ -0,0 +1,12 @@ +#include +void sub0(int my_c_size); + +int main(int argc, char **argv) +{ + int my_c_size; + + my_c_size = (int)sizeof(size_t); + sub0(my_c_size); + + return 0; +} diff --git a/Fortran/gfortran/regression/c_size_t_test.f03 b/Fortran/gfortran/regression/c_size_t_test.f03 --- /dev/null +++ b/Fortran/gfortran/regression/c_size_t_test.f03 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-additional-sources c_size_t_driver.c } +module c_size_t_test + use, intrinsic :: iso_c_binding + +contains + subroutine sub0(my_c_size) bind(c) + integer(c_int), value :: my_c_size ! value of C's sizeof(size_t) + + ! if the value of c_size_t isn't equal to the value of C's sizeof(size_t) + ! we call abort. + if(c_size_t .ne. my_c_size) then + STOP 1 + end if + end subroutine sub0 +end module c_size_t_test diff --git a/Fortran/gfortran/regression/c_sizeof_1.f90 b/Fortran/gfortran/regression/c_sizeof_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_sizeof_1.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! Support F2008's c_sizeof() +! +use iso_c_binding, only: c_int, c_char, c_ptr, c_intptr_t, c_null_ptr, c_sizeof + +integer(kind=c_int) :: i, j(10) +character(kind=c_char,len=4),parameter :: str(1 ) = "abcd" +character(kind=c_char,len=1),parameter :: str2(4) = ["a","b","c","d"] +type(c_ptr) :: cptr +integer(c_intptr_t) :: iptr + +! Using F2008's C_SIZEOF +i = c_sizeof(i) +if (i /= 4) STOP 1 + +i = c_sizeof(j) +if (i /= 40) STOP 2 + +i = c_sizeof(str2) +if (i /= 4) STOP 3 + +i = c_sizeof(str2(1)) +if (i /= 1) STOP 4 + +write(*,*) c_sizeof(cptr), c_sizeof(iptr), c_sizeof(C_NULL_PTR) + +! Using GNU's SIZEOF +i = sizeof(i) +if (i /= 4) STOP 5 + +i = sizeof(j) +if (i /= 40) STOP 6 + +i = sizeof(str) +if (i /= 4) STOP 7 + +i = sizeof(str(1)) +if (i /= 4) STOP 8 + +i = sizeof(str(1)(1:3)) +if (i /= 3) STOP 9 + +end + diff --git a/Fortran/gfortran/regression/c_sizeof_2.f90 b/Fortran/gfortran/regression/c_sizeof_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_sizeof_2.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-std=f2003 -Wall -Wno-conversion" } +! Support F2008's c_sizeof() +! +USE ISO_C_BINDING, only: C_SIZE_T, c_sizeof ! { dg-error "is not in the selected standard" } +integer(C_SIZE_T) :: i +i = c_sizeof(i) +end + diff --git a/Fortran/gfortran/regression/c_sizeof_3.f90 b/Fortran/gfortran/regression/c_sizeof_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_sizeof_3.f90 @@ -0,0 +1,18 @@ +! { dg-do link } +! +! PR fortran/40568 +! +! Module checks for C_SIZEOF (part of ISO_C_BINDING) +! +subroutine test +use iso_c_binding, only: foo => c_sizeof, bar=> c_sizeof, c_sizeof, c_int +integer(c_int) :: i +print *, c_sizeof(i), bar(i), foo(i) +end + +use iso_c_binding +implicit none +integer(c_int) :: i +print *, c_sizeof(i) +call test() +end diff --git a/Fortran/gfortran/regression/c_sizeof_4.f90 b/Fortran/gfortran/regression/c_sizeof_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_sizeof_4.f90 @@ -0,0 +1,10 @@ +! { dg-do link } +! +! PR fortran/40568 +! +! Module checks for C_SIZEOF (part of ISO_C_BINDING) +! + +implicit none +intrinsic c_sizeof ! { dg-error "does not exist" } +end diff --git a/Fortran/gfortran/regression/c_sizeof_5.f90 b/Fortran/gfortran/regression/c_sizeof_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_sizeof_5.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! { dg-options "-fcray-pointer" } +! +use iso_c_binding +real target(10) +real pointee(10) +pointer (ipt, pointee) +integer(c_intptr_t) :: int_cptr +real :: x +if (c_sizeof(ipt) /= c_sizeof(int_cptr)) STOP 1 +if (c_sizeof(pointee) /= c_sizeof(x)*10) STOP 2 +end diff --git a/Fortran/gfortran/regression/c_sizeof_6.f90 b/Fortran/gfortran/regression/c_sizeof_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/c_sizeof_6.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +program foo + + use iso_c_binding, only: c_int, c_char, c_sizeof + + integer(kind=c_int) :: i + + character(kind=c_char,len=1),parameter :: str2(4) = ["a","b","c","d"] + + i = c_sizeof(str2(1:3)) ! { dg-error "must be an interoperable data" } + + if (i /= 3) STOP 1 + +end program foo + diff --git a/Fortran/gfortran/regression/change_symbol_attributes_1.f90 b/Fortran/gfortran/regression/change_symbol_attributes_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/change_symbol_attributes_1.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! Fix for PR21730 - declarations used to produce the error: +! target :: x ! these 2 lines interchanged +! 1 +! Error: Cannot change attributes of symbol at (1) after it has been used. +! +! Contributed by Harald Anlauf +! +subroutine gfcbug27 (x) + real, intent(inout) :: x(:) + + real :: tmp(size (x,1)) ! gfc produces an error unless + target :: x ! these 2 lines interchanged + real, pointer :: p(:) + + p => x(:) +end subroutine gfcbug27 diff --git a/Fortran/gfortran/regression/char4-subscript.f90 b/Fortran/gfortran/regression/char4-subscript.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char4-subscript.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } +! +! PR fortran/95837 +! +type t + character(len=:, kind=4), pointer :: str2 +end type t +type(t) :: var + +allocate(character(len=5, kind=4) :: var%str2) + +var%str2(1:1) = 4_"d" +var%str2(2:3) = 4_"ef" +var%str2(4:4) = achar(int(Z'1F600'), kind=4) +var%str2(5:5) = achar(int(Z'1F608'), kind=4) + +if (var%str2(1:3) /= 4_"def") stop 1 +if (ichar(var%str2(4:4)) /= int(Z'1F600')) stop 2 +if (ichar(var%str2(5:5)) /= int(Z'1F608')) stop 2 + +deallocate(var%str2) +end + +! Note: the last '\x00' is regarded as string terminator, hence, the trailing \0 byte is not in the dump + +! { dg-final { scan-tree-dump { \(\*var\.str2\)\[1\]{lb: 1 sz: 4} = "(d\\x00\\x00|\\x00\\x00\\x00d)"\[1\]{lb: 1 sz: 4};} "original" } } +! { dg-final { scan-tree-dump { __builtin_memmove \(\(void \*\) &\(\*var.str2\)\[2\]{lb: 1 sz: 4}, \(void \*\) &"(e\\x00\\x00\\x00f\\x00\\x00|\\x00\\x00\\x00e\\x00\\x00\\x00f)"\[1\]{lb: 1 sz: 4}, 8\);} "original" } } +! { dg-final { scan-tree-dump { \(\*var.str2\)\[4\]{lb: 1 sz: 4} = "(\\x00\\xf6\\x01|\\x00\\x01\\xf6)"\[1\]{lb: 1 sz: 4};} "original" } } +! { dg-final { scan-tree-dump { \(\*var.str2\)\[5\]{lb: 1 sz: 4} = "(\\b\\xf6\\x01|\\x00\\x01\\xf6\\b)"\[1\]{lb: 1 sz: 4};} "original" } } diff --git a/Fortran/gfortran/regression/char4_decl-2.f90 b/Fortran/gfortran/regression/char4_decl-2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char4_decl-2.f90 @@ -0,0 +1,63 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } + +! In this program shall be no kind=1, +! except for the 'argv' of the 'main' program. + +! PR fortran/107266 + +! { dg-final { scan-tree-dump-times "kind=1" 1 "original" } } +! { dg-final { scan-tree-dump-times "character\\(kind=1\\) \\* \\* argv\\)" 1 "original" } } + + +! { dg-final { scan-tree-dump-times "character\\(kind=4\\) f \\(character\\(kind=4\\) x\\)" 1 "original" } } + +character(kind=4) function f(x) bind(C) + character(kind=4), value :: x +end + +program testit + implicit none (type, external) + character (kind=4, len=:), allocatable :: aa + character (kind=4, len=:), pointer :: pp + + pp => NULL () + + call frobf (aa, pp) + if (.not. allocated (aa)) stop 101 + if (storage_size(aa) /= storage_size(4_'foo')) stop 1 + if (aa .ne. 4_'foo') stop 102 + if (.not. associated (pp)) stop 103 + if (storage_size(pp) /= storage_size(4_'bar')) stop 2 + if (pp .ne. 4_'bar') stop 104 + + pp => NULL () + + call frobc (aa, pp) + if (.not. allocated (aa)) stop 105 + if (storage_size(aa) /= storage_size(4_'frog')) stop 3 + if (aa .ne. 4_'frog') stop 106 + if (.not. associated (pp)) stop 107 + if (storage_size(pp) /= storage_size(4_'toad')) stop 4 + if (pp .ne. 4_'toad') stop 108 + + + contains + + subroutine frobf (a, p) Bind(C) + character (kind=4, len=:), allocatable :: a + character (kind=4, len=:), pointer :: p + allocate (character(kind=4, len=3) :: p) + a = 4_'foo' + p = 4_'bar' + end subroutine + + subroutine frobc (a, p) Bind(C) + character (kind=4, len=:), allocatable :: a + character (kind=4, len=:), pointer :: p + allocate (character(kind=4, len=4) :: p) + a = 4_'frog' + p = 4_'toad' + end subroutine + +end program diff --git a/Fortran/gfortran/regression/char4_decl.f90 b/Fortran/gfortran/regression/char4_decl.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char4_decl.f90 @@ -0,0 +1,56 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } + +! In this program shall be no kind=1, +! except for the 'argv' of the 'main' program. + +! Related PR fortran/107266 + +! { dg-final { scan-tree-dump-times "kind=1" 1 "original" } } +! { dg-final { scan-tree-dump-times "character\\(kind=1\\) \\* \\* argv\\)" 1 "original" } } + +program testit + implicit none (type, external) + character (kind=4, len=:), allocatable :: aa + character (kind=4, len=:), pointer :: pp + + pp => NULL () + + call frobf (aa, pp) + if (.not. allocated (aa)) stop 101 + if (storage_size(aa) /= storage_size(4_'foo')) stop 1 + if (aa .ne. 4_'foo') stop 102 + if (.not. associated (pp)) stop 103 + if (storage_size(pp) /= storage_size(4_'bar')) stop 2 + if (pp .ne. 4_'bar') stop 104 + + pp => NULL () + + call frobc (aa, pp) + if (.not. allocated (aa)) stop 105 + if (storage_size(aa) /= storage_size(4_'frog')) stop 3 + if (aa .ne. 4_'frog') stop 106 + if (.not. associated (pp)) stop 107 + if (storage_size(pp) /= storage_size(4_'toad')) stop 4 + if (pp .ne. 4_'toad') stop 108 + + + contains + + subroutine frobf (a, p) + character (kind=4, len=:), allocatable :: a + character (kind=4, len=:), pointer :: p + allocate (character(kind=4, len=3) :: p) + a = 4_'foo' + p = 4_'bar' + end subroutine + + subroutine frobc (a, p) + character (kind=4, len=:), allocatable :: a + character (kind=4, len=:), pointer :: p + allocate (character(kind=4, len=4) :: p) + a = 4_'frog' + p = 4_'toad' + end subroutine + +end program diff --git a/Fortran/gfortran/regression/char4_iunit_1.f03 b/Fortran/gfortran/regression/char4_iunit_1.f03 --- /dev/null +++ b/Fortran/gfortran/regression/char4_iunit_1.f03 @@ -0,0 +1,33 @@ +! { dg-do run } +! { dg-add-options ieee } +! PR37077 Implement Internal Unit I/O for character KIND=4 +! Test case prepared by Jerry DeLisle +program char4_iunit_1 + implicit none + character(kind=4,len=44) :: string + integer(kind=4) :: i,j + real(kind=4) :: inf, nan, large + + large = huge(large) + inf = 2 * large + nan = 0 + nan = nan / nan + + string = 4_"123456789x" + write(string,'(a11)') 4_"abcdefg" + if (string .ne. 4_" abcdefg ") STOP 1 + write(string,*) 12345 + if (string .ne. 4_" 12345 ") STOP 2 + write(string, '(i6,5x,i8,a5)') 78932, 123456, "abc" + if (string .ne. 4_" 78932 123456 abc ") STOP 3 + write(string, *) .true., .false. , .true. + if (string .ne. 4_" T F T ") STOP 4 + write(string, *) 1.2345e-06, 4.2846e+10_8 + if (string .ne. 4_" 1.23450002E-06 42846000000.000000 ") STOP 5 + write(string, *) nan, inf + if (string .ne. 4_" NaN Infinity ") STOP 6 + write(string, '(10x,f3.1,3x,f9.1)') nan, inf + if (string .ne. 4_" NaN Infinity ") STOP 7 + write(string, *) (1.2, 3.4 ) + if (string .ne. 4_" (1.20000005,3.40000010)") STOP 8 +end program char4_iunit_1 diff --git a/Fortran/gfortran/regression/char4_iunit_2.f03 b/Fortran/gfortran/regression/char4_iunit_2.f03 --- /dev/null +++ b/Fortran/gfortran/regression/char4_iunit_2.f03 @@ -0,0 +1,47 @@ +! { dg-do run } +! PR37077 Implement Internal Unit I/O for character KIND=4 +! Test case prepared by Jerry DeLisle +program char4_iunit_2 + implicit none + integer, parameter :: k = 4 + character(kind=4,len=80) :: widestring, str_char4 + character(kind=1,len=80) :: skinnystring + integer :: i,j + real :: x + character(9) :: str_default + + widestring = k_"12345 2.54360 hijklmnop qwertyuiopasdfg" + skinnystring = "12345 2.54360 hijklmnop qwertyuiopasdfg" + i = 77777 + x = 0.0 + str_default = "xxxxxxxxx" + str_char4 = k_"xyzzy" + read(widestring,'(i5,1x,f7.5,1x,a9,1x,a15)') i, x, str_default, str_char4 + if (i /= 12345 .or. (x - 2.5436001) > epsilon(x) .or. & + str_default /= "hijklmnop" .or. str_char4 /= k_"qwertyuiopasdfg")& + STOP 1 + i = 77777 + x = 0.0 + str_default = "xxxxxxxxx" + str_char4 = k_"xyzzy" + read(widestring,'(2x,i4,tl3,1x,f7.5,1x,a9,1x,a15)')i, x, str_default,& + str_char4 + if (i /= 345 .or. (x - 52.542999) > epsilon(x) .or. & + str_default /= "0 hijklmn" .or. str_char4 /= k_"p qwertyuiopasd")& + STOP 2 + read(skinnystring,'(2x,i4,tl3,1x,f7.5,1x,a9,1x,a15)')i, x, str_default,& + str_char4 + if (i /= 345 .or. (x - 52.542999) > epsilon(x) .or. & + str_default /= "0 hijklmn" .or. str_char4 /= k_"p qwertyuiopasd")& + STOP 3 + write(widestring,'(2x,i4,tl3,1x,f10.5,1x,a9,1x,a15)')i, x, str_default,& + trim(str_char4) + if (widestring .ne. k_" 3 52.54300 0 hijklmn p qwertyuiopasd") STOP 4 + write(skinnystring,'(2x,i4,tl3,1x,f10.5,1x,a9,1x,a15)')i, x, str_default,& + trim(str_char4) + if (skinnystring .ne. " 3 52.54300 0 hijklmn p qwertyuiopasd") STOP 5 + write(widestring,*)"test",i, x, str_default,& + trim(str_char4) + if (widestring .ne. & + k_" test 345 52.5429993 0 hijklmnp qwertyuiopasd") STOP 6 +end program char4_iunit_2 diff --git a/Fortran/gfortran/regression/char_allocation_1.f90 b/Fortran/gfortran/regression/char_allocation_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_allocation_1.f90 @@ -0,0 +1,11 @@ +! PR fortran/31974 +! { dg-do run } + subroutine foo (n) + integer :: n + character (len = n) :: v(n) + v = '' + if (any (v /= '')) STOP 1 + end subroutine foo + + call foo(7) + end diff --git a/Fortran/gfortran/regression/char_array_arg_1.f90 b/Fortran/gfortran/regression/char_array_arg_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_array_arg_1.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! Test the fix for pr41167, in which the first argument of 'pack', below, +! was simplified incorrectly, with the results indicated. +! +! Contributed by Harald Anlauf +! +program gfcbug88 + implicit none + type t + character(len=8) :: name + end type t + type(t) ,parameter :: obstyp(2)= (/ t ('A'), t ('B') /) + character(9) :: chr(1) + + print *, pack (" "//obstyp(:)% name, (/ .true., .false. /)) ! Used to ICE on compilation + chr = pack (" "//obstyp(:)% name, (/ .true., .false. /)) ! Used to give conversion error +end program gfcbug88 diff --git a/Fortran/gfortran/regression/char_array_constructor.f90 b/Fortran/gfortran/regression/char_array_constructor.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_array_constructor.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +module z + integer :: i + character(6) :: a(2) = (/ ('main ' , i = 1, 2) /) + character(6) :: b(2) = (/ 'abcd ' , 'efghij' /) +end module + +program y + use z + if (a(1) /= 'main ') STOP 1 + if (a(2) /= 'main ') STOP 2 + if (b(1) /= 'abcd ') STOP 3 + if (b(2) /= 'efghij') STOP 4 +end program y diff --git a/Fortran/gfortran/regression/char_array_constructor_2.f90 b/Fortran/gfortran/regression/char_array_constructor_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_array_constructor_2.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! Tests the fix for PR30319, in which the use of the parameter 'aa' in +! the array constructor that initialises bb would cause an internal +! error in resolution. +! +! Contributed by Vivek Rao +! +module foomod + character (len=1), parameter :: aa = "z", bb(1) = (/aa/) +end module foomod + use foomod + print *, aa, bb +end diff --git a/Fortran/gfortran/regression/char_array_constructor_3.f90 b/Fortran/gfortran/regression/char_array_constructor_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_array_constructor_3.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! tests the fix for PR32156, in which the character length of the compound +! expression got lost. +! +! Contributed by Tobias Burnus +! +write (*,'(2A3)') 'X'//(/"1","2"/)//'Y' +END diff --git a/Fortran/gfortran/regression/char_array_constructor_4.f90 b/Fortran/gfortran/regression/char_array_constructor_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_array_constructor_4.f90 @@ -0,0 +1,13 @@ +! PR 30319 - Bogus warning from -Warray-bounds during string assignment +! { dg-do compile } +! { dg-options "-O2 -Warray-bounds" } + +program test_bounds + + character(256) :: foo + + foo = '1234' ! { dg-bogus "\\\[-Warray-bounds" } + + print *, foo + +end program test_bounds diff --git a/Fortran/gfortran/regression/char_array_structure_constructor.f90 b/Fortran/gfortran/regression/char_array_structure_constructor.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_array_structure_constructor.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! +! PR fortran/19107 +! -fwhole-file flag added for PR fortran/44945 +! +! This test the fix of PR19107, where character array actual +! arguments in derived type constructors caused an ICE. +! It also checks that the scalar counterparts are OK. +! Contributed by Paul Thomas pault@gcc.gnu.org +! +MODULE global + TYPE :: dt + CHARACTER(4) a + CHARACTER(4) b(2) + END TYPE + TYPE (dt), DIMENSION(:), ALLOCATABLE, SAVE :: c +END MODULE global +program char_array_structure_constructor + USE global + call alloc (2) + if ((any (c%a /= "wxyz")) .OR. & + (any (c%b(1) /= "abcd")) .OR. & + (any (c%b(2) /= "efgh"))) STOP 1 +contains + SUBROUTINE alloc (n) + USE global + ALLOCATE (c(n), STAT=IALLOC_FLAG) + DO i = 1,n + c (i) = dt ("wxyz",(/"abcd","efgh"/)) + ENDDO + end subroutine alloc +END program char_array_structure_constructor diff --git a/Fortran/gfortran/regression/char_assign_1.f90 b/Fortran/gfortran/regression/char_assign_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_assign_1.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! { dg-options "-Wcharacter-truncation" } +! Tests the fix for PR31266: references to CHARACTER +! components lead to the wrong length being assigned to substring +! expressions. +type data + character(len=5) :: c +end type data +type(data), dimension(5), target :: y +character(len=2), dimension(5) :: p +character(len=3), dimension(5) :: q + +y(:)%c = "abcdef" ! { dg-warning "in assignment \\(5/6\\)" } +p(1) = y(1)%c(3:) ! { dg-warning "in assignment \\(2/3\\)" } +if (p(1).ne."cd") STOP 1 + +p(1) = y(1)%c ! { dg-warning "in assignment \\(2/5\\)" } +if (p(1).ne."ab") STOP 2 + +q = "xyz" +p = q ! { dg-warning "CHARACTER expression will be truncated in assignment \\(2/3\\)" } +if (any (p.ne.q(:)(1:2))) STOP 3 +end diff --git a/Fortran/gfortran/regression/char_associated_1.f90 b/Fortran/gfortran/regression/char_associated_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_associated_1.f90 @@ -0,0 +1,8 @@ +! Check that associated works correctly for character arrays. +! { dg-do run } +program main + character (len = 5), dimension (:), pointer :: ptr + character (len = 5), dimension (2), target :: a = (/ 'abcde', 'fghij' /) + ptr => a + if (.not. associated (ptr, a)) STOP 1 +end program main diff --git a/Fortran/gfortran/regression/char_bounds_check_fail_1.f90 b/Fortran/gfortran/regression/char_bounds_check_fail_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_bounds_check_fail_1.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Substring out of bounds check" } +! PR fortran/27588 +program bound_check + character*10 zz + i = 2 + j = i+9 + zz = ' ' + zz(i:j) = 'abcdef' + print * , zz + end +! { dg-output "At line 10.*Substring out of bounds: upper bound \\(11\\) of 'zz' exceeds string length" } diff --git a/Fortran/gfortran/regression/char_cast_1.f90 b/Fortran/gfortran/regression/char_cast_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_cast_1.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } +! +! Check the fix for PR31608 in all it's various manifestations:) +! Contributed by Richard Guenther +! + character(len=1) :: string = "z" + integer :: i(1) = (/100/) + print *, Up("abc") + print *, transfer(((transfer(string,"x",1))), "x",1) + print *, transfer(char(i), "x") + print *, Upper ("abcdefg") + contains + Character (len=20) Function Up (string) + Character(len=*) string + character(1) :: chr + Up = transfer(achar(iachar(transfer(string,chr,1))), "x") + return + end function Up + Character (len=20) Function Upper (string) + Character(len=*) string + Upper = & + transfer(merge(transfer(string,"x",len(string)), & + string, .true.), "x") + return + end function Upper +end +! The sign that all is well is that [S.6][1] appears twice. +! Platform dependent variations are [S$6][1], [__S_6][1], [S___6][1] +! { dg-final { scan-tree-dump-times "6\\\]\\\[1\\\]" 2 "original" } } diff --git a/Fortran/gfortran/regression/char_cast_2.f90 b/Fortran/gfortran/regression/char_cast_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_cast_2.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! This is the same as achar_4.f90 but checks that the result of the 'merge' +! reference is correctly cast. +! +! The code comes from http://www.star.le.ac.uk/~cgp/fortran.html (by Clive Page) +! Reported by Thomas Koenig +! + if (any (Up ("AbCdEfGhIjKlM") .ne. (/"ABCDEFGHIJKLM"/))) STOP 1 +contains + Character (len=20) Function Up (string) + Character(len=*) string + Up = & + transfer(merge(achar(iachar(transfer(string,"x",len(string)))- & + (ichar('a')-ichar('A')) ), & + transfer(string,"x",len(string)) , & + transfer(string,"x",len(string)) >= "a" .and. & + transfer(string,"x",len(string)) <= "z"), repeat("x", len(string))) + return + end function Up +end +! The sign that all is well is that [S.5][1] appears twice. +! Platform dependent variations are [S$5][1], [__S_5][1], [S___5][1] +! so we count the occurrences of 5][1]. +! { dg-final { scan-tree-dump-times "5\\\]\\\[1\\\]" 2 "original" } } diff --git a/Fortran/gfortran/regression/char_comparison_1.f b/Fortran/gfortran/regression/char_comparison_1.f --- /dev/null +++ b/Fortran/gfortran/regression/char_comparison_1.f @@ -0,0 +1,28 @@ +C { dg-do run } +C { dg-options "-std=legacy" } +C +C PR 30525 - comparisons with padded spaces were done +C signed. + program main + character*2 c2 + character*1 c1, c3, c4 +C +C Comparison between char(255) and space padding +C + c2 = 'a' // char(255) + c1 = 'a' + if (.not. (c2 .gt. c1)) STOP 1 +C +C Comparison between char(255) and space +C + c3 = ' ' + c4 = char(255) + if (.not. (c4 .gt. c3)) STOP 2 + +C +C Check constant folding +C + if (.not. ('a' // char(255) .gt. 'a')) STOP 3 + + if (.not. (char(255) .gt. 'a')) STOP 4 + end diff --git a/Fortran/gfortran/regression/char_component_initializer_1.f90 b/Fortran/gfortran/regression/char_component_initializer_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_component_initializer_1.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! Check the fix for PR31487 in which the derived type default initializer +! would be padded out with nulls instead of spaces. +! +! Reported by Harald Anlauf +! +program gfcbug62 + implicit none + character(len=16) :: tdefi(2) = (/'0z1jan0000','1hr '/) + type t_ctl + character(len=16) :: tdefi(2) = (/'0z1jan0000','1hr '/) + end type t_ctl + + type(t_ctl) :: ctl + integer :: i,k + + if (tdefi(1) .ne. ctl%tdefi(1)) STOP 1 +end program gfcbug62 diff --git a/Fortran/gfortran/regression/char_component_initializer_2.f90 b/Fortran/gfortran/regression/char_component_initializer_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_component_initializer_2.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-Wall" } +! Added -Wall option to make sure PR42526 does not show up again. +program gfcbug62 + implicit none + character(len=16) :: tdefi(2) = (/'0z1jan0000','1hr '/) + type t_ctl + character(len=16) :: tdefi(2) = (/'0z1jan0000','1hr '/) + end type t_ctl + + type(t_ctl) :: ctl + integer :: i,k + i = 1 + k = 1 + if (tdefi(1) .ne. ctl%tdefi(1)) STOP 1 +end program gfcbug62 diff --git a/Fortran/gfortran/regression/char_component_initializer_3.f90 b/Fortran/gfortran/regression/char_component_initializer_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_component_initializer_3.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/78479 +program p + type t + character(3) :: c(1) = 'a' // ['b'] + end type +end diff --git a/Fortran/gfortran/regression/char_cons_len.f90 b/Fortran/gfortran/regression/char_cons_len.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_cons_len.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! Tests the fix for PR24813 in which a character array +! constructor, as an argument for LEN, would cause an ICE. +! + character(11) :: chr1, chr2 + i = len ((/chr1, chr2, "ggg "/)) + j = len ((/"abcdefghijk", chr1, chr2/)) + k = len ((/'hello ','goodbye'/)) + l = foo ("yes siree, Bob") + if (any ((/11,11,7,14/) /= (/i,j,k,l/))) STOP 1 +contains + integer function foo (arg) + character(*) :: arg + character(len(arg)) :: ctor + foo = len ((/ctor/)) + end function foo +end diff --git a/Fortran/gfortran/regression/char_conversion.f90 b/Fortran/gfortran/regression/char_conversion.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_conversion.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! PR 78618: ICE in gfc_check_rank, at fortran/check.c:3670 +! +! Contributed by Gerhard Steinmetz + +program p + character, parameter :: c = char(256,4) ! { dg-error "cannot be converted" } + if (rank(c) /= 0) STOP 1 +end diff --git a/Fortran/gfortran/regression/char_cshift_1.f90 b/Fortran/gfortran/regression/char_cshift_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_cshift_1.f90 @@ -0,0 +1,40 @@ +! Test cshift0 for character arrays. +! { dg-do run } +program main + implicit none + integer, parameter :: n1 = 2, n2 = 3, n3 = 4, slen = 3 + character (len = slen), dimension (n1, n2, n3) :: a + integer (kind = 1) :: shift1 = 3 + integer (kind = 2) :: shift2 = 4 + integer (kind = 4) :: shift3 = 5 + integer (kind = 8) :: shift4 = 6 + integer :: i1, i2, i3 + + do i3 = 1, n3 + do i2 = 1, n2 + do i1 = 1, n1 + a (i1, i2, i3) = 'ab'(i1:i1) // 'cde'(i2:i2) // 'fghi'(i3:i3) + end do + end do + end do + + call test (cshift (a, shift1, 1), int (shift1), 0, 0) + call test (cshift (a, shift2, 2), 0, int (shift2), 0) + call test (cshift (a, shift3, 3), 0, 0, int (shift3)) + call test (cshift (a, shift4, 3), 0, 0, int (shift4)) +contains + subroutine test (b, d1, d2, d3) + character (len = slen), dimension (n1, n2, n3) :: b + integer :: d1, d2, d3 + + do i3 = 1, n3 + do i2 = 1, n2 + do i1 = 1, n1 + if (b (i1, i2, i3) .ne. a (mod (d1 + i1 - 1, n1) + 1, & + mod (d2 + i2 - 1, n2) + 1, & + mod (d3 + i3 - 1, n3) + 1)) STOP 1 + end do + end do + end do + end subroutine test +end program main diff --git a/Fortran/gfortran/regression/char_cshift_2.f90 b/Fortran/gfortran/regression/char_cshift_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_cshift_2.f90 @@ -0,0 +1,45 @@ +! Test cshift1 for character arrays. +! { dg-do run } +program main + implicit none + integer, parameter :: n1 = 2, n2 = 3, n3 = 4, slen = 3 + character (len = slen), dimension (n1, n2, n3) :: a + integer (kind = 1), dimension (2, 4) :: shift1 + integer (kind = 2), dimension (2, 4) :: shift2 + integer (kind = 4), dimension (2, 4) :: shift3 + integer (kind = 8), dimension (2, 4) :: shift4 + integer :: i1, i2, i3 + + do i3 = 1, n3 + do i2 = 1, n2 + do i1 = 1, n1 + a (i1, i2, i3) = 'ab'(i1:i1) // 'cde'(i2:i2) // 'fghi'(i3:i3) + end do + end do + end do + + shift1 (1, :) = (/ 4, 11, 19, 20 /) + shift1 (2, :) = (/ 55, 5, 1, 2 /) + shift2 = shift1 + shift3 = shift1 + shift4 = shift1 + + call test (cshift (a, shift1, 2)) + call test (cshift (a, shift2, 2)) + call test (cshift (a, shift3, 2)) + call test (cshift (a, shift4, 2)) +contains + subroutine test (b) + character (len = slen), dimension (n1, n2, n3) :: b + integer :: i2p + + do i3 = 1, n3 + do i2 = 1, n2 + do i1 = 1, n1 + i2p = mod (shift1 (i1, i3) + i2 - 1, n2) + 1 + if (b (i1, i2, i3) .ne. a (i1, i2p, i3)) STOP 1 + end do + end do + end do + end subroutine test +end program main diff --git a/Fortran/gfortran/regression/char_cshift_3.f90 b/Fortran/gfortran/regression/char_cshift_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_cshift_3.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! PR 36886 - misalignment of characters for cshift could cause +! problems on some architectures. +program main + character(len=2) :: c2 + character(len=4), dimension(2,2) :: a, b, c, d + ! Force misalignment of a or b + common /foo/ a, c, c2, b, d + a = 'aa' + b = 'bb' + d = cshift(b,1) + c = cshift(a,1) +end program main diff --git a/Fortran/gfortran/regression/char_decl_1.f90 b/Fortran/gfortran/regression/char_decl_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_decl_1.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +! PR32644 "CHARACTER*1, c" produces "Unclassifiable statement" +program f +character*1, c +end program f diff --git a/Fortran/gfortran/regression/char_decl_2.f90 b/Fortran/gfortran/regression/char_decl_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_decl_2.f90 @@ -0,0 +1,4 @@ +! { dg-do run } + character (kind=kind("a")) :: u + if (kind(u) /= kind("a")) STOP 1 + end diff --git a/Fortran/gfortran/regression/char_eoshift_1.f90 b/Fortran/gfortran/regression/char_eoshift_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_eoshift_1.f90 @@ -0,0 +1,50 @@ +! Test eoshift0 for character arrays. +! { dg-do run } +program main + implicit none + integer, parameter :: n1 = 6, n2 = 5, n3 = 4, slen = 3 + character (len = slen), dimension (n1, n2, n3) :: a + character (len = slen) :: filler + integer (kind = 1) :: shift1 = 4 + integer (kind = 2) :: shift2 = 2 + integer (kind = 4) :: shift3 = 3 + integer (kind = 8) :: shift4 = 1 + integer :: i1, i2, i3 + + do i3 = 1, n3 + do i2 = 1, n2 + do i1 = 1, n1 + a (i1, i2, i3) = 'abcdef'(i1:i1) // 'ghijk'(i2:i2) // 'lmno'(i3:i3) + end do + end do + end do + + call test (eoshift (a, shift1, 'foo', 1), int (shift1), 0, 0, 'foo') + call test (eoshift (a, shift2, 'foo', 2), 0, int (shift2), 0, 'foo') + call test (eoshift (a, shift3, 'foo', 2), 0, int (shift3), 0, 'foo') + call test (eoshift (a, shift4, 'foo', 3), 0, 0, int (shift4), 'foo') + + filler = '' + call test (eoshift (a, shift1, dim = 1), int (shift1), 0, 0, filler) + call test (eoshift (a, shift2, dim = 2), 0, int (shift2), 0, filler) + call test (eoshift (a, shift3, dim = 2), 0, int (shift3), 0, filler) + call test (eoshift (a, shift4, dim = 3), 0, 0, int (shift4), filler) +contains + subroutine test (b, d1, d2, d3, filler) + character (len = slen), dimension (n1, n2, n3) :: b + character (len = slen) :: filler + integer :: d1, d2, d3 + + do i3 = 1, n3 + do i2 = 1, n2 + do i1 = 1, n1 + if (i1 + d1 .gt. n1 .or. i2 + d2 .gt. n2 .or. i3 + d3 .gt. n3) then + if (b (i1, i2, i3) .ne. filler) STOP 1 + else + if (b (i1, i2, i3) .ne. a (i1 + d1, i2 + d2, i3 + d3)) STOP 2 + end if + end do + end do + end do + end subroutine test +end program main diff --git a/Fortran/gfortran/regression/char_eoshift_2.f90 b/Fortran/gfortran/regression/char_eoshift_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_eoshift_2.f90 @@ -0,0 +1,57 @@ +! Test eoshift1 for character arrays. +! { dg-do run } +program main + implicit none + integer, parameter :: n1 = 2, n2 = 5, n3 = 4, slen = 3 + character (len = slen), dimension (n1, n2, n3) :: a + character (len = slen) :: filler + integer (kind = 1), dimension (n1, n3) :: shift1 + integer (kind = 2), dimension (n1, n3) :: shift2 + integer (kind = 4), dimension (n1, n3) :: shift3 + integer (kind = 8), dimension (n1, n3) :: shift4 + integer :: i1, i2, i3 + + shift1 (1, :) = (/ 1, 3, 2, 2 /) + shift1 (2, :) = (/ 2, 1, 1, 3 /) + shift2 = shift1 + shift3 = shift1 + shift4 = shift1 + + do i3 = 1, n3 + do i2 = 1, n2 + do i1 = 1, n1 + a (i1, i2, i3) = 'ab'(i1:i1) // 'cdefg'(i2:i2) // 'hijk'(i3:i3) + end do + end do + end do + + call test (eoshift (a, shift1, 'foo', 2), 'foo') + call test (eoshift (a, shift2, 'foo', 2), 'foo') + call test (eoshift (a, shift3, 'foo', 2), 'foo') + call test (eoshift (a, shift4, 'foo', 2), 'foo') + + filler = '' + call test (eoshift (a, shift1, dim = 2), filler) + call test (eoshift (a, shift2, dim = 2), filler) + call test (eoshift (a, shift3, dim = 2), filler) + call test (eoshift (a, shift4, dim = 2), filler) +contains + subroutine test (b, filler) + character (len = slen), dimension (n1, n2, n3) :: b + character (len = slen) :: filler + integer :: i2p + + do i3 = 1, n3 + do i2 = 1, n2 + do i1 = 1, n1 + i2p = i2 + shift1 (i1, i3) + if (i2p .gt. n2) then + if (b (i1, i2, i3) .ne. filler) STOP 1 + else + if (b (i1, i2, i3) .ne. a (i1, i2p, i3)) STOP 2 + end if + end do + end do + end do + end subroutine test +end program main diff --git a/Fortran/gfortran/regression/char_eoshift_3.f90 b/Fortran/gfortran/regression/char_eoshift_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_eoshift_3.f90 @@ -0,0 +1,54 @@ +! Test eoshift2 for character arrays. +! { dg-do run } +program main + implicit none + integer, parameter :: n1 = 2, n2 = 5, n3 = 4, slen = 3 + character (len = slen), dimension (n1, n2, n3) :: a + character (len = slen), dimension (n1, n3) :: filler + integer (kind = 1) :: shift1 = 4 + integer (kind = 2) :: shift2 = 2 + integer (kind = 4) :: shift3 = 3 + integer (kind = 8) :: shift4 = 1 + integer :: i1, i2, i3 + + filler (1, :) = (/ 'tic', 'tac', 'toe', 'tip' /) + filler (2, :) = (/ 'zzz', 'yyy', 'xxx', 'www' /) + + do i3 = 1, n3 + do i2 = 1, n2 + do i1 = 1, n1 + a (i1, i2, i3) = 'ab'(i1:i1) // 'cdefg'(i2:i2) // 'hijk'(i3:i3) + end do + end do + end do + + call test (eoshift (a, shift1, filler, 2), int (shift1), .true.) + call test (eoshift (a, shift2, filler, 2), int (shift2), .true.) + call test (eoshift (a, shift3, filler, 2), int (shift3), .true.) + call test (eoshift (a, shift4, filler, 2), int (shift4), .true.) + + call test (eoshift (a, shift1, dim = 2), int (shift1), .false.) + call test (eoshift (a, shift2, dim = 2), int (shift2), .false.) + call test (eoshift (a, shift3, dim = 2), int (shift3), .false.) + call test (eoshift (a, shift4, dim = 2), int (shift4), .false.) +contains + subroutine test (b, d2, has_filler) + character (len = slen), dimension (n1, n2, n3) :: b + logical :: has_filler + integer :: d2 + + do i3 = 1, n3 + do i2 = 1, n2 + do i1 = 1, n1 + if (i2 + d2 .le. n2) then + if (b (i1, i2, i3) .ne. a (i1, i2 + d2, i3)) STOP 1 + else if (has_filler) then + if (b (i1, i2, i3) .ne. filler (i1, i3)) STOP 2 + else + if (b (i1, i2, i3) .ne. '') STOP 3 + end if + end do + end do + end do + end subroutine test +end program main diff --git a/Fortran/gfortran/regression/char_eoshift_4.f90 b/Fortran/gfortran/regression/char_eoshift_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_eoshift_4.f90 @@ -0,0 +1,61 @@ +! Test eoshift3 for character arrays. +! { dg-do run } +program main + implicit none + integer, parameter :: n1 = 2, n2 = 5, n3 = 4, slen = 3 + character (len = slen), dimension (n1, n2, n3) :: a + character (len = slen), dimension (n1, n3) :: filler + integer (kind = 1), dimension (n1, n3) :: shift1 + integer (kind = 2), dimension (n1, n3) :: shift2 + integer (kind = 4), dimension (n1, n3) :: shift3 + integer (kind = 8), dimension (n1, n3) :: shift4 + integer :: i1, i2, i3 + + filler (1, :) = (/ 'tic', 'tac', 'toe', 'tip' /) + filler (2, :) = (/ 'zzz', 'yyy', 'xxx', 'www' /) + + shift1 (1, :) = (/ 1, 3, 2, 2 /) + shift1 (2, :) = (/ 2, 1, 1, 3 /) + shift2 = shift1 + shift3 = shift1 + shift4 = shift1 + + do i3 = 1, n3 + do i2 = 1, n2 + do i1 = 1, n1 + a (i1, i2, i3) = 'ab'(i1:i1) // 'cdefg'(i2:i2) // 'hijk'(i3:i3) + end do + end do + end do + + call test (eoshift (a, shift1, filler, 2), .true.) + call test (eoshift (a, shift2, filler, 2), .true.) + call test (eoshift (a, shift3, filler, 2), .true.) + call test (eoshift (a, shift4, filler, 2), .true.) + + call test (eoshift (a, shift1, dim = 2), .false.) + call test (eoshift (a, shift2, dim = 2), .false.) + call test (eoshift (a, shift3, dim = 2), .false.) + call test (eoshift (a, shift4, dim = 2), .false.) +contains + subroutine test (b, has_filler) + character (len = slen), dimension (n1, n2, n3) :: b + logical :: has_filler + integer :: i2p + + do i3 = 1, n3 + do i2 = 1, n2 + do i1 = 1, n1 + i2p = i2 + shift1 (i1, i3) + if (i2p .le. n2) then + if (b (i1, i2, i3) .ne. a (i1, i2p, i3)) STOP 1 + else if (has_filler) then + if (b (i1, i2, i3) .ne. filler (i1, i3)) STOP 2 + else + if (b (i1, i2, i3) .ne. '') STOP 3 + end if + end do + end do + end do + end subroutine test +end program main diff --git a/Fortran/gfortran/regression/char_eoshift_5.f90 b/Fortran/gfortran/regression/char_eoshift_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_eoshift_5.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } + +! PR fortran/36403 +! Check that the string length of BOUNDARY is added to the library-eoshift +! call even if BOUNDARY is missing (as it is optional). +! This is the original test from the PR. + +! Contributed by Kazumoto Kojima. + + CHARACTER(LEN=3), DIMENSION(10) :: Z + call test_eoshift +contains + subroutine test_eoshift + CHARACTER(LEN=1), DIMENSION(10) :: chk + chk(1:8) = "5" + chk(9:10) = " " + Z(:)="456" + if (any (EOSHIFT(Z(:)(2:2),2) .ne. chk)) STOP 1 + END subroutine +END + +! Check that _gfortran_eoshift* is called with 8 arguments: +! { dg-final { scan-tree-dump "_gfortran_eoshift\[0-9_\]+char \\(\[&a-zA-Z0-9._\]*, \[&a-zA-Z0-9._\]*, \[&a-zA-Z0-9._\]*, \[&a-zA-Z0-9._\]*, \[&a-zA-Z0-9._\]*, \[&a-zA-Z0-9._\]*, \[&a-zA-Z0-9._\]*, \[&a-zA-Z0-9._\]*\\)" "original" } } diff --git a/Fortran/gfortran/regression/char_expr_1.f90 b/Fortran/gfortran/regression/char_expr_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_expr_1.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! PR fortran/36795 +! "(str)" (= an expression) was regarded as "str" (= a variable) +! and thus when yy was deallocated so was xx. Result: An invalid +! memory access. +! +program main + implicit none + character (len=10), allocatable :: str(:) + allocate (str(1)) + str(1) = "dog" + if (size(str) /= 1 .or. str(1) /= "dog") STOP 1 +contains + subroutine foo(xx,yy) + character (len=*), intent(in) :: xx(:) + character (len=*), intent(out), allocatable :: yy(:) + allocate (yy(size(xx))) + yy = xx + end subroutine foo +end program main diff --git a/Fortran/gfortran/regression/char_expr_2.f90 b/Fortran/gfortran/regression/char_expr_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_expr_2.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! PR fortran/36803 +! PR fortran/36795 +! +! "(n)" was simplified to the EXPR_VARIABLE "n" +! and thus "(n)" was judged as definable. +! +interface + subroutine foo(x) + character, intent(out) :: x(:) ! or INTENT(INOUT) + end subroutine foo +end interface +character :: n(5) +call foo( (n) ) ! { dg-error "Non-variable expression" } +end diff --git a/Fortran/gfortran/regression/char_expr_3.f90 b/Fortran/gfortran/regression/char_expr_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_expr_3.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! Check the fix for PR36795, where the parentheses in the call to foo were +! simplified out ie. foo((xx), xx) simplified to foo (xx, xx) +! +! Conributed by Vivek Rao +! +program main + implicit none + character(len=10), allocatable :: xx(:) + character(len=10) :: yy + allocate (xx(2)) + xx(1) = "" + xx(2) = "dog" + call foo ((xx),xx) + if (trim (xx(1)) .ne. "dog") STOP 1 + if (size (xx, 1) .ne. 1) STOP 2 +contains + subroutine foo (xx,yy) + character(len=*), intent(in) :: xx(:) + character(len=*), intent(out), allocatable :: yy(:) + if (allocated (yy)) deallocate (yy) + allocate (yy(1)) + yy = xx(2) + end subroutine foo +end program main + diff --git a/Fortran/gfortran/regression/char_initialiser_actual.f90 b/Fortran/gfortran/regression/char_initialiser_actual.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_initialiser_actual.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! Tests passing of character array initialiser as actual argument. +! Fixes PR18109. +! Contributed by Paul Thomas pault@gcc.gnu.org +program char_initialiser + character*5, dimension(3) :: x + character*5, dimension(:), pointer :: y + x=(/"is Ja","ne Fo","nda "/) + call sfoo ("is Ja", x(1)) + call afoo ((/"is Ja","ne Fo","nda "/), x) + y => pfoo ((/"is Ja","ne Fo","nda "/)) + call afoo (y, x) +contains + subroutine sfoo(ch1, ch2) + character*(*) :: ch1, ch2 + if (ch1 /= ch2) STOP 1 + end subroutine sfoo + subroutine afoo(ch1, ch2) + character*(*), dimension(:) :: ch1, ch2 + if (any(ch1 /= ch2)) STOP 2 + end subroutine afoo + function pfoo(ch2) + character*5, dimension(:), target :: ch2 + character*5, dimension(:), pointer :: pfoo + allocate(pfoo(size(ch2))) + pfoo = ch2 + end function pfoo +end program diff --git a/Fortran/gfortran/regression/char_length_1.f90 b/Fortran/gfortran/regression/char_length_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_length_1.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-Wall -std=f2003" } +! Tests the patch for PR27996 and PR27998, in which warnings +! or errors were not emitted when the length of character +! constants was changed silently. +! +! Contributed by Tobias Burnus +! +program test + implicit none + character(10) :: a(3) + character(10) :: b(3)= & + (/ 'Takata ', 'Tanaka', 'Hayashi' /) ! { dg-error "Different CHARACTER" } + character(4) :: c = "abcde" ! { dg-warning "being truncated" } + a = (/ 'Takata', 'Tanaka ', 'Hayashi' /) ! { dg-error "Different CHARACTER" } + a = (/ 'Takata ', 'Tanaka ', 'Hayashi' /) + b = "abc" ! { dg-error "no IMPLICIT" } + c = "abcdefg" ! { dg-warning "will be truncated" } +end program test diff --git a/Fortran/gfortran/regression/char_length_10.f90 b/Fortran/gfortran/regression/char_length_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_length_10.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! Checks the fix for PR33241, in which the assumed character +! length of the parameter was never filled in with that of +! the initializer. +! +! Contributed by Victor Prosolin +! +PROGRAM fptest + IMPLICIT NONE + CHARACTER (LEN=*), DIMENSION(1), PARAMETER :: var = 'a' + CALL parsef (var) +contains + SUBROUTINE parsef (Var) + IMPLICIT NONE + CHARACTER (LEN=*), DIMENSION(:), INTENT(in) :: Var + END SUBROUTINE parsef +END PROGRAM fptest diff --git a/Fortran/gfortran/regression/char_length_11.f90 b/Fortran/gfortran/regression/char_length_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_length_11.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } + + character(len=*), parameter :: s = "foo" + write (*,*) adjustr(s(:)) +end diff --git a/Fortran/gfortran/regression/char_length_12.f90 b/Fortran/gfortran/regression/char_length_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_length_12.f90 @@ -0,0 +1,12 @@ +! { dg-do run } + + implicit none + character(len=3), dimension(3,3), parameter :: & + p = reshape(["xyz", "abc", "mkl", "vpn", "lsd", "epo", "tgv", & + "bbc", "wto"], [3,3]) + character(len=3), dimension(3,3) :: m1 + + m1 = p + if (any (spread (p, 1, 2) /= spread (m1, 1, 2))) STOP 1 + +end diff --git a/Fortran/gfortran/regression/char_length_13.f90 b/Fortran/gfortran/regression/char_length_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_length_13.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! +! PR fortran/38095 +! +! Contributed by Vivek Rao +! +! Compiling the program below gave an ICE +! +module bar + implicit none +contains +elemental function trim_append(xx,yy) result(xy) + character (len=*), intent(in) :: xx,yy + character (len=len(xx) + len(yy)) :: xy + xy = trim(xx) // yy +end function trim_append +function same(xx) result(yy) + character (len=*), intent(in) :: xx(:) + character (len=len(xx)) :: yy(size(xx)) + yy = [xx] +end function same +subroutine foo(labels) + character (len=*), intent(in) :: labels(:) + print*,"size(labels)=",size(labels) +end subroutine foo +subroutine xmain() + call foo(trim_append(["a"],same(["b"]))) +end subroutine xmain +end module bar + +program main + use bar + call xmain() +end program main diff --git a/Fortran/gfortran/regression/char_length_14.f90 b/Fortran/gfortran/regression/char_length_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_length_14.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! PR35937, in which letting the length of 'c' to kind = 8 would +! screw up the interface and would cause an ICE. Note that this is +! actually the example of comment #4. +! +! Contributed by Thomas Koenig +! +program main + implicit none + if (f5 ('1') .ne. "a") STOP 1 + if (len (f5 ('1')) .ne. 1) STOP 1 + if (f5 ('4') .ne. "abcd") STOP 1 + if (len (f5 ('4')) .ne. 4) STOP 1 +contains + function f5 (c) + character(len=1_8) :: c + character(len=scan('123456789', c)) :: f5 + integer :: i + do i = 1, len (f5) + f5(i:i) = char (i+96) + end do + end function f5 +end program main diff --git a/Fortran/gfortran/regression/char_length_15.f90 b/Fortran/gfortran/regression/char_length_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_length_15.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! +! Test the fix for PR38915 in which the character length of the +! temporaries produced in the assignments marked below was set to +! one. +! +! Contributed by Dick Hendrickson +! +program cg0033_41 + type t + sequence + integer i + character(len=9) c + end type t + type (t) L(3),R(3), LL(4), RR(4) + EQUIVALENCE (L,LL) + integer nfv1(3), nfv2(3) + R(1)%c = '123456789' + R(2)%c = 'abcdefghi' + R(3)%c = '!@#$%^&*(' + L%c = R%c + LL(1:3)%c = R%c + LL(4)%c = 'QWERTYUIO' + RR%c = LL%c ! The equivalence forces a dependency + L%c = LL(2:4)%c + if (any (RR(2:4)%c .ne. L%c)) STOP 1 + nfv1 = (/1,2,3/) + nfv2 = nfv1 + L%c = R%c + L(nfv1)%c = L(nfv2)%c ! The vector indices force a dependency + if (any (R%c .ne. L%c)) STOP 2 +end + diff --git a/Fortran/gfortran/regression/char_length_16.f90 b/Fortran/gfortran/regression/char_length_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_length_16.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! +! PR 40822: [4.5 Regression] Internal compiler error when Fortran intrinsic LEN referenced before explicit declaration +! +! Contributed by Mat Cross + +SUBROUTINE SEARCH(ITEMVAL) + CHARACTER (*) :: ITEMVAL + CHARACTER (LEN(ITEMVAL)) :: ITEM + INTRINSIC LEN +END + diff --git a/Fortran/gfortran/regression/char_length_17.f90 b/Fortran/gfortran/regression/char_length_17.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_length_17.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! PR 34145 - the length of the string should be simplified to one, +! no library call for string comparison is necessary. +program main + character (len=5) :: c + integer(kind=8) :: i + i = 3 + c(i:i) = 'a' + c(i+1:i+1) = 'b' + if (c(i:i) /= 'a') STOP 1 + if (c(i+1:i+1) /= 'b') STOP 2 +end program main +! { dg-final { scan-tree-dump-times "gfortran_compare_string" 0 "original" } } diff --git a/Fortran/gfortran/regression/char_length_18.f90 b/Fortran/gfortran/regression/char_length_18.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_length_18.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR 45576 - no ICE for missing optional argument +! Test case supplied by Joost VandeVondele +SUBROUTINE get_r_val() + INTEGER, PARAMETER :: default_string_length=128 + CHARACTER(len=default_string_length) :: c_val + LOGICAL :: check + check = c_val(LEN_TRIM(c_val):LEN_TRIM(c_val))=="]" +END SUBROUTINE get_r_val diff --git a/Fortran/gfortran/regression/char_length_19.f90 b/Fortran/gfortran/regression/char_length_19.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_length_19.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! +! PR fortran/58579 +! +! Contributed by Joost VandeVondele +! +! Was ICEing before due to the patch for PR 58593 +! + subroutine test + CHARACTER(len=20) :: tmpStr + CHARACTER(len=20, kind=4) :: tmpStr4 + INTEGER :: output_unit=6 + WRITE (UNIT=output_unit,FMT="(T2,A,T61,A20)")& + "DFT| Self-interaction correction (SIC)",ADJUSTR(TRIM(tmpstr)) + WRITE (UNIT=output_unit,FMT="(T2,A,T61,A20)")& + 4_"DFT| Self-interaction correction (SIC)",ADJUSTR(TRIM(tmpstr4)) + END + +! +! PR fortran/58593 +! Contributed by Albert Bartok +! +! The PR was overallocating memory. I placed it here to check for a +! variant of the test case above, which takes a slightly differnt code +! patch. Thus, its purpose is just to ensure that it won't ICE. +! +program test_char + + implicit none + integer :: i + + read*, i + print*, trim(test(i)) + + contains + + function test(i) + integer, intent(in) :: i + character(len=i) :: test + + test(1:1) = "A" + endfunction test + +endprogram test_char diff --git a/Fortran/gfortran/regression/char_length_2.f90 b/Fortran/gfortran/regression/char_length_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_length_2.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! Tests the fix for PR 31250. +! The fix for PR fortran/67987 supercedes PR 31250, which removes +! the -Wsurprising option. +! +CHARACTER(len=0) :: c1 ! This is OK. +CHARACTER(len=-1) :: c2 +PARAMETER(I=-100) +CHARACTER(len=I) :: c3 +CHARACTER(len=min(I,500)) :: c4 +CHARACTER(len=max(I,500)) :: d1 ! no warning +CHARACTER(len=5) :: d2 ! no warning + +if (len(c1) .ne. 0) call link_error () +if (len(c2) .ne. len(c1)) call link_error () +if (len(c3) .ne. len(c2)) call link_error () +if (len(c4) .ne. len(c3)) call link_error () + +if (len(d1) .ne. 500) call link_error () +if (len(d2) .ne. 5) call link_error () +END diff --git a/Fortran/gfortran/regression/char_length_20.f90 b/Fortran/gfortran/regression/char_length_20.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_length_20.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! { dg-options "-fcheck=bounds" } +program rabbithole + implicit none + character(len=:), allocatable :: text_block(:) + integer i, ii + character(len=10) :: cten='abcdefghij' + character(len=20) :: ctwenty='abcdefghijabcdefghij' + ii = -6 + text_block=[ character(len=ii) :: cten, ctwenty ] + if (any(len_trim(text_block) /= 0)) STOP 1 +end program rabbithole +! { dg-output "At line 10 of file .*char_length_20.f90.*Fortran runtime warning: Negative character length treated as LEN = 0" } diff --git a/Fortran/gfortran/regression/char_length_21.f90 b/Fortran/gfortran/regression/char_length_21.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_length_21.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +program rabbithole + implicit none + character(len=:), allocatable :: text_block(:) + integer i, ii + character(len=10) :: cten='abcdefghij' + character(len=20) :: ctwenty='abcdefghijabcdefghij' + ii = -6 + text_block = [character(len=ii) :: cten, ctwenty] + if (any(len_trim(text_block) /= 0)) STOP 1 +end program rabbithole diff --git a/Fortran/gfortran/regression/char_length_22.f90 b/Fortran/gfortran/regression/char_length_22.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_length_22.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-O -Wall" } +! PR 94091 - this used to give a bogus warning. +! Test case by "MikeS". +program tester + character(50) cname,fred + fred='1234567890123456789012345678901234567890' ! 40 characters + kk=len_trim(fred) + cname=fred(5:kk) + print *,kk,cname +end program tester diff --git a/Fortran/gfortran/regression/char_length_23.f90 b/Fortran/gfortran/regression/char_length_23.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_length_23.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! +! Test the fix for PRs 96100 and 96101. +! +! Contributed by Gerhardt Steinmetz +! +program p + type t + character(:), allocatable :: c(:) + end type + type(t) :: x + character(:), allocatable :: w + +! PR96100 + allocate(x%c(2), source = 'def') + associate (y => [x%c(1:1)]) ! ICE + print *,y + end associate + +! PR96101 + associate (y => ([w(:)])) + print *, y ! ICE + end associate + +end diff --git a/Fortran/gfortran/regression/char_length_3.f90 b/Fortran/gfortran/regression/char_length_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_length_3.f90 @@ -0,0 +1,52 @@ +! { dg-do compile } +! PR fortran/25071 +! Check if actual argument is too short +! + program test + implicit none + character(len=10) :: v + character(len=10), target :: x + character(len=20), target :: y + character(len=30), target :: z + character(len=10), pointer :: ptr1 + character(len=20), pointer :: ptr2 + character(len=30), pointer :: ptr3 + character(len=10), allocatable :: alloc1(:) + character(len=20), allocatable :: alloc2(:) + character(len=30), allocatable :: alloc3(:) + call foo(v) ! { dg-warning "actual argument shorter than of dummy" } + call foo(x) ! { dg-warning "actual argument shorter than of dummy" } + call foo(y) + call foo(z) + ptr1 => x + call foo(ptr1) ! { dg-warning "actual argument shorter than of dummy" } + call bar(ptr1) ! { dg-warning "Character length mismatch" } + ptr2 => y + call foo(ptr2) + call bar(ptr2) + ptr3 => z + call foo(ptr3) + call bar(ptr3) ! { dg-warning "Character length mismatch" } + allocate(alloc1(1)) + allocate(alloc2(1)) + allocate(alloc3(1)) + call arr(alloc1) ! { dg-warning "Character length mismatch" } + call arr(alloc2) + call arr(alloc3) ! { dg-warning "Character length mismatch" } + contains + subroutine foo(y) + character(len=20) :: y + y = 'hello world' + end subroutine + subroutine bar(y) + character(len=20),pointer :: y + y = 'hello world' + end subroutine + subroutine arr(y) + character(len=20),allocatable :: y(:) + y(1) = 'hello world' + end subroutine + end + + ! Remove -Wstringop-overflow warnings. + ! { dg-prune-output "overflows the destination" } diff --git a/Fortran/gfortran/regression/char_length_4.f90 b/Fortran/gfortran/regression/char_length_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_length_4.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! tests the fix for PR31540, in which the character lengths in +! parentheses were not resolved. +! +! Contributed by Tobias Burnus +! + subroutine pfb() + implicit none + external pfname1, pfname2 + character ((136)) pfname1 + character ((129+7)) pfname2 + return + end diff --git a/Fortran/gfortran/regression/char_length_5.f90 b/Fortran/gfortran/regression/char_length_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_length_5.f90 @@ -0,0 +1,60 @@ +! { dg-do run } +! Tests the fix for PR31867, in which the interface evaluation +! of the character length of 'join' (ie. the length available in +! the caller) was wrong. +! +! Contributed by +! +module util_mod + implicit none +contains + function join (words, sep) result(str) + character (len=*), intent(in) :: words(:),sep + character (len = (size (words) - 1) * len_trim (sep) + & + sum (len_trim (words))) :: str + integer :: i,nw + nw = size (words) + str = "" + if (nw < 1) then + return + else + str = words(1) + end if + do i=2,nw + str = trim (str) // trim (sep) // words(i) + end do + end function join +end module util_mod +! +program xjoin + use util_mod, only: join + implicit none + integer yy + character (len=5) :: words(5:8) = (/"two ","three","four ","five "/), sep = "^#^" + character (len=5) :: words2(4) = (/"bat ","ball ","goal ","stump"/), sep2 = "&" + + if (join (words, sep) .ne. "two^#^three^#^four^#^five") STOP 1 + if (len (join (words, sep)) .ne. 25) STOP 2 + + if (join (words(5:6), sep) .ne. "two^#^three") STOP 3 + if (len (join (words(5:6), sep)) .ne. 11) STOP 4 + + if (join (words(7:8), sep) .ne. "four^#^five") STOP 5 + if (len (join (words(7:8), sep)) .ne. 11) STOP 6 + + if (join (words(5:7:2), sep) .ne. "two^#^four") STOP 7 + if (len (join (words(5:7:2), sep)) .ne. 10) STOP 8 + + if (join (words(6:8:2), sep) .ne. "three^#^five") STOP 9 + if (len (join (words(6:8:2), sep)) .ne. 12) STOP 10 + + if (join (words2, sep2) .ne. "bat&ball&goal&stump") STOP 11 + if (len (join (words2, sep2)) .ne. 19) STOP 12 + + if (join (words2(1:2), sep2) .ne. "bat&ball") STOP 13 + if (len (join (words2(1:2), sep2)) .ne. 8) STOP 14 + + if (join (words2(2:4:2), sep2) .ne. "ball&stump") STOP 15 + if (len (join (words2(2:4:2), sep2)) .ne. 10) STOP 16 + +end program xjoin diff --git a/Fortran/gfortran/regression/char_length_6.f90 b/Fortran/gfortran/regression/char_length_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_length_6.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! +program test + character(2_8) :: c(2) + logical :: l(2) + + c = "aa" + l = c .eq. "aa" + if (any (.not. l)) STOP 1 + + call foo ([c(1)]) + l = c .eq. "aa" + if (any (.not. l)) STOP 2 + +contains + + subroutine foo (c) + character(2) :: c(1) + end subroutine foo + +end diff --git a/Fortran/gfortran/regression/char_length_7.f90 b/Fortran/gfortran/regression/char_length_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_length_7.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! Test the fix for PR31879 in which the concatenation operators below +! would cause ICEs because the character lengths were never resolved. +! +! Contributed by Vivek Rao +! +module str_mod + character(3) :: mz(2) = (/"fgh","ijk"/) +contains + function ccopy(yy) result(xy) + character (len=*), intent(in) :: yy(:) + character (len=5) :: xy(size(yy)) + xy = yy + end function ccopy +end module str_mod +! +program xx + use str_mod, only: ccopy, mz + implicit none + character(2) :: z = "zz" + character(3) :: zz(2) = (/"abc","cde"/) + character(2) :: ans(2) + integer :: i = 2, j = 3 + if (any(ccopy("_&_"//(/"A","B"/)//"?") .ne. (/"_&_A?","_&_B?"/))) STOP 1 + if (any(ccopy(z//zz) .ne. (/"zzabc","zzcde"/))) STOP 2 + if (any(ccopy(z//zz(:)(1:2)) .ne. (/"zzab ","zzcd "/))) STOP 3 + if (any(ccopy(z//mz(:)(2:3)) .ne. (/"zzgh ","zzjk "/))) STOP 4 + +! This was another bug, uncovered when the PR was fixed. + if (any(ccopy(z//mz(:)(i:j)) .ne. (/"zzgh ","zzjk "/))) STOP 5 +end program xx diff --git a/Fortran/gfortran/regression/char_length_8.f90 b/Fortran/gfortran/regression/char_length_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_length_8.f90 @@ -0,0 +1,69 @@ +! { dg-do run } +! Test the fix for PR31197 and PR31258 in which the substrings below +! would cause ICEs because the character lengths were never resolved. +! +! Contributed by Joost VandeVondele +! and Thomas Koenig +! + CHARACTER(LEN=3), DIMENSION(10) :: Z + CHARACTER(LEN=3), DIMENSION(3,3) :: W + integer :: ctr = 0 + call test_reshape + call test_eoshift + call test_cshift + call test_spread + call test_transpose + call test_pack + call test_unpack + call test_pr31197 + if (ctr .ne. 8) STOP 1 +contains + subroutine test_reshape + Z(:)="123" + if (any (RESHAPE(Z(:)(2:2),(/5,2/)) .ne. "2")) STOP 2 + ctr = ctr + 1 + end subroutine + subroutine test_eoshift + CHARACTER(LEN=1), DIMENSION(10) :: chk + chk(1:8) = "5" + chk(9:10) = " " + Z(:)="456" + if (any (EOSHIFT(Z(:)(2:2),2) .ne. chk)) STOP 3 + ctr = ctr + 1 + END subroutine + subroutine test_cshift + Z(:)="901" + if (any (CSHIFT(Z(:)(2:2),2) .ne. "0")) STOP 4 + ctr = ctr + 1 + end subroutine + subroutine test_spread + Z(:)="789" + if (any (SPREAD(Z(:)(2:2),dim=1,ncopies=2) .ne. "8")) STOP 5 + ctr = ctr + 1 + end subroutine + subroutine test_transpose + W(:, :)="abc" + if (any (TRANSPOSE(W(:,:)(1:2)) .ne. "ab")) STOP 6 + ctr = ctr + 1 + end subroutine + subroutine test_pack + W(:, :)="def" + if (any (pack(W(:,:)(2:3),mask=.true.) .ne. "ef")) STOP 7 + ctr = ctr + 1 + end subroutine + subroutine test_unpack + logical, dimension(5,2) :: mask + Z(:)="hij" + mask = .true. + if (any (unpack(Z(:)(2:2),mask,' ') .ne. "i")) STOP 8 + ctr = ctr + 1 + end subroutine + subroutine test_pr31197 + TYPE data + CHARACTER(LEN=3) :: A = "xyz" + END TYPE + TYPE(data), DIMENSION(10), TARGET :: T + if (any (TRANSPOSE(RESHAPE(T(:)%A(2:2),(/5,2/))) .ne. "y")) STOP 9 + ctr = ctr + 1 + end subroutine +END diff --git a/Fortran/gfortran/regression/char_length_9.f90 b/Fortran/gfortran/regression/char_length_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_length_9.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! Test the fix for a regression caused by the first fix of PR31879. +! Reported by Tobias Burnus +! +MODULE input_val_types + IMPLICIT NONE + INTEGER, PARAMETER :: default_string_length=80 + TYPE val_type + CHARACTER(len=default_string_length), DIMENSION(:), POINTER :: c_val + END TYPE val_type +CONTAINS + SUBROUTINE val_get (val, c_val) + TYPE(val_type), POINTER :: val + CHARACTER(LEN=*), INTENT(out) :: c_val + INTEGER :: i, l_out + i=1 + c_val((i-1)*default_string_length+1:MIN (l_out, i*default_string_length)) = & + val%c_val(i)(1:MIN (80, l_out-(i-1)*default_string_length)) + END SUBROUTINE val_get +END MODULE input_val_types diff --git a/Fortran/gfortran/regression/char_pack_1.f90 b/Fortran/gfortran/regression/char_pack_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_pack_1.f90 @@ -0,0 +1,59 @@ +! Test (non-scalar) pack for character arrays. +! { dg-do run } +program main + implicit none + integer, parameter :: n1 = 3, n2 = 4, nv = 10, slen = 9 + character (len = slen), dimension (n1, n2) :: a + character (len = slen), dimension (nv) :: vector + logical, dimension (n1, n2) :: mask + integer :: i1, i2, i + + do i2 = 1, n2 + do i1 = 1, n1 + a (i1, i2) = 'abc'(i1:i1) // 'defg'(i2:i2) // 'cantrip' + end do + end do + mask (1, :) = (/ .true., .false., .true., .true. /) + mask (2, :) = (/ .true., .false., .false., .false. /) + mask (3, :) = (/ .false., .true., .true., .true. /) + + do i = 1, nv + vector (i) = 'crespo' // '0123456789'(i:i) + end do + + call test1 (pack (a, mask)) + call test2 (pack (a, mask, vector)) +contains + subroutine test1 (b) + character (len = slen), dimension (:) :: b + + i = 0 + do i2 = 1, n2 + do i1 = 1, n1 + if (mask (i1, i2)) then + i = i + 1 + if (b (i) .ne. a (i1, i2)) STOP 1 + end if + end do + end do + if (size (b, 1) .ne. i) STOP 2 + end subroutine test1 + + subroutine test2 (b) + character (len = slen), dimension (:) :: b + + if (size (b, 1) .ne. nv) STOP 3 + i = 0 + do i2 = 1, n2 + do i1 = 1, n1 + if (mask (i1, i2)) then + i = i + 1 + if (b (i) .ne. a (i1, i2)) STOP 4 + end if + end do + end do + do i = i + 1, nv + if (b (i) .ne. vector (i)) STOP 5 + end do + end subroutine test2 +end program main diff --git a/Fortran/gfortran/regression/char_pack_2.f90 b/Fortran/gfortran/regression/char_pack_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_pack_2.f90 @@ -0,0 +1,53 @@ +! Test scalar pack for character arrays. +! { dg-do run } +program main + implicit none + integer, parameter :: n1 = 3, n2 = 4, nv = 16, slen = 9 + character (len = slen), dimension (n1, n2) :: a + character (len = slen), dimension (nv) :: vector + logical :: mask + integer :: i1, i2, i + + do i2 = 1, n2 + do i1 = 1, n1 + a (i1, i2) = 'abc'(i1:i1) // 'defg'(i2:i2) // 'cantrip' + end do + end do + + do i = 1, nv + vector (i) = 'crespo' // '0123456789abcdef'(i:i) + end do + + mask = .true. + call test1 (pack (a, mask)) + call test2 (pack (a, mask, vector)) +contains + subroutine test1 (b) + character (len = slen), dimension (:) :: b + + i = 0 + do i2 = 1, n2 + do i1 = 1, n1 + i = i + 1 + if (b (i) .ne. a (i1, i2)) STOP 1 + end do + end do + if (size (b, 1) .ne. i) STOP 2 + end subroutine test1 + + subroutine test2 (b) + character (len = slen), dimension (:) :: b + + if (size (b, 1) .ne. nv) STOP 3 + i = 0 + do i2 = 1, n2 + do i1 = 1, n1 + i = i + 1 + if (b (i) .ne. a (i1, i2)) STOP 4 + end do + end do + do i = i + 1, nv + if (b (i) .ne. vector (i)) STOP 5 + end do + end subroutine test2 +end program main diff --git a/Fortran/gfortran/regression/char_pointer_assign.f90 b/Fortran/gfortran/regression/char_pointer_assign.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_pointer_assign.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +program char_pointer_assign +! Test character pointer assignments, required +! to fix PR18890 and PR21297 +! Provided by Paul Thomas pault@gcc.gnu.org + implicit none + character*4, target :: t1 + character*4, target :: t2(4) =(/"lmno","lmno","lmno","lmno"/) + character*4 :: const + character*4, pointer :: c1, c3 + character*4, pointer :: c2(:), c4(:) + allocate (c3, c4(4)) +! Scalars first. + c3 = "lmno" ! pointer = constant + t1 = c3 ! target = pointer + c1 => t1 ! pointer =>target + c1(2:3) = "nm" + c3 = c1 ! pointer = pointer + c3(1:1) = "o" + c3(4:4) = "l" + c1 => c3 ! pointer => pointer + if (t1 /= "lnmo") STOP 1 + if (c1 /= "onml") STOP 2 + +! Now arrays. + c4 = "lmno" ! pointer = constant + t2 = c4 ! target = pointer + c2 => t2 ! pointer =>target + const = c2(1) + const(2:3) ="nm" ! c2(:)(2:3) = "nm" is still broken + c2 = const + c4 = c2 ! pointer = pointer + const = c4(1) + const(1:1) ="o" ! c4(:)(1:1) = "o" is still broken + const(4:4) ="l" ! c4(:)(4:4) = "l" is still broken + c4 = const + c2 => c4 ! pointer => pointer + if (any (t2 /= "lnmo")) STOP 3 + if (any (c2 /= "onml")) STOP 4 + deallocate (c3, c4) +end program char_pointer_assign + diff --git a/Fortran/gfortran/regression/char_pointer_assign_2.f90 b/Fortran/gfortran/regression/char_pointer_assign_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_pointer_assign_2.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! Tests the fix for PRs20895 and 25030, where pointer assignments +! of different length characters were accepted. + character(4), target :: ch1(2) + character(4), pointer :: ch2(:) + character(5), pointer :: ch3(:) + + ch2 => ch1 ! Check correct is OK + ch3 => ch1 ! { dg-error "Unequal character lengths \\(5/4\\)" } + +end diff --git a/Fortran/gfortran/regression/char_pointer_assign_3.f90 b/Fortran/gfortran/regression/char_pointer_assign_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_pointer_assign_3.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! PR fortran/31803 +! Assigning a substring to a pointer + +program test + implicit none + character (len = 7), target :: textt + character (len = 7), pointer :: textp + character (len = 5), pointer :: textp2 + textp => textt + textp2 => textt(1:5) + if(len(textp) /= 7) STOP 1 + if(len(textp2) /= 5) STOP 2 + textp = 'aaaaaaa' + textp2 = 'bbbbbbb' + if(textp /= 'bbbbbaa') STOP 3 + if(textp2 /= 'bbbbb') STOP 4 +end program test diff --git a/Fortran/gfortran/regression/char_pointer_assign_4.f90 b/Fortran/gfortran/regression/char_pointer_assign_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_pointer_assign_4.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Unequal character length" } + +! PR fortran/31822 +! Verify that runtime checks for matching character length +! in pointer assignment work. + +! Contributed by Tobias Burnus + +program ptr + implicit none + character(len=10), target :: s1 + character(len=5), pointer :: p1 + integer, volatile :: i + i = 8 + p1 => s1(1:i) +end program ptr + +! { dg-output "Unequal character lengths \\(5/8\\)" } diff --git a/Fortran/gfortran/regression/char_pointer_assign_5.f90 b/Fortran/gfortran/regression/char_pointer_assign_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_pointer_assign_5.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Unequal character length" } + +! PR fortran/31822 +! Verify that runtime checks for matching character length +! in pointer assignment work. + +! Contributed by Tobias Burnus + +program ptr + implicit none + character(len=10), target :: s1 + call bar((/ s1, s1 /)) +contains + subroutine bar(s) + character(len=*),target :: s(2) + character(len=17),pointer :: p(:) + p => s + end subroutine bar +end program ptr + +! { dg-output "Unequal character lengths \\(17/10\\)" } diff --git a/Fortran/gfortran/regression/char_pointer_assign_6.f90 b/Fortran/gfortran/regression/char_pointer_assign_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_pointer_assign_6.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR 31821 +program main + character (len=4), pointer:: s1 + character (len=20), pointer :: p1 + character (len=4) :: c + s1 = 'abcd' + p1 => s1(2:3) ! { dg-error "Unequal character lengths \\(20/2\\)" } + p1 => c(1:) ! { dg-error "Pointer assignment target" } + p1 => c(:4) ! { dg-error "Pointer assignment target" } +end diff --git a/Fortran/gfortran/regression/char_pointer_assign_7.f90 b/Fortran/gfortran/regression/char_pointer_assign_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_pointer_assign_7.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! PR fortran/50549 - should reject pointer assignments of different lengths +! in structure constructors + +program test + implicit none + type t + character(2), pointer :: p2 + end type t + type t2 + character(2), pointer :: p(:) + end type t2 + type td + character(:), pointer :: pd + end type td + interface + function f1 () + character(1), pointer :: f1 + end function f1 + function f2 () + character(2), pointer :: f2 + end function f2 + end interface + + character(1), target :: p1 + character(1), pointer :: q1(:) + character(2), pointer :: q2(:) + type(t) :: u + type(t2) :: u2 + type(td) :: v + u = t(p1) ! { dg-error "Unequal character lengths" } + u = t(f1()) ! { dg-error "Unequal character lengths" } + u = t(f2()) ! OK + u2 = t2(q1) ! { dg-error "Unequal character lengths" } + u2 = t2(q2) ! OK + v = td(p1) ! OK + v = td(f1()) ! OK +end diff --git a/Fortran/gfortran/regression/char_pointer_assign_icb_1.f90 b/Fortran/gfortran/regression/char_pointer_assign_icb_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_pointer_assign_icb_1.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! Reduced testcase from PR 50892, regressed due to r256284 (PR 78534) +subroutine test + use, intrinsic :: ISO_C_Binding, only: c_ptr + type(c_ptr) :: text + character(len=:), pointer :: ftext + ftext => FortranChar(text) +contains + function FortranChar ( C ) + type(c_ptr), intent(in), value :: C + character(len=10), pointer :: FortranChar + end function FortranChar +end subroutine test diff --git a/Fortran/gfortran/regression/char_pointer_comp_assign.f90 b/Fortran/gfortran/regression/char_pointer_comp_assign.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_pointer_comp_assign.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! This test the fix of PR18283, where assignments of scalar, +! character pointer components of derived types caused an ICE. +! It also checks that the array counterparts remain operational. +! Contributed by Paul Thomas pault@gcc.gnu.org +! +program char_pointer_comp_assign + implicit none + type :: dt + character (len=4), pointer :: scalar + character (len=4), pointer :: array(:) + end type dt + type (dt) :: a + character (len=4), target :: scalar_t ="abcd" + character (len=4), target :: array_t(2) = (/"abcd","efgh"/) + +! Do assignments first + allocate (a%scalar, a%array(2)) + a%scalar = scalar_t + if (a%scalar /= "abcd") STOP 1 + a%array = array_t + if (any(a%array /= (/"abcd","efgh"/))) STOP 2 + deallocate (a%scalar, a%array) + +! Now do pointer assignments. + a%scalar => scalar_t + if (a%scalar /= "abcd") STOP 3 + a%array => array_t + if (any(a%array /= (/"abcd","efgh"/))) STOP 4 + +end program char_pointer_comp_assign diff --git a/Fortran/gfortran/regression/char_pointer_dependency.f90 b/Fortran/gfortran/regression/char_pointer_dependency.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_pointer_dependency.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! Test assignments from character pointer functions with dependencies +! are correctly resolved. +! Provided by Paul Thomas pault@gcc.gnu.org +program char_pointer_dependency + implicit none + character*4, pointer :: c2(:) + allocate (c2(2)) + c2 = (/"abcd","efgh"/) + c2 = afoo (c2) + if (c2(1) /= "efgh") STOP 1 + if (c2(2) /= "abcd") STOP 2 + deallocate (c2) +contains + function afoo (ac0) result (ac1) + integer :: j + character*4 :: ac0(:) + character*4, pointer :: ac1(:) + allocate (ac1(2)) + do j = 1,2 + ac1(j) = ac0(3-j) + end do + end function afoo +end program char_pointer_dependency diff --git a/Fortran/gfortran/regression/char_pointer_dummy.f90 b/Fortran/gfortran/regression/char_pointer_dummy.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_pointer_dummy.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +program char_pointer_dummy +! Test character pointer dummy arguments, required +! to fix PR16939 and PR18689 +! Provided by Paul Thomas pault@gcc.gnu.org + implicit none + character*4 :: c0 + character*4, pointer :: c1 + character*4, pointer :: c2(:) + allocate (c1, c2(1)) +! Check that we have not broken non-pointer characters. + c0 = "wxyz" + call foo (c0) +! Now the pointers + c1 = "wxyz" + call sfoo (c1) + c2 = "wxyz" + call afoo (c2) + deallocate (c1, c2) +contains + subroutine foo (cc1) + character*4 :: cc1 + if (cc1 /= "wxyz") STOP 1 + end subroutine foo + subroutine sfoo (sc1) + character*4, pointer :: sc1 + if (sc1 /= "wxyz") STOP 2 + end subroutine sfoo + subroutine afoo (ac1) + character*4, pointer :: ac1(:) + if (ac1(1) /= "wxyz") STOP 3 + end subroutine afoo +end program char_pointer_dummy + diff --git a/Fortran/gfortran/regression/char_pointer_func.f90 b/Fortran/gfortran/regression/char_pointer_func.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_pointer_func.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +program char_pointer_func +! Test assignments from character pointer functions, required +! to fix PR17192 and PR17202 +! Provided by Paul Thomas pault@gcc.gnu.org + implicit none + character*4 :: c0 + character*4, pointer :: c1 + character*4, pointer :: c2(:) + allocate (c1, c2(1)) +! Check that we have not broken non-pointer characters. + c0 = foo () + if (c0 /= "abcd") STOP 1 +! Value assignments + c1 = sfoo () + if (c1 /= "abcd") STOP 2 + c2 = afoo (c0) + if (c2(1) /= "abcd") STOP 3 + deallocate (c1, c2) +! Pointer assignments + c1 => sfoo () + if (c1 /= "abcd") STOP 4 + c2 => afoo (c0) + if (c2(1) /= "abcd") STOP 5 + deallocate (c1, c2) +contains + function foo () result (cc1) + character*4 :: cc1 + cc1 = "abcd" + end function foo + function sfoo () result (sc1) + character*4, pointer :: sc1 + allocate (sc1) + sc1 = "abcd" + end function sfoo + function afoo (c0) result (ac1) + character*4 :: c0 + character*4, pointer :: ac1(:) + allocate (ac1(1)) + ac1 = "abcd" + end function afoo +end program char_pointer_func diff --git a/Fortran/gfortran/regression/char_reshape_1.f90 b/Fortran/gfortran/regression/char_reshape_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_reshape_1.f90 @@ -0,0 +1,43 @@ +! Test reshape for character arrays. +! { dg-do run } +program main + implicit none + integer, parameter :: n = 20, slen = 9 + character (len = slen), dimension (n) :: a, pad + integer, dimension (3) :: shape, order + integer :: i + + do i = 1, n + a (i) = 'abcdefghijklmnopqrstuvwxyz'(i:i+6) + pad (i) = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'(i:i+6) + end do + + shape = (/ 4, 6, 5 /) + order = (/ 3, 1, 2 /) + call test (reshape (a, shape, pad, order)) +contains + subroutine test (b) + character (len = slen), dimension (:, :, :) :: b + integer :: i1, i2, i3, ai, padi + + do i = 1, 3 + if (size (b, i) .ne. shape (i)) STOP 1 + end do + ai = 0 + padi = 0 + do i2 = 1, shape (2) + do i1 = 1, shape (1) + do i3 = 1, shape (3) + if (ai .lt. n) then + ai = ai + 1 + if (b (i1, i2, i3) .ne. a (ai)) STOP 2 + else + padi = padi + 1 + if (padi .gt. n) padi = 1 + if (b (i1, i2, i3) .ne. pad (padi)) STOP 3 + end if + end do + end do + end do + end subroutine test +end program main diff --git a/Fortran/gfortran/regression/char_result_1.f90 b/Fortran/gfortran/regression/char_result_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_result_1.f90 @@ -0,0 +1,114 @@ +! Related to PR 15326. Try calling string functions whose lengths depend +! on the lengths of other strings. +! { dg-do run } +pure function double (string) + character (len = *), intent (in) :: string + character (len = len (string) * 2) :: double + double = string // string +end function double + +function f1 (string) + character (len = *) :: string + character (len = len (string)) :: f1 + f1 = '' +end function f1 + +function f2 (string1, string2) + character (len = *) :: string1 + character (len = len (string1) - 20) :: string2 + character (len = len (string1) + len (string2) / 2) :: f2 + f2 = '' +end function f2 + +program main + implicit none + + interface + pure function double (string) + character (len = *), intent (in) :: string + character (len = len (string) * 2) :: double + end function double + function f1 (string) + character (len = *) :: string + character (len = len (string)) :: f1 + end function f1 + function f2 (string1, string2) + character (len = *) :: string1 + character (len = len (string1) - 20) :: string2 + character (len = len (string1) + len (string2) / 2) :: f2 + end function f2 + end interface + + integer :: a + character (len = 80) :: text + character (len = 70), target :: textt + character (len = 70), pointer :: textp + + a = 42 + textp => textt + + call test (f1 (text), 80) + call test (f2 (text, text), 110) + call test (f3 (text), 115) + call test (f4 (text), 192) + call test (f5 (text), 160) + call test (f6 (text), 39) + + call test (f1 (textp), 70) + call test (f2 (textp, text), 95) + call test (f3 (textp), 105) + call test (f4 (textp), 192) + call test (f5 (textp), 140) + call test (f6 (textp), 29) + + call indirect (textp) +contains + function f3 (string) + integer, parameter :: l1 = 30 + character (len = *) :: string + character (len = len (string) + l1 + 5) :: f3 + f3 = '' + end function f3 + + function f4 (string) + character (len = len (text) - 10) :: string + character (len = len (string) + len (text) + a) :: f4 + f4 = '' + end function f4 + + function f5 (string) + character (len = *) :: string + character (len = len (double (string))) :: f5 + f5 = '' + end function f5 + + function f6 (string) + character (len = *) :: string + character (len = len (string (a:))) :: f6 + f6 = '' + end function f6 + + subroutine indirect (text2) + character (len = *) :: text2 + + call test (f1 (text), 80) + call test (f2 (text, text), 110) + call test (f3 (text), 115) + call test (f4 (text), 192) + call test (f5 (text), 160) + call test (f6 (text), 39) + + call test (f1 (text2), 70) + call test (f2 (text2, text2), 95) + call test (f3 (text2), 105) + call test (f4 (text2), 192) + call test (f5 (text2), 140) + call test (f6 (text2), 29) + end subroutine indirect + + subroutine test (string, length) + character (len = *) :: string + integer, intent (in) :: length + if (len (string) .ne. length) STOP 1 + end subroutine test +end program main diff --git a/Fortran/gfortran/regression/char_result_10.f90 b/Fortran/gfortran/regression/char_result_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_result_10.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! PR 18883: Fake result variables of non-constant length, with ENTRY +function s_to_c(chars) + character, pointer :: chars(:) + character(len=len(chars)) :: s_to_c, s_to_c_2 + s_to_c = 'a' + return +entry s_to_c_2(chars) + s_to_c_2 = 'b' + return +end function s_to_c + +program huj + + implicit none + interface + function s_to_c(chars) + character, pointer :: chars(:) + character(len=len(chars)) :: s_to_c + end function s_to_c + + function s_to_c_2(chars) + character, pointer :: chars(:) + character(len=len(chars)) :: s_to_c_2 + end function s_to_c_2 + end interface + + character, pointer :: c(:) + character(3) :: s + + allocate(c(5)) + c = (/"a", "b", "c" /) + s = s_to_c(c) + s = s_to_c_2(c) + +end program huj diff --git a/Fortran/gfortran/regression/char_result_11.f90 b/Fortran/gfortran/regression/char_result_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_result_11.f90 @@ -0,0 +1,115 @@ +! { dg-do link } +! PR 23675: Character function of module-variable length +! PR 25716: Implicit kind conversions in in expressions written to *.mod-files. +module cutils + + implicit none + private + + type t + integer :: k = 25 + integer :: kk(3) = (/30, 40, 50 /) + end type t + + integer :: m1 = 25, m2 = 25, m3 = 25, m4 = 25, m5 = 25 + integer :: n5 = 3, n7 = 3, n9 = 3 + integer(1) :: n1 = 3, n2 = 3, n3 = 3, n4 = 3, n6 = 3, n8 = 3 + character(10) :: s = "abcdefghij" + integer :: x(4) = (/ 30, 40, 50, 60 /) + type(t), save :: tt1(5), tt2(5) + + public :: IntToChar1, IntToChar2, IntToChar3, IntToChar4, IntToChar5, & + IntToChar6, IntToChar7, IntToChar8 + +contains + + pure integer function get_k(tt) + type(t), intent(in) :: tt + + get_k = tt%k + end function get_k + + function IntToChar1(integerValue) result(a) + integer, intent(in) :: integerValue + character(len=m1) :: a + + write(a, *) integerValue + end function IntToChar1 + + function IntToChar2(integerValue) result(a) + integer, intent(in) :: integerValue + character(len=m2+n1) :: a + + write(a, *) integerValue + end function IntToChar2 + + function IntToChar3(integerValue) result(a) + integer, intent(in) :: integerValue + character(len=iachar(s(n2:n3))) :: a + + write(a, *) integerValue + end function IntToChar3 + + function IntToChar4(integerValue) result(a) + integer, intent(in) :: integerValue + character(len=tt1(n4)%k) :: a + + write(a, *) integerValue + end function IntToChar4 + + function IntToChar5(integerValue) result(a) + integer, intent(in) :: integerValue + character(len=maxval((/m3, n5/))) :: a + + write(a, *) integerValue + end function IntToChar5 + + function IntToChar6(integerValue) result(a) + integer, intent(in) :: integerValue + character(len=x(n6)) :: a + + write(a, *) integerValue + end function IntToChar6 + + function IntToChar7(integerValue) result(a) + integer, intent(in) :: integerValue + character(len=tt2(min(m4, n7, 2))%kk(n8)) :: a + + write(a, *) integerValue + end function IntToChar7 + + function IntToChar8(integerValue) result(a) + integer, intent(in) :: integerValue + character(len=get_k(t(m5, (/31, n9, 53/)))) :: a + + write(a, *) integerValue + end function IntToChar8 + +end module cutils + + +program test + + use cutils + + implicit none + character(25) :: str + + str = IntToChar1(3) + print *, str + str = IntToChar2(3) + print *, str + str = IntToChar3(3) + print *, str + str = IntToChar4(3) + print *, str + str = IntToChar5(3) + print *, str + str = IntToChar6(3) + print *, str + str = IntToChar7(3) + print *, str + str = IntToChar8(3) + print *, str + +end program test diff --git a/Fortran/gfortran/regression/char_result_12.f90 b/Fortran/gfortran/regression/char_result_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_result_12.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! Tests the fix for PR29912, in which the call to JETTER +! would cause a segfault because a temporary was not being written. +! +! Contributed by Philip Mason +! + program testat + character(len=4) :: ctemp(2) + character(len=512) :: temper(2) + ! + !------------------------ + !'This was OK.' + !------------------------ + temper(1) = 'doncaster' + temper(2) = 'uxbridge' + ctemp = temper + if (any (ctemp /= ["donc", "uxbr"])) STOP 1 + ! + !------------------------ + !'This went a bit wrong.' + !------------------------ + ctemp = jetter(1,2) + if (any (ctemp /= ["donc", "uxbr"])) STOP 2 + + contains + function jetter(id1,id2) + character(len=512) :: jetter(id1:id2) + jetter(id1) = 'doncaster' + jetter(id2) = 'uxbridge' + end function jetter + end program testat diff --git a/Fortran/gfortran/regression/char_result_13.f90 b/Fortran/gfortran/regression/char_result_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_result_13.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! Tests the fix for PR38538, where the character length for the +! argument of 'func' was not calculated. +! +! Contributed by Vivek Rao +! +module abc + implicit none +contains + subroutine xmain (i, j) + integer i, j + call foo (func ("_"//bar (i)//"x"//bar (j)//"x"), "_abcxabx") ! original was elemental + call foo (nfunc("_"//bar (j)//"x"//bar (i)//"x"), "_abxabcx") + end subroutine xmain +! + function bar (i) result(yy) + integer i, j, k + character (len = i) :: yy(2) + do j = 1, size (yy, 1) + do k = 1, i + yy(j)(k:k) = char (96+k) + end do + end do + end function bar +! + elemental function func (yy) result(xy) + character (len = *), intent(in) :: yy + character (len = len (yy)) :: xy + xy = yy + end function func +! + function nfunc (yy) result(xy) + character (len = *), intent(in) :: yy(:) + character (len = len (yy)) :: xy(size (yy)) + xy = yy + end function nfunc +! + subroutine foo(cc, teststr) + character (len=*), intent(in) :: cc(:) + character (len=*), intent(in) :: teststr + if (any (cc .ne. teststr)) STOP 1 + end subroutine foo +end module abc + + use abc + call xmain(3, 2) +end diff --git a/Fortran/gfortran/regression/char_result_14.f90 b/Fortran/gfortran/regression/char_result_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_result_14.f90 @@ -0,0 +1,103 @@ +! { dg-do run } +! +! Tests the fix for PR44265. This is the original test with the addition +! of the check of the issue found in comment #1 of the PR. +! +! Contributed by Ian Harvey +! Ian also contributed the first version of the fix. +! +! The original version of the bug +MODULE Fruits0 + IMPLICIT NONE + PRIVATE + PUBLIC :: Get0 +CONTAINS + FUNCTION Get0(i) RESULT(s) + CHARACTER(*), PARAMETER :: names(3) = [ & + 'Apple ', & + 'Orange ', & + 'Mango ' ]; + INTEGER, INTENT(IN) :: i + CHARACTER(LEN_TRIM(names(i))) :: s + !**** + s = names(i) + END FUNCTION Get0 +END MODULE Fruits0 +! +! Version that came about from sorting other issues. +MODULE Fruits + IMPLICIT NONE + PRIVATE + character (20) :: buffer + CHARACTER(*), PARAMETER :: names(4) = [ & + 'Apple ', & + 'Orange ', & + 'Mango ', & + 'Pear ' ]; + PUBLIC :: Get, SGet, fruity2, fruity3, buffer +CONTAINS +! This worked previously + subroutine fruity3 + write (buffer, '(i2,a)') len (Get (4)), Get (4) + end +! Original function in the PR + FUNCTION Get(i) RESULT(s) + INTEGER, INTENT(IN) :: i + CHARACTER(LEN_trim(names(i))) :: s + !**** + s = names(i) + END FUNCTION Get +! Check that dummy is OK + Subroutine Sget(i, s) + CHARACTER(*), PARAMETER :: names(4) = [ & + 'Apple ', & + 'Orange ', & + 'Mango ', & + 'Pear ' ]; + INTEGER, INTENT(IN) :: i + CHARACTER(LEN_trim(names(i))), intent(out) :: s + !**** + s = names(i) + write (buffer, '(i2,a)') len (s), s + END subroutine SGet +! This would fail with undefined references to mangled 'names' during linking + subroutine fruity2 + write (buffer, '(i2,a)') len (Get (3)), Get (3) + end +END MODULE Fruits + +PROGRAM WheresThatbLinkingConstantGone + use Fruits0 + USE Fruits + IMPLICIT NONE + character(7) :: arg = "" + integer :: i + +! Test the fix for the original bug + if (len (Get0(1)) .ne. 5) STOP 1 + if (Get0(2) .ne. "Orange") STOP 2 + +! Test the fix for the subsequent issues + call fruity + if (trim (buffer) .ne. " 6Orange") STOP 3 + call fruity2 + if (trim (buffer) .ne. " 5Mango") STOP 4 + call fruity3 + if (trim (buffer) .ne. " 4Pear") STOP 5 + do i = 3, 4 + call Sget (i, arg) + if (i == 3) then + if (trim (buffer) .ne. " 5Mango") STOP 6 + if (trim (arg) .ne. "Mango") STOP 7 + else + if (trim (buffer) .ne. " 4Pear") STOP 8 +! Since arg is fixed length in this scope, it gets over-written +! by s, which in this case is length 4. Thus, the 'o' remains. + if (trim (arg) .ne. "Pearo") STOP 9 + end if + enddo +contains + subroutine fruity + write (buffer, '(i2,a)') len (Get (2)), Get (2) + end +END PROGRAM WheresThatbLinkingConstantGone diff --git a/Fortran/gfortran/regression/char_result_15.f90 b/Fortran/gfortran/regression/char_result_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_result_15.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! +! Tests the fix for PR44265. This test arose because of an issue found +! during the development of the fix; namely the clash between the normal +! module parameter and that found in the specification expression for +! 'Get'. +! +! Contributed by Paul Thomas +! +MODULE Fruits + IMPLICIT NONE + PRIVATE + character (20) :: buffer + PUBLIC :: Get, names, fruity, buffer + CHARACTER(len=7), PARAMETER :: names(3) = [ & + 'Pomme ', & + 'Orange ', & + 'Mangue ' ]; +CONTAINS + FUNCTION Get(i) RESULT(s) + CHARACTER(len=7), PARAMETER :: names(3) = [ & + 'Apple ', & + 'Orange ', & + 'Mango ' ]; + INTEGER, INTENT(IN) :: i + CHARACTER(LEN_TRIM(names(i))) :: s + s = names(i) + END FUNCTION Get + subroutine fruity (i) + integer :: i + write (buffer, '(i2,a)') len (Get (i)), Get (i) + end subroutine +END MODULE Fruits + +PROGRAM WheresThatbLinkingConstantGone + USE Fruits + IMPLICIT NONE + integer :: i + write (buffer, '(i2,a)') len (Get (1)), Get (1) + if (trim (buffer) .ne. " 5Apple") STOP 1 + call fruity(3) + if (trim (buffer) .ne. " 5Mango") STOP 2 + if (trim (names(3)) .ne. "Mangue") STOP 3 +END PROGRAM WheresThatbLinkingConstantGone diff --git a/Fortran/gfortran/regression/char_result_16.f90 b/Fortran/gfortran/regression/char_result_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_result_16.f90 @@ -0,0 +1,16 @@ +! PR fortran/78757 +! { dg-do compile } +! { dg-options "-O1" } + +program pr78757 + implicit none + character (len = 30), target :: x + character (len = 30), pointer :: s + s => foo (30_8) +contains + function foo (i) + integer (8) :: i + character (len = i), pointer :: foo + foo => x + end function foo +end program pr78757 diff --git a/Fortran/gfortran/regression/char_result_17.f90 b/Fortran/gfortran/regression/char_result_17.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_result_17.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! PR fortran/84615 +! Charlen should always be the ABI defined character length type +! regardless of which kind it is declared as in the source. +program TestStringTools + character(len=52) :: txt + character(len=1), dimension(52) :: chararr = & + (/(char(i+64),char(i+96), i = 1,26)/) + txt = chararray2string(chararr) + if (txt .ne. "AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUuVvWwXxYyZz") & + STOP 1 +contains + function chararray2string(chararray) result(text) + character(len=1), dimension(:) :: chararray ! input + character(len=int(size(chararray, 1), kind=8)) :: text ! output + do i = 1,size(chararray,1) + text(i:i) = chararray (i) + end do + end function chararray2string +end program TestStringTools diff --git a/Fortran/gfortran/regression/char_result_18.f90 b/Fortran/gfortran/regression/char_result_18.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_result_18.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! Tests the fix for PR80657. +! +! Contributed by Vittorio Zecca +! +function f(x) +implicit character(len(f)) (x) ! { dg-error "Self reference in character length" } +character(len(x)) f +end diff --git a/Fortran/gfortran/regression/char_result_19.f90 b/Fortran/gfortran/regression/char_result_19.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_result_19.f90 @@ -0,0 +1,24 @@ +! { dg-do preprocess } +! { dg-additional-options "-cpp" } +! +! Test the fix for PR86248 +! +! Contributed by Bill Long +! +program test + use test_module + implicit none + integer :: i + character(:), allocatable :: chr + do i = 0, 2 + chr = func_1 (i) + select case (i) + case (0) + if (chr .ne. 'el0') stop i + case (1) + if (chr .ne. 'el11') stop i + case (2) + if (chr .ne. 'el2') stop i + end select + end do +end program test diff --git a/Fortran/gfortran/regression/char_result_2.f90 b/Fortran/gfortran/regression/char_result_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_result_2.f90 @@ -0,0 +1,107 @@ +! Like char_result_1.f90, but the string arguments are pointers. +! { dg-do run } +pure function double (string) + character (len = *), intent (in) :: string + character (len = len (string) * 2) :: double + double = string // string +end function double + +function f1 (string) + character (len = *), pointer :: string + character (len = len (string)) :: f1 + f1 = '' +end function f1 + +function f2 (string1, string2) + character (len = *), pointer :: string1 + character (len = len (string1) - 20), pointer :: string2 + character (len = len (string1) + len (string2) / 2) :: f2 + f2 = '' +end function f2 + +program main + implicit none + + interface + pure function double (string) + character (len = *), intent (in) :: string + character (len = len (string) * 2) :: double + end function double + function f1 (string) + character (len = *), pointer :: string + character (len = len (string)) :: f1 + end function f1 + function f2 (string1, string2) + character (len = *), pointer :: string1 + character (len = len (string1) - 20), pointer :: string2 + character (len = len (string1) + len (string2) / 2) :: f2 + end function f2 + end interface + + integer :: a + character (len = 80) :: text + character (len = 70), target :: textt + character (len = 70), pointer :: textp + character (len = 50), pointer :: textp2 + + a = 42 + textp => textt + textp2 => textt(1:50) + + call test (f1 (textp), 70) + call test (f2 (textp, textp), 95) + call test (f3 (textp), 105) + call test (f4 (textp), 192) + call test (f5 (textp), 140) + call test (f6 (textp), 29) + + call indirect (textp2) +contains + function f3 (string) + integer, parameter :: l1 = 30 + character (len = *), pointer :: string + character (len = len (string) + l1 + 5) :: f3 + f3 = '' + end function f3 + + function f4 (string) + character (len = len (text) - 10), pointer :: string + character (len = len (string) + len (text) + a) :: f4 + f4 = '' + end function f4 + + function f5 (string) + character (len = *), pointer :: string + character (len = len (double (string))) :: f5 + f5 = '' + end function f5 + + function f6 (string) + character (len = *), pointer :: string + character (len = len (string (a:))) :: f6 + f6 = '' + end function f6 + + subroutine indirect (textp2) + character (len = 50), pointer :: textp2 + + call test (f1 (textp), 70) + call test (f2 (textp, textp), 95) + call test (f3 (textp), 105) + call test (f4 (textp), 192) + call test (f5 (textp), 140) + call test (f6 (textp), 29) + + call test (f1 (textp2), 50) + call test (f2 (textp2, textp), 65) + call test (f3 (textp2), 85) + call test (f5 (textp2), 100) + call test (f6 (textp2), 9) + end subroutine indirect + + subroutine test (string, length) + character (len = *) :: string + integer, intent (in) :: length + if (len (string) .ne. length) STOP 1 + end subroutine test +end program main diff --git a/Fortran/gfortran/regression/char_result_3.f90 b/Fortran/gfortran/regression/char_result_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_result_3.f90 @@ -0,0 +1,78 @@ +! Related to PR 15326. Try calling string functions whose lengths involve +! some sort of array calculation. +! { dg-do run } +pure elemental function double (x) + integer, intent (in) :: x + integer :: double + double = x * 2 +end function double + +program main + implicit none + + interface + pure elemental function double (x) + integer, intent (in) :: x + integer :: double + end function double + end interface + + integer, dimension (100:104), target :: a + integer, dimension (:), pointer :: ap + integer :: i, lower + + a = (/ (i + 5, i = 0, 4) /) + ap => a + lower = 11 + + call test (f1 (a), 35) + call test (f1 (ap), 35) + call test (f1 ((/ 5, 10, 50 /)), 65) + call test (f1 (a (101:103)), 21) + + call test (f2 (a), 115) + call test (f2 (ap), 115) + call test (f2 ((/ 5, 10, 50 /)), 119) + call test (f2 (a (101:103)), 116) + + call test (f3 (a), 60) + call test (f3 (ap), 60) + call test (f3 ((/ 5, 10, 50 /)), 120) + call test (f3 (a (101:103)), 30) + + call test (f4 (a, 13, 1), 21) + call test (f4 (ap, 13, 2), 14) + call test (f4 ((/ 5, 10, 50 /), 12, 1), 60) + call test (f4 (a (101:103), 12, 1), 15) +contains + function f1 (array) + integer, dimension (10:) :: array + character (len = sum (array)) :: f1 + f1 = '' + end function f1 + + function f2 (array) + integer, dimension (10:) :: array + character (len = array (11) + a (104) + 100) :: f2 + f2 = '' + end function f2 + + function f3 (array) + integer, dimension (:) :: array + character (len = sum (double (array (2:)))) :: f3 + f3 = '' + end function f3 + + function f4 (array, upper, stride) + integer, dimension (10:) :: array + integer :: upper, stride + character (len = sum (array (lower:upper:stride))) :: f4 + f4 = '' + end function f4 + + subroutine test (string, length) + character (len = *) :: string + integer, intent (in) :: length + if (len (string) .ne. length) STOP 1 + end subroutine test +end program main diff --git a/Fortran/gfortran/regression/char_result_4.f90 b/Fortran/gfortran/regression/char_result_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_result_4.f90 @@ -0,0 +1,62 @@ +! Like char_result_3.f90, but the array arguments are pointers. +! { dg-do run } +pure elemental function double (x) + integer, intent (in) :: x + integer :: double + double = x * 2 +end function double + +program main + implicit none + + interface + pure elemental function double (x) + integer, intent (in) :: x + integer :: double + end function double + end interface + + integer, dimension (100:104), target :: a + integer, dimension (:), pointer :: ap + integer :: i, lower + + a = (/ (i + 5, i = 0, 4) /) + ap => a + lower = lbound(a,dim=1) + + call test (f1 (ap), 35) + call test (f2 (ap), 115) + call test (f3 (ap), 60) + call test (f4 (ap, 104, 2), 21) +contains + function f1 (array) + integer, dimension (:), pointer :: array + character (len = sum (array)) :: f1 + f1 = '' + end function f1 + + function f2 (array) + integer, dimension (:), pointer :: array + character (len = array (101) + a (104) + 100) :: f2 + f2 = '' + end function f2 + + function f3 (array) + integer, dimension (:), pointer :: array + character (len = sum (double (array (101:)))) :: f3 + f3 = '' + end function f3 + + function f4 (array, upper, stride) + integer, dimension (:), pointer :: array + integer :: upper, stride + character (len = sum (array (lower:upper:stride))) :: f4 + f4 = '' + end function f4 + + subroutine test (string, length) + character (len = *) :: string + integer, intent (in) :: length + if (len (string) .ne. length) STOP 1 + end subroutine test +end program main diff --git a/Fortran/gfortran/regression/char_result_5.f90 b/Fortran/gfortran/regression/char_result_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_result_5.f90 @@ -0,0 +1,137 @@ +! Related to PR 15326. Test calls to string functions whose lengths +! depend on various types of scalar value. +! { dg-do run } +pure function select (selector, iftrue, iffalse) + logical, intent (in) :: selector + integer, intent (in) :: iftrue, iffalse + integer :: select + + if (selector) then + select = iftrue + else + select = iffalse + end if +end function select + +program main + implicit none + + interface + pure function select (selector, iftrue, iffalse) + logical, intent (in) :: selector + integer, intent (in) :: iftrue, iffalse + integer :: select + end function select + end interface + + type pair + integer :: left, right + end type pair + + integer, target :: i + integer, pointer :: ip + real, target :: r + real, pointer :: rp + logical, target :: l + logical, pointer :: lp + complex, target :: c + complex, pointer :: cp + character, target :: ch + character, pointer :: chp + type (pair), target :: p + type (pair), pointer :: pp + + character (len = 10) :: dig + + i = 100 + r = 50.5 + l = .true. + c = (10.9, 11.2) + ch = '1' + p%left = 40 + p%right = 50 + + ip => i + rp => r + lp => l + cp => c + chp => ch + pp => p + + dig = '1234567890' + + call test (f1 (i), 200) + call test (f1 (ip), 200) + call test (f1 (-30), 60) + call test (f1 (i / (-4)), 50) + + call test (f2 (r), 100) + call test (f2 (rp), 100) + call test (f2 (70.1), 140) + call test (f2 (r / 4), 24) + call test (f2 (real (i)), 200) + + call test (f3 (l), 50) + call test (f3 (lp), 50) + call test (f3 (.false.), 55) + call test (f3 (i < 30), 55) + + call test (f4 (c), 10) + call test (f4 (cp), 10) + call test (f4 (cmplx (60.0, r)), 60) + call test (f4 (cmplx (r, 1.0)), 50) + + call test (f5 (ch), 11) + call test (f5 (chp), 11) + call test (f5 ('23'), 12) + call test (f5 (dig (3:)), 13) + call test (f5 (dig (10:)), 10) + + call test (f6 (p), 145) + call test (f6 (pp), 145) + call test (f6 (pair (20, 10)), 85) + call test (f6 (pair (i / 2, 1)), 106) +contains + function f1 (i) + integer :: i + character (len = abs (i) * 2) :: f1 + f1 = '' + end function f1 + + function f2 (r) + real :: r + character (len = floor (r) * 2) :: f2 + f2 = '' + end function f2 + + function f3 (l) + logical :: l + character (len = select (l, 50, 55)) :: f3 + f3 = '' + end function f3 + + function f4 (c) + complex :: c + character (len = int (c)) :: f4 + f4 = '' + end function f4 + + function f5 (c) + character :: c + character (len = scan ('123456789', c) + 10) :: f5 + f5 = '' + end function f5 + + function f6 (p) + type (pair) :: p + integer :: i + character (len = sum ((/ p%left, p%right, (i, i = 1, 10) /))) :: f6 + f6 = '' + end function f6 + + subroutine test (string, length) + character (len = *) :: string + integer, intent (in) :: length + if (len (string) .ne. length) STOP 1 + end subroutine test +end program main diff --git a/Fortran/gfortran/regression/char_result_6.f90 b/Fortran/gfortran/regression/char_result_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_result_6.f90 @@ -0,0 +1,107 @@ +! Like char_result_5.f90, but the function arguments are pointers to scalars. +! { dg-do run } +pure function select (selector, iftrue, iffalse) + logical, intent (in) :: selector + integer, intent (in) :: iftrue, iffalse + integer :: select + + if (selector) then + select = iftrue + else + select = iffalse + end if +end function select + +program main + implicit none + + interface + pure function select (selector, iftrue, iffalse) + logical, intent (in) :: selector + integer, intent (in) :: iftrue, iffalse + integer :: select + end function select + end interface + + type pair + integer :: left, right + end type pair + + integer, target :: i + integer, pointer :: ip + real, target :: r + real, pointer :: rp + logical, target :: l + logical, pointer :: lp + complex, target :: c + complex, pointer :: cp + character, target :: ch + character, pointer :: chp + type (pair), target :: p + type (pair), pointer :: pp + + i = 100 + r = 50.5 + l = .true. + c = (10.9, 11.2) + ch = '1' + p%left = 40 + p%right = 50 + + ip => i + rp => r + lp => l + cp => c + chp => ch + pp => p + + call test (f1 (ip), 200) + call test (f2 (rp), 100) + call test (f3 (lp), 50) + call test (f4 (cp), 10) + call test (f5 (chp), 11) + call test (f6 (pp), 145) +contains + function f1 (i) + integer, pointer :: i + character (len = abs (i) * 2) :: f1 + f1 = '' + end function f1 + + function f2 (r) + real, pointer :: r + character (len = floor (r) * 2) :: f2 + f2 = '' + end function f2 + + function f3 (l) + logical, pointer :: l + character (len = select (l, 50, 55)) :: f3 + f3 = '' + end function f3 + + function f4 (c) + complex, pointer :: c + character (len = int (c)) :: f4 + f4 = '' + end function f4 + + function f5 (c) + character, pointer :: c + character (len = scan ('123456789', c) + 10) :: f5 + f5 = '' + end function f5 + + function f6 (p) + type (pair), pointer :: p + integer :: i + character (len = sum ((/ p%left, p%right, (i, i = 1, 10) /))) :: f6 + f6 = '' + end function f6 + + subroutine test (string, length) + character (len = *) :: string + integer, intent (in) :: length + if (len (string) .ne. length) STOP 1 + end subroutine test +end program main diff --git a/Fortran/gfortran/regression/char_result_7.f90 b/Fortran/gfortran/regression/char_result_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_result_7.f90 @@ -0,0 +1,47 @@ +! Related to PR 15326. Try calling string functions whose lengths depend +! on a dummy procedure. +! { dg-do run } +integer pure function double (x) + integer, intent (in) :: x + double = x * 2 +end function double + +program main + implicit none + + interface + integer pure function double (x) + integer, intent (in) :: x + end function double + end interface + + call test (f1 (double, 100), 200) + + call indirect (double) +contains + function f1 (fn, i) + integer :: i + interface + integer pure function fn (x) + integer, intent (in) :: x + end function fn + end interface + character (len = fn (i)) :: f1 + f1 = '' + end function f1 + + subroutine indirect (fn) + interface + integer pure function fn (x) + integer, intent (in) :: x + end function fn + end interface + call test (f1 (fn, 100), 200) + end subroutine indirect + + subroutine test (string, length) + character (len = *) :: string + integer, intent (in) :: length + if (len (string) .ne. length) STOP 1 + end subroutine test +end program main diff --git a/Fortran/gfortran/regression/char_result_8.f90 b/Fortran/gfortran/regression/char_result_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_result_8.f90 @@ -0,0 +1,51 @@ +! Related to PR 15326. Compare functions that return string pointers with +! functions that return strings. +! { dg-do run } +program main + implicit none + + character (len = 30), target :: string + + call test (f1 (), 30) + call test (f2 (50), 50) + call test (f3 (), 30) + call test (f4 (70), 70) + + call indirect (100) +contains + function f1 () + character (len = 30) :: f1 + f1 = '' + end function f1 + + function f2 (i) + integer :: i + character (len = i) :: f2 + f2 = '' + end function f2 + + function f3 () + character (len = 30), pointer :: f3 + f3 => string + end function f3 + + function f4 (i) + integer :: i + character (len = i), pointer :: f4 + f4 => string + end function f4 + + subroutine indirect (i) + integer :: i + call test (f1 (), 30) + call test (f2 (i), i) + call test (f3 (), 30) + call test (f4 (i), i) + end subroutine indirect + + subroutine test (string, length) + character (len = *) :: string + integer, intent (in) :: length + if (len (string) .ne. length) STOP 1 + end subroutine test +end program main diff --git a/Fortran/gfortran/regression/char_result_9.f90 b/Fortran/gfortran/regression/char_result_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_result_9.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! PR 18883: Fake result variables of non-constant length, in module +module foo +contains + function s_to_c(chars) + character, pointer :: chars(:) + character(len=len(chars)) :: s_to_c + s_to_c = 'a' + end function s_to_c +end module foo + +program huj + + use foo + + implicit none + character, pointer :: c(:) + character(3) :: s + + allocate(c(5)) + c = (/"a", "b", "c" /) + s = s_to_c(c) + +end program huj diff --git a/Fortran/gfortran/regression/char_result_mod_19.f90 b/Fortran/gfortran/regression/char_result_mod_19.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_result_mod_19.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-additional-sources char_result_19.f90 } +! +! Module for char_result_19.f90 +! Tests fix for PR86248 +! +module test_module + implicit none + public :: func_1 + private + character(len=*),dimension(0:2),parameter :: darray = (/"el0 ","el11","el2 "/) +contains + function func_1 (func_1_input) result(f) + integer, intent(in) :: func_1_input + character(len = len_trim (darray(func_1_input))) :: f + f = darray(func_1_input) + end function func_1 +end module test_module diff --git a/Fortran/gfortran/regression/char_spread_1.f90 b/Fortran/gfortran/regression/char_spread_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_spread_1.f90 @@ -0,0 +1,32 @@ +! Test spread for character arrays. +! { dg-do run } +program main + implicit none + integer, parameter :: n1 = 3, n2 = 10, n3 = 4, slen = 9 + character (len = slen), dimension (n1, n3) :: a + integer :: i1, i2, i3 + + do i3 = 1, n3 + do i1 = 1, n1 + a (i1, i3) = 'abc'(i1:i1) // 'defg'(i3:i3) // 'cantrip' + end do + end do + + call test (spread (a, 2, n2)) +contains + subroutine test (b) + character (len = slen), dimension (:, :, :) :: b + + if (size (b, 1) .ne. n1) STOP 1 + if (size (b, 2) .ne. n2) STOP 2 + if (size (b, 3) .ne. n3) STOP 3 + + do i3 = 1, n3 + do i2 = 1, n2 + do i1 = 1, n1 + if (b (i1, i2, i3) .ne. a (i1, i3)) STOP 4 + end do + end do + end do + end subroutine test +end program main diff --git a/Fortran/gfortran/regression/char_transpose_1.f90 b/Fortran/gfortran/regression/char_transpose_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_transpose_1.f90 @@ -0,0 +1,29 @@ +! Test transpose for character arrays. +! { dg-do run } +program main + implicit none + integer, parameter :: n1 = 3, n2 = 4, slen = 9 + character (len = slen), dimension (n1, n2) :: a + integer :: i1, i2 + + do i2 = 1, n2 + do i1 = 1, n1 + a (i1, i2) = 'abc'(i1:i1) // 'defg'(i2:i2) // 'cantrip' + end do + end do + + call test (transpose (a)) +contains + subroutine test (b) + character (len = slen), dimension (:, :) :: b + + if (size (b, 1) .ne. n2) STOP 1 + if (size (b, 2) .ne. n1) STOP 2 + + do i2 = 1, n2 + do i1 = 1, n1 + if (b (i2, i1) .ne. a (i1, i2)) STOP 3 + end do + end do + end subroutine test +end program main diff --git a/Fortran/gfortran/regression/char_type_len.f90 b/Fortran/gfortran/regression/char_type_len.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_type_len.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! Testcase for PR fortran/25681 +program char_type_len + integer,parameter :: n = 9 + type foo_t + character (len = 80) :: bar (1) + character (len = 75) :: gee (n) + end type foo_t + type(foo_t) :: foo + + if (len(foo%bar) /= 80 .or. len(foo%gee) /= 75) STOP 1 +end program char_type_len diff --git a/Fortran/gfortran/regression/char_type_len_2.f90 b/Fortran/gfortran/regression/char_type_len_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_type_len_2.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR31251 Non-integer character length leads to segfault +! Submitted by Jerry DeLisle +! +! Updated to deal with the fix for PR fortran/67805. +! + character(len=2.3) :: s ! { dg-error "INTEGER expression expected" } + character(kind=1,len=4.3) :: t ! { dg-error "INTEGER expression expected" } + character(len=,,7.2,kind=1) :: u ! { dg-error "Syntax error in CHARACTER declaration" } + character(len=7,kind=2) :: v ! ! { dg-error "Kind 2 is not supported for CHARACTER" } + character(kind=2) :: w ! ! { dg-error "Kind 2 is not supported for CHARACTER" } + character(kind=2,len=7) :: x ! ! { dg-error "Kind 2 is not supported for CHARACTER" } + end diff --git a/Fortran/gfortran/regression/char_unpack_1.f90 b/Fortran/gfortran/regression/char_unpack_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_unpack_1.f90 @@ -0,0 +1,44 @@ +! Test unpack0 for character arrays. +! { dg-do run } +program main + implicit none + integer, parameter :: n1 = 3, n2 = 4, nv = 10, slen = 9 + character (len = slen), dimension (n1, n2) :: field + character (len = slen), dimension (nv) :: vector + logical, dimension (n1, n2) :: mask + integer :: i1, i2, i + + do i2 = 1, n2 + do i1 = 1, n1 + field (i1, i2) = 'abc'(i1:i1) // 'defg'(i2:i2) // 'cantrip' + end do + end do + mask (1, :) = (/ .true., .false., .true., .true. /) + mask (2, :) = (/ .true., .false., .false., .false. /) + mask (3, :) = (/ .false., .true., .true., .true. /) + + do i = 1, nv + vector (i) = 'crespo' // '0123456789'(i:i) + end do + + call test (unpack (vector, mask, field)) +contains + subroutine test (a) + character (len = slen), dimension (:, :) :: a + + if (size (a, 1) .ne. n1) STOP 1 + if (size (a, 2) .ne. n2) STOP 2 + + i = 0 + do i2 = 1, n2 + do i1 = 1, n1 + if (mask (i1, i2)) then + i = i + 1 + if (a (i1, i2) .ne. vector (i)) STOP 3 + else + if (a (i1, i2) .ne. field (i1, i2)) STOP 4 + end if + end do + end do + end subroutine test +end program main diff --git a/Fortran/gfortran/regression/char_unpack_2.f90 b/Fortran/gfortran/regression/char_unpack_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/char_unpack_2.f90 @@ -0,0 +1,40 @@ +! Test unpack1 for character arrays. +! { dg-do run } +program main + implicit none + integer, parameter :: n1 = 3, n2 = 4, nv = 10, slen = 9 + character (len = slen) :: field + character (len = slen), dimension (nv) :: vector + logical, dimension (n1, n2) :: mask + integer :: i1, i2, i + + field = 'broadside' + mask (1, :) = (/ .true., .false., .true., .true. /) + mask (2, :) = (/ .true., .false., .false., .false. /) + mask (3, :) = (/ .false., .true., .true., .true. /) + + do i = 1, nv + vector (i) = 'crespo' // '0123456789'(i:i) + end do + + call test (unpack (vector, mask, field)) +contains + subroutine test (a) + character (len = slen), dimension (:, :) :: a + + if (size (a, 1) .ne. n1) STOP 1 + if (size (a, 2) .ne. n2) STOP 2 + + i = 0 + do i2 = 1, n2 + do i1 = 1, n1 + if (mask (i1, i2)) then + i = i + 1 + if (a (i1, i2) .ne. vector (i)) STOP 3 + else + if (a (i1, i2) .ne. field) STOP 4 + end if + end do + end do + end subroutine test +end program main diff --git a/Fortran/gfortran/regression/character_array_constructor_1.f90 b/Fortran/gfortran/regression/character_array_constructor_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/character_array_constructor_1.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! Tests the fix for PR27113, in which character structure +! components would produce the TODO compilation error "complex +! character array constructors". +! +! Test based on part of tonto-2.2; +! Contributed by Paul Thomas +! + type BASIS_TYPE + character(len=8) :: label + end type + + type(BASIS_TYPE), dimension(:), pointer :: ptr + character(8), dimension(2) :: carray + + allocate (ptr(2)) + ptr(1)%label = "Label 1" + ptr(2)%label = "Label 2" + +! This is the original bug + call read_library_data_((/ptr%label/)) + + carray(1) = "Label 3" + carray(2) = "Label 4" + +! Mix a character array with the character component of a derived type pointer array. + call read_library_data_((/carray, ptr%label/)) + +! Finally, add a constant (character(8)). + call read_library_data_((/carray, ptr%label, "Label 5 "/)) + +contains + + subroutine read_library_data_ (chr) + character(*), dimension(:) :: chr + character(len = len(chr)) :: tmp + if (size(chr,1) == 2) then + if (any (chr .ne. (/"Label 1", "Label 2"/))) STOP 1 + elseif (size(chr,1) == 4) then + if (any (chr .ne. (/"Label 3", "Label 4","Label 1", "Label 2"/))) STOP 2 + elseif (size(chr,1) == 5) then + if (any (chr .ne. (/"Label 3", "Label 4","Label 1", "Label 2", "Label 5"/))) & + STOP 3 + end if + end subroutine read_library_data_ + +end diff --git a/Fortran/gfortran/regression/character_array_dummy_1.f90 b/Fortran/gfortran/regression/character_array_dummy_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/character_array_dummy_1.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! +! PR fortran/105381 +! Infinite recursion with array references of character dummy arguments. +! +! Contributed by Harald Anlauf + +MODULE m + implicit none + integer, parameter :: ncrit = 8 + integer, parameter :: nterm = 7 +contains + + subroutine new_thin_rule (rule1) + character(*),intent(in) ,optional :: rule1(ncrit) + character(len=8) :: rules (ncrit,nterm) + rules = '' + if (present (rule1)) rules(:,1) = rule1 ! <-- compile time hog + end subroutine new_thin_rule + +end module m diff --git a/Fortran/gfortran/regression/character_assign_1.f90 b/Fortran/gfortran/regression/character_assign_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/character_assign_1.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! Tests the fix for PR35702, which caused an ICE because the types in the assignment +! were not translated to be the same. +! +! Contributed by Dick Hendrickson +! +MODULE TESTS + TYPE UNSEQ + CHARACTER(1) :: C + END TYPE UNSEQ +CONTAINS + SUBROUTINE CG0028 (TDA1L, TDA1R, nf0, nf1, nf2, nf3) + TYPE(UNSEQ) TDA1L(NF3) + TDA1L(NF1:NF2:NF1)%C = TDA1L(NF0+2:NF3:NF2/2)%C + END SUBROUTINE +END MODULE TESTS diff --git a/Fortran/gfortran/regression/character_comparison_1.f90 b/Fortran/gfortran/regression/character_comparison_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/character_comparison_1.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! { dg-options "-O -fdump-tree-original" } +program main + implicit none + character(len=4) :: c + integer :: n + integer :: i + common /foo/ i + + n = 0 + i = 0 + c = 'abcd' + n = n + 1 ; if (c == c) call yes + n = n + 1 ; if (c >= c) call yes + n = n + 1 ; if (c <= c) call yes + n = n + 1 ; if (c .eq. c) call yes + n = n + 1 ; if (c .ge. c) call yes + n = n + 1 ; if (c .le. c) call yes + if (c /= c) STOP 1 + if (c > c) STOP 2 + if (c < c) STOP 3 + if (c .ne. c) STOP 4 + if (c .gt. c) STOP 5 + if (c .lt. c) STOP 6 + if (n /= i) STOP 7 +end program main + +subroutine yes + implicit none + common /foo/ i + integer :: i + i = i + 1 +end subroutine yes + +! { dg-final { scan-tree-dump-times "gfortran_compare_string" 0 "original" } } + diff --git a/Fortran/gfortran/regression/character_comparison_2.f90 b/Fortran/gfortran/regression/character_comparison_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/character_comparison_2.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! { dg-options "-O -fdump-tree-original" } +program main + implicit none + character(len=4) :: c + integer :: n + integer :: i + integer :: k1, k2 + common /foo/ i + + n = 0 + i = 0 + k1 = 1 + k2 = 3 + c = 'abcd' + n = n + 1 ; if (c(1:2) == c(1:2)) call yes + n = n + 1 ; if (c(k1:k2) >= c(k1:k2)) call yes + n = n + 1 ; if (c(:2) <= c(1:2)) call yes + n = n + 1 ; if (c(k2:) .eq. c(k2:4)) call yes + n = n + 1 ; if (c(:) .ge. c) call yes + n = n + 1 ; if (c .le. c) call yes + if (c(1:2) /= c(1:2)) STOP 1 + if (c(k1:k2) > c(k1:k2)) STOP 2 + if (c(:2) < c(1:2)) STOP 3 + if (c(:) .ne. c) STOP 4 + if (c(:2) .gt. c(1:2)) STOP 5 + if (c(1:2) .lt. c(:2)) STOP 6 + if (n /= i) STOP 7 +end program main + +subroutine yes + implicit none + common /foo/ i + integer :: i + i = i + 1 +end subroutine yes + +! { dg-final { scan-tree-dump-times "gfortran_compare_string" 0 "original" } } + diff --git a/Fortran/gfortran/regression/character_comparison_3.f90 b/Fortran/gfortran/regression/character_comparison_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/character_comparison_3.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +program main + implicit none + character(len=4) :: c + integer :: i + integer :: k1, k2, k3, k4, k11, k22, k33, k44 + + k1 = 1 + k2 = 2 + k3 = 3 + k4 = 4 + k11 = 1 + k22 = 2 + k33 = 3 + k44 = 4 + c = 'abcd' + if (c(2:) /= c(k2:k4)) STOP 1 + if (c(k2:k4) /= c(k22:)) STOP 2 + if (c(2:3) == c(1:2)) STOP 3 + if (c(1:2) == c(2:3)) STOP 4 + if (c(k1:) == c(k2:)) STOP 5 + if (c(:3) == c(:k4)) STOP 6 + if (c(:k4) == c(:3)) STOP 7 + if (c(:k3) == c(:k44)) STOP 8 +end program main + +! { dg-final { scan-tree-dump-times "gfortran_compare_string" 6 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_memcmp" 2 "original" } } + diff --git a/Fortran/gfortran/regression/character_comparison_4.f90 b/Fortran/gfortran/regression/character_comparison_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/character_comparison_4.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! { dg-options "-O -fdump-tree-original" } +program main + implicit none + character(len=4) :: c, d + integer :: n + integer :: i + common /foo/ i + + n = 0 + i = 0 + c = 'abcd' + d = 'efgh' + + n = n + 1 ; if ('a' // c == 'a' // c) call yes + n = n + 1 ; if (c // 'a' == c // 'a') call yes + n = n + 1; if ('b' // c > 'a' // d) call yes + n = n + 1; if (c // 'b' > c // 'a') call yes + + if ('a' // c /= 'a' // c) STOP 1 + if ('a' // c // 'b' == 'a' // c // 'a') STOP 2 + if ('b' // c == 'a' // c) STOP 3 + if (c // 'a' == c // 'b') STOP 4 + if (c // 'a ' /= c // 'a') STOP 5 + if (c // 'b' /= c // 'b ') STOP 6 + + if (n /= i) STOP 7 +end program main + +subroutine yes + implicit none + common /foo/ i + integer :: i + i = i + 1 +end subroutine yes + +! { dg-final { scan-tree-dump-times "gfortran_compare_string" 0 "original" } } + diff --git a/Fortran/gfortran/regression/character_comparison_5.f90 b/Fortran/gfortran/regression/character_comparison_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/character_comparison_5.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-options "-O -fdump-tree-original" } +program main + implicit none + character(len=4) :: c, d + integer :: n + integer :: i + common /foo/ i + + n = 0 + i = 0 + c = 'abcd' + d = 'efgh' + if (c // 'a' >= d // 'a') STOP 1 + if ('a' // c >= 'a' // d) STOP 2 +end program main + +! { dg-final { scan-tree-dump-times "gfortran_concat_string" 0 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_memcmp" 2 "original" } } + diff --git a/Fortran/gfortran/regression/character_comparison_6.f90 b/Fortran/gfortran/regression/character_comparison_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/character_comparison_6.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-options "-O -fdump-tree-original" } +program main + implicit none + character(len=4) :: c + integer :: n + integer :: i + common /foo/ i + + n = 0 + i = 0 + c = 'abcd' + if ('a ' // c == 'a' // c) STOP 1 + if ('a' // c == 'a ' // c) STOP 2 +end program main + +! { dg-final { scan-tree-dump-times "gfortran_concat_string" 4 "original" } } +! { dg-final { scan-tree-dump-times "gfortran_compare_string" 2 "original" } } + diff --git a/Fortran/gfortran/regression/character_comparison_7.f90 b/Fortran/gfortran/regression/character_comparison_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/character_comparison_7.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! { dg-options "-O -fdump-tree-original" } +! Test that expressions in subroutine calls are also optimized +program main + implicit none + character(len=4) :: c + c = 'abcd' + call yes(c == c) + call no(c /= c) +end program main + +subroutine yes(a) + implicit none + logical, intent(in) :: a + if (.not. a) STOP 1 +end subroutine yes + +subroutine no(a) + implicit none + logical, intent(in) :: a + if (a) STOP 2 +end subroutine no + +! { dg-final { scan-tree-dump-times "gfortran_compare_string" 0 "original" } } + diff --git a/Fortran/gfortran/regression/character_comparison_8.f90 b/Fortran/gfortran/regression/character_comparison_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/character_comparison_8.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! { dg-options "-O -fdump-tree-original" } +! Check for compile-time optimization of LLE and friends. +program main + character(3) :: a + a = 'ab' + if (.not. LLE(a,a)) STOP 1 + if (LLT(a,a)) STOP 2 + if (.not. LGE(a,a)) STOP 3 + if (LGT(a,a)) STOP 4 +end program main +! { dg-final { scan-tree-dump-times "gfortran_compare_string" 0 "original" } } + diff --git a/Fortran/gfortran/regression/character_comparison_9.f90 b/Fortran/gfortran/regression/character_comparison_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/character_comparison_9.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +program main + character (len=2) :: a, b + character (kind=4,len=4) :: c,d + a = 'ab' + b = 'aa' + if (a < b) STOP 1 + c = 4_"aaaa" + d = 4_"aaab" + if (c == d) STOP 2 + if (c > d) STOP 3 +end program main +! { dg-final { scan-tree-dump-times "_gfortran_compare_string_char4" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_memcmp" 2 "original" } } diff --git a/Fortran/gfortran/regression/character_mismatch.f90 b/Fortran/gfortran/regression/character_mismatch.f90 --- /dev/null +++ b/Fortran/gfortran/regression/character_mismatch.f90 @@ -0,0 +1,76 @@ +! { dg-do compile } +! +! Test case contributed by Mark Eggleston + +program test + use iso_fortran_env + implicit none + integer, parameter :: ucs4 = selected_char_kind('ISO_10646') + integer :: x + character(len=7) :: s = "abcd123" + character(4, ucs4) :: s4 = char(int(z'20ac'), ucs4) // ucs4_"100" + + x = s + x = "string" + x = "A longer string" // " plus a bit" + x = s // s + x = s // "a bit more" + x = "prefix:" // s + x = s4 + x = ucs4_"string" + x = ucs4_"A longer string" // ucs4_" plus a bit" + x = s4 // s4 + x = s4 // ucs4_"a bit more" + x = ucs4_"prefix:" // s4 + + call f(s) + call f("string") + call f("A longer string" // " plus a bit") + call f(s // s) + call f(s // "a bit more") + call f("a string:" // s) + + call f(s4) + call f(ucs4_"string") + call f(ucs4_"A longer string" // ucs4_" plus a bit") + call f(s4 // s4) + call f(s4 // ucs4_"a bit more") + call f(ucs4_"a string:" // s4) + + write(*,*) "" // ucs4_"" + +contains + subroutine f(y) + integer, intent(in) :: y + + write(*,*) y + end subroutine f + +end program + +! { dg-error "CHARACTER\\(7\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 13 } +! { dg-error "CHARACTER\\(6\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 14 } +! { dg-error "CHARACTER\\(26\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 15 } +! { dg-error "CHARACTER\\(14\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 16 } +! { dg-error "CHARACTER\\(17\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 17 } +! { dg-error "CHARACTER\\(14\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 18 } +! { dg-error "CHARACTER\\(4,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 19 } +! { dg-error "CHARACTER\\(6,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 20 } +! { dg-error "CHARACTER\\(26,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 21 } +! { dg-error "CHARACTER\\(8,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 22 } +! { dg-error "CHARACTER\\(14,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 23 } +! { dg-error "CHARACTER\\(11,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 24 } +! { dg-error "CHARACTER\\(7\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 26 } +! { dg-error "CHARACTER\\(6\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 27 } +! { dg-error "CHARACTER\\(26\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 28 } +! { dg-error "CHARACTER\\(14\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 29 } +! { dg-error "CHARACTER\\(17\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 30 } +! { dg-error "CHARACTER\\(16\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 31 } +! { dg-error "CHARACTER\\(4,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 33 } +! { dg-error "CHARACTER\\(6,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 34 } +! { dg-error "CHARACTER\\(26,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 35 } +! { dg-error "CHARACTER\\(8,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 36 } +! { dg-error "CHARACTER\\(14,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 37 } +! { dg-error "CHARACTER\\(13,4\\) to INTEGER\\(4\\)" "type mismatch" { target \*-\*-\* } 38 } +! { dg-error "CHARACTER\\(0\\)/CHARACTER\\(0,4\\)" "operand type mismatch" { target \*-\*-\* } 40 } + diff --git a/Fortran/gfortran/regression/character_workout_1.f90 b/Fortran/gfortran/regression/character_workout_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/character_workout_1.f90 @@ -0,0 +1,689 @@ +! { dg-do run } +! +! Tests fix for PR100120/100816/100818/100819/100821 +! + +program main_p + + implicit none + + integer, parameter :: k = 1 + integer, parameter :: n = 11 + integer, parameter :: m = 7 + integer, parameter :: l = 3 + integer, parameter :: u = 5 + integer, parameter :: e = u-l+1 + integer, parameter :: c = 61 + + character(kind=k), target :: c1(n) + character(len=m, kind=k), target :: cm(n) + ! + character(kind=k), pointer :: s1 + character(len=m, kind=k), pointer :: sm + character(len=e, kind=k), pointer :: se + character(len=:, kind=k), pointer :: sd + ! + character(kind=k), pointer :: p1(:) + character(len=m, kind=k), pointer :: pm(:) + character(len=e, kind=k), pointer :: pe(:) + character(len=:, kind=k), pointer :: pd(:) + + class(*), pointer :: su + class(*), pointer :: pu(:) + + integer :: i, j + + nullify(s1, sm, se, sd, su) + nullify(p1, pm, pe, pd, pu) + c1 = [(char(i+c, kind=k), i=1,n)] + do i = 1, n + do j = 1, m + cm(i)(j:j) = char(i*m+j+c-m, kind=k) + end do + end do + + s1 => c1(n) + if(.not.associated(s1)) stop 1 + if(.not.associated(s1, c1(n))) stop 2 + if(len(s1)/=1) stop 3 + if(s1/=c1(n)) stop 4 + call schar_c1(s1) + call schar_a1(s1) + p1 => c1 + if(.not.associated(p1)) stop 5 + if(.not.associated(p1, c1)) stop 6 + if(len(p1)/=1) stop 7 + if(any(p1/=c1)) stop 8 + call achar_c1(p1) + call achar_a1(p1) + ! + sm => cm(n) + if(.not.associated(sm)) stop 9 + if(.not.associated(sm, cm(n))) stop 10 + if(len(sm)/=m) stop 11 + if(sm/=cm(n)) stop 12 + call schar_cm(sm) + call schar_am(sm) + pm => cm + if(.not.associated(pm)) stop 13 + if(.not.associated(pm, cm)) stop 14 + if(len(pm)/=m) stop 15 + if(any(pm/=cm)) stop 16 + call achar_cm(pm) + call achar_am(pm) + ! + se => cm(n)(l:u) + if(.not.associated(se)) stop 17 + if(.not.associated(se, cm(n)(l:u))) stop 18 + if(len(se)/=e) stop 19 + if(se/=cm(n)(l:u)) stop 20 + call schar_ce(se) + call schar_ae(se) + pe => cm(:)(l:u) + if(.not.associated(pe)) stop 21 + if(.not.associated(pe, cm(:)(l:u))) stop 22 + if(len(pe)/=e) stop 23 + if(any(pe/=cm(:)(l:u))) stop 24 + call achar_ce(pe) + call achar_ae(pe) + ! + sd => c1(n) + if(.not.associated(sd)) stop 25 + if(.not.associated(sd, c1(n))) stop 26 + if(len(sd)/=1) stop 27 + if(sd/=c1(n)) stop 28 + call schar_d1(sd) + pd => c1 + if(.not.associated(pd)) stop 29 + if(.not.associated(pd, c1)) stop 30 + if(len(pd)/=1) stop 31 + if(any(pd/=c1)) stop 32 + call achar_d1(pd) + ! + sd => cm(n) + if(.not.associated(sd)) stop 33 + if(.not.associated(sd, cm(n))) stop 34 + if(len(sd)/=m) stop 35 + if(sd/=cm(n)) stop 36 + call schar_dm(sd) + pd => cm + if(.not.associated(pd)) stop 37 + if(.not.associated(pd, cm)) stop 38 + if(len(pd)/=m) stop 39 + if(any(pd/=cm)) stop 40 + call achar_dm(pd) + ! + sd => cm(n)(l:u) + if(.not.associated(sd)) stop 41 + if(.not.associated(sd, cm(n)(l:u))) stop 42 + if(len(sd)/=e) stop 43 + if(sd/=cm(n)(l:u)) stop 44 + call schar_de(sd) + pd => cm(:)(l:u) + if(.not.associated(pd)) stop 45 + if(.not.associated(pd, cm(:)(l:u))) stop 46 + if(len(pd)/=e) stop 47 + if(any(pd/=cm(:)(l:u))) stop 48 + call achar_de(pd) + ! + sd => c1(n) + s1 => sd + if(.not.associated(s1)) stop 49 + if(.not.associated(s1, c1(n))) stop 50 + if(len(s1)/=1) stop 51 + if(s1/=c1(n)) stop 52 + call schar_c1(s1) + call schar_a1(s1) + pd => c1 + s1 => pd(n) + if(.not.associated(s1)) stop 53 + if(.not.associated(s1, c1(n))) stop 54 + if(len(s1)/=1) stop 55 + if(s1/=c1(n)) stop 56 + call schar_c1(s1) + call schar_a1(s1) + pd => c1 + p1 => pd + if(.not.associated(p1)) stop 57 + if(.not.associated(p1, c1)) stop 58 + if(len(p1)/=1) stop 59 + if(any(p1/=c1)) stop 60 + call achar_c1(p1) + call achar_a1(p1) + ! + sd => cm(n) + sm => sd + if(.not.associated(sm)) stop 61 + if(.not.associated(sm, cm(n))) stop 62 + if(len(sm)/=m) stop 63 + if(sm/=cm(n)) stop 64 + call schar_cm(sm) + call schar_am(sm) + pd => cm + sm => pd(n) + if(.not.associated(sm)) stop 65 + if(.not.associated(sm, cm(n))) stop 66 + if(len(sm)/=m) stop 67 + if(sm/=cm(n)) stop 68 + call schar_cm(sm) + call schar_am(sm) + pd => cm + pm => pd + if(.not.associated(pm)) stop 69 + if(.not.associated(pm, cm)) stop 70 + if(len(pm)/=m) stop 71 + if(any(pm/=cm)) stop 72 + call achar_cm(pm) + call achar_am(pm) + ! + sd => cm(n)(l:u) + se => sd + if(.not.associated(se)) stop 73 + if(.not.associated(se, cm(n)(l:u))) stop 74 + if(len(se)/=e) stop 75 + if(se/=cm(n)(l:u)) stop 76 + call schar_ce(se) + call schar_ae(se) + pd => cm(:)(l:u) + pe => pd + if(.not.associated(pe)) stop 77 + if(.not.associated(pe, cm(:)(l:u))) stop 78 + if(len(pe)/=e) stop 79 + if(any(pe/=cm(:)(l:u))) stop 80 + call achar_ce(pe) + call achar_ae(pe) + ! + su => c1(n) + if(.not.associated(su)) stop 81 + if(.not.associated(su, c1(n))) stop 82 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=1) stop 83 + if(su/=c1(n)) stop 84 + class default + stop 85 + end select + call schar_u1(su) + pu => c1 + if(.not.associated(pu)) stop 86 + if(.not.associated(pu, c1)) stop 87 + select type(pu) + type is(character(len=*, kind=k)) + if(len(pu)/=1) stop 88 + if(any(pu/=c1)) stop 89 + class default + stop 90 + end select + call achar_u1(pu) + ! + su => cm(n) + if(.not.associated(su)) stop 91 + if(.not.associated(su)) stop 92 + if(.not.associated(su, cm(n))) stop 93 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=m) stop 94 + if(su/=cm(n)) stop 95 + class default + stop 96 + end select + call schar_um(su) + pu => cm + if(.not.associated(pu)) stop 97 + if(.not.associated(pu, cm)) stop 98 + select type(pu) + type is(character(len=*, kind=k)) + if(len(pu)/=m) stop 99 + if(any(pu/=cm)) stop 100 + class default + stop 101 + end select + call achar_um(pu) + ! + su => cm(n)(l:u) + if(.not.associated(su)) stop 102 + if(.not.associated(su, cm(n)(l:u))) stop 103 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=e) stop 104 + if(su/=cm(n)(l:u)) stop 105 + class default + stop 106 + end select + call schar_ue(su) + pu => cm(:)(l:u) + if(.not.associated(pu)) stop 107 + if(.not.associated(pu, cm(:)(l:u))) stop 108 + select type(pu) + type is(character(len=*, kind=k)) + if(len(pu)/=e) stop 109 + if(any(pu/=cm(:)(l:u))) stop 110 + class default + stop 111 + end select + call achar_ue(pu) + ! + sd => c1(n) + su => sd + if(.not.associated(su)) stop 112 + if(.not.associated(su, c1(n))) stop 113 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=1) stop 114 + if(su/=c1(n)) stop 115 + class default + stop 116 + end select + call schar_u1(su) + pd => c1 + su => pd(n) + if(.not.associated(su)) stop 117 + if(.not.associated(su, c1(n))) stop 118 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=1) stop 119 + if(su/=c1(n)) stop 120 + class default + stop 121 + end select + call schar_u1(su) + pd => c1 + pu => pd + if(.not.associated(pu)) stop 122 + if(.not.associated(pu, c1)) stop 123 + select type(pu) + type is(character(len=*, kind=k)) + if(len(pu)/=1) stop 124 + if(any(pu/=c1)) stop 125 + class default + stop 126 + end select + call achar_u1(pu) + ! + sd => cm(n) + su => sd + if(.not.associated(su)) stop 127 + if(.not.associated(su, cm(n))) stop 128 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=m) stop 129 + if(su/=cm(n)) stop 130 + class default + stop 131 + end select + call schar_um(su) + pd => cm + su => pd(n) + if(.not.associated(su)) stop 132 + if(.not.associated(su, cm(n))) stop 133 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=m) stop 134 + if(su/=cm(n)) stop 135 + class default + stop 136 + end select + call schar_um(su) + pd => cm + pu => pd + if(.not.associated(pu)) stop 137 + if(.not.associated(pu, cm)) stop 138 + select type(pu) + type is(character(len=*, kind=k)) + if(len(pu)/=m) stop 139 + if(any(pu/=cm)) stop 140 + class default + stop 141 + end select + call achar_um(pu) + ! + sd => cm(n)(l:u) + su => sd + if(.not.associated(su)) stop 142 + if(.not.associated(su, cm(n)(l:u))) stop 143 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=e) stop 144 + if(su/=cm(n)(l:u)) stop 145 + class default + stop 146 + end select + call schar_ue(su) + pd => cm(:)(l:u) + su => pd(n) + if(.not.associated(su)) stop 147 + if(.not.associated(su, cm(n)(l:u))) stop 148 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=e) stop 149 + if(su/=cm(n)(l:u)) stop 150 + class default + stop 151 + end select + call schar_ue(su) + pd => cm(:)(l:u) + pu => pd + if(.not.associated(pu)) stop 152 + if(.not.associated(pu, cm(:)(l:u))) stop 153 + select type(pu) + type is(character(len=*, kind=k)) + if(len(pu)/=e) stop 154 + if(any(pu/=cm(:)(l:u))) stop 155 + class default + stop 156 + end select + call achar_ue(pu) + ! + sd => cm(n) + su => sd(l:u) + if(.not.associated(su)) stop 157 + if(.not.associated(su, cm(n)(l:u))) stop 158 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=e) stop 159 + if(su/=cm(n)(l:u)) stop 160 + class default + stop 161 + end select + call schar_ue(su) + pd => cm(:) + su => pd(n)(l:u) + if(.not.associated(su)) stop 162 + if(.not.associated(su, cm(n)(l:u))) stop 163 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=e) stop 164 + if(su/=cm(n)(l:u)) stop 165 + class default + stop 166 + end select + call schar_ue(su) + pd => cm + pu => pd(:)(l:u) + if(.not.associated(pu)) stop 167 + if(.not.associated(pu, cm(:)(l:u))) stop 168 + select type(pu) + type is(character(len=*, kind=k)) + if(len(pu)/=e) stop 169 + if(any(pu/=cm(:)(l:u))) stop 170 + class default + stop 171 + end select + call achar_ue(pu) + ! + stop + +contains + + subroutine schar_c1(a) + character(kind=k), pointer, intent(in) :: a + + if(.not.associated(a)) stop 172 + if(.not.associated(a, c1(n))) stop 173 + if(len(a)/=1) stop 174 + if(a/=c1(n)) stop 175 + return + end subroutine schar_c1 + + subroutine achar_c1(a) + character(kind=k), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 176 + if(.not.associated(a, c1)) stop 177 + if(len(a)/=1) stop 178 + if(any(a/=c1)) stop 179 + return + end subroutine achar_c1 + + subroutine schar_cm(a) + character(kind=k, len=m), pointer, intent(in) :: a + + if(.not.associated(a)) stop 180 + if(.not.associated(a, cm(n))) stop 181 + if(len(a)/=m) stop 182 + if(a/=cm(n)) stop 183 + return + end subroutine schar_cm + + subroutine achar_cm(a) + character(kind=k, len=m), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 184 + if(.not.associated(a, cm)) stop 185 + if(len(a)/=m) stop 186 + if(any(a/=cm)) stop 187 + return + end subroutine achar_cm + + subroutine schar_ce(a) + character(kind=k, len=e), pointer, intent(in) :: a + + if(.not.associated(a)) stop 188 + if(.not.associated(a, cm(n)(l:u))) stop 189 + if(len(a)/=e) stop 190 + if(a/=cm(n)(l:u)) stop 191 + return + end subroutine schar_ce + + subroutine achar_ce(a) + character(kind=k, len=e), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 192 + if(.not.associated(a, cm(:)(l:u))) stop 193 + if(len(a)/=e) stop 194 + if(any(a/=cm(:)(l:u))) stop 195 + return + end subroutine achar_ce + + subroutine schar_a1(a) + character(kind=k, len=*), pointer, intent(in) :: a + + if(.not.associated(a)) stop 196 + if(.not.associated(a, c1(n))) stop 197 + if(len(a)/=1) stop 198 + if(a/=c1(n)) stop 199 + return + end subroutine schar_a1 + + subroutine achar_a1(a) + character(kind=k, len=*), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 200 + if(.not.associated(a, c1)) stop 201 + if(len(a)/=1) stop 202 + if(any(a/=c1)) stop 203 + return + end subroutine achar_a1 + + subroutine schar_am(a) + character(kind=k, len=*), pointer, intent(in) :: a + + if(.not.associated(a)) stop 204 + if(.not.associated(a, cm(n))) stop 205 + if(len(a)/=m) stop 206 + if(a/=cm(n)) stop 207 + return + end subroutine schar_am + + subroutine achar_am(a) + character(kind=k, len=*), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 208 + if(.not.associated(a, cm)) stop 209 + if(len(a)/=m) stop 210 + if(any(a/=cm)) stop 211 + return + end subroutine achar_am + + subroutine schar_ae(a) + character(kind=k, len=*), pointer, intent(in) :: a + + if(.not.associated(a)) stop 212 + if(.not.associated(a, cm(n)(l:u))) stop 213 + if(len(a)/=e) stop 214 + if(a/=cm(n)(l:u)) stop 215 + return + end subroutine schar_ae + + subroutine achar_ae(a) + character(kind=k, len=*), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 216 + if(.not.associated(a, cm(:)(l:u))) stop 217 + if(len(a)/=e) stop 218 + if(any(a/=cm(:)(l:u))) stop 219 + return + end subroutine achar_ae + + subroutine schar_d1(a) + character(kind=k, len=:), pointer, intent(in) :: a + + if(.not.associated(a)) stop 220 + if(.not.associated(a, c1(n))) stop 221 + if(len(a)/=1) stop 222 + if(a/=c1(n)) stop 223 + return + end subroutine schar_d1 + + subroutine achar_d1(a) + character(kind=k, len=:), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 224 + if(.not.associated(a, c1)) stop 225 + if(len(a)/=1) stop 226 + if(any(a/=c1)) stop 227 + return + end subroutine achar_d1 + + subroutine schar_dm(a) + character(kind=k, len=:), pointer, intent(in) :: a + + if(.not.associated(a)) stop 228 + if(.not.associated(a, cm(n))) stop 229 + if(len(a)/=m) stop 230 + if(a/=cm(n)) stop 231 + return + end subroutine schar_dm + + subroutine achar_dm(a) + character(kind=k, len=:), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 232 + if(.not.associated(a, cm)) stop 233 + if(len(a)/=m) stop 234 + if(any(a/=cm)) stop 235 + return + end subroutine achar_dm + + subroutine schar_de(a) + character(kind=k, len=:), pointer, intent(in) :: a + + if(.not.associated(a)) stop 236 + if(.not.associated(a, cm(n)(l:u))) stop 237 + if(len(a)/=e) stop 238 + if(a/=cm(n)(l:u)) stop 239 + return + end subroutine schar_de + + subroutine achar_de(a) + character(kind=k, len=:), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 240 + if(.not.associated(a, cm(:)(l:u))) stop 241 + if(len(a)/=e) stop 242 + if(any(a/=cm(:)(l:u))) stop 243 + return + end subroutine achar_de + + subroutine schar_u1(a) + class(*), pointer, intent(in) :: a + + if(.not.associated(a)) stop 244 + if(.not.associated(a, c1(n))) stop 245 + select type(a) + type is(character(len=*, kind=k)) + if(len(a)/=1) stop 246 + if(a/=c1(n)) stop 247 + class default + stop 248 + end select + return + end subroutine schar_u1 + + subroutine achar_u1(a) + class(*), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 249 + if(.not.associated(a, c1)) stop 250 + select type(a) + type is(character(len=*, kind=k)) + if(len(a)/=1) stop 251 + if(any(a/=c1)) stop 252 + class default + stop 253 + end select + return + end subroutine achar_u1 + + subroutine schar_um(a) + class(*), pointer, intent(in) :: a + + if(.not.associated(a)) stop 254 + if(.not.associated(a)) stop 255 + if(.not.associated(a, cm(n))) stop 256 + select type(a) + type is(character(len=*, kind=k)) + if(len(a)/=m) stop 257 + if(a/=cm(n)) stop 258 + class default + stop 259 + end select + return + end subroutine schar_um + + subroutine achar_um(a) + class(*), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 260 + if(.not.associated(a, cm)) stop 261 + select type(a) + type is(character(len=*, kind=k)) + if(len(a)/=m) stop 262 + if(any(a/=cm)) stop 263 + class default + stop 264 + end select + return + end subroutine achar_um + + subroutine schar_ue(a) + class(*), pointer, intent(in) :: a + + if(.not.associated(a)) stop 265 + if(.not.associated(a, cm(n)(l:u))) stop 266 + select type(a) + type is(character(len=*, kind=k)) + if(len(a)/=e) stop 267 + if(a/=cm(n)(l:u)) stop 268 + class default + stop 269 + end select + return + end subroutine schar_ue + + subroutine achar_ue(a) + class(*), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 270 + if(.not.associated(a, cm(:)(l:u))) stop 271 + select type(a) + type is(character(len=*, kind=k)) + if(len(a)/=e) stop 272 + if(any(a/=cm(:)(l:u))) stop 273 + class default + stop 274 + end select + return + end subroutine achar_ue + +end program main_p diff --git a/Fortran/gfortran/regression/character_workout_4.f90 b/Fortran/gfortran/regression/character_workout_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/character_workout_4.f90 @@ -0,0 +1,689 @@ +! { dg-do run } +! +! Tests fix for PR100120/100816/100818/100819/100821 +! + +program main_p + + implicit none + + integer, parameter :: k = 4 + integer, parameter :: n = 11 + integer, parameter :: m = 7 + integer, parameter :: l = 3 + integer, parameter :: u = 5 + integer, parameter :: e = u-l+1 + integer, parameter :: c = int(z"FF00") + + character(kind=k), target :: c1(n) + character(len=m, kind=k), target :: cm(n) + ! + character(kind=k), pointer :: s1 + character(len=m, kind=k), pointer :: sm + character(len=e, kind=k), pointer :: se + character(len=:, kind=k), pointer :: sd + ! + character(kind=k), pointer :: p1(:) + character(len=m, kind=k), pointer :: pm(:) + character(len=e, kind=k), pointer :: pe(:) + character(len=:, kind=k), pointer :: pd(:) + + class(*), pointer :: su + class(*), pointer :: pu(:) + + integer :: i, j + + nullify(s1, sm, se, sd, su) + nullify(p1, pm, pe, pd, pu) + c1 = [(char(i+c, kind=k), i=1,n)] + do i = 1, n + do j = 1, m + cm(i)(j:j) = char(i*m+j+c-m, kind=k) + end do + end do + + s1 => c1(n) + if(.not.associated(s1)) stop 1 + if(.not.associated(s1, c1(n))) stop 2 + if(len(s1)/=1) stop 3 + if(s1/=c1(n)) stop 4 + call schar_c1(s1) + call schar_a1(s1) + p1 => c1 + if(.not.associated(p1)) stop 5 + if(.not.associated(p1, c1)) stop 6 + if(len(p1)/=1) stop 7 + if(any(p1/=c1)) stop 8 + call achar_c1(p1) + call achar_a1(p1) + ! + sm => cm(n) + if(.not.associated(sm)) stop 9 + if(.not.associated(sm, cm(n))) stop 10 + if(len(sm)/=m) stop 11 + if(sm/=cm(n)) stop 12 + call schar_cm(sm) + call schar_am(sm) + pm => cm + if(.not.associated(pm)) stop 13 + if(.not.associated(pm, cm)) stop 14 + if(len(pm)/=m) stop 15 + if(any(pm/=cm)) stop 16 + call achar_cm(pm) + call achar_am(pm) + ! + se => cm(n)(l:u) + if(.not.associated(se)) stop 17 + if(.not.associated(se, cm(n)(l:u))) stop 18 + if(len(se)/=e) stop 19 + if(se/=cm(n)(l:u)) stop 20 + call schar_ce(se) + call schar_ae(se) + pe => cm(:)(l:u) + if(.not.associated(pe)) stop 21 + if(.not.associated(pe, cm(:)(l:u))) stop 22 + if(len(pe)/=e) stop 23 + if(any(pe/=cm(:)(l:u))) stop 24 + call achar_ce(pe) + call achar_ae(pe) + ! + sd => c1(n) + if(.not.associated(sd)) stop 25 + if(.not.associated(sd, c1(n))) stop 26 + if(len(sd)/=1) stop 27 + if(sd/=c1(n)) stop 28 + call schar_d1(sd) + pd => c1 + if(.not.associated(pd)) stop 29 + if(.not.associated(pd, c1)) stop 30 + if(len(pd)/=1) stop 31 + if(any(pd/=c1)) stop 32 + call achar_d1(pd) + ! + sd => cm(n) + if(.not.associated(sd)) stop 33 + if(.not.associated(sd, cm(n))) stop 34 + if(len(sd)/=m) stop 35 + if(sd/=cm(n)) stop 36 + call schar_dm(sd) + pd => cm + if(.not.associated(pd)) stop 37 + if(.not.associated(pd, cm)) stop 38 + if(len(pd)/=m) stop 39 + if(any(pd/=cm)) stop 40 + call achar_dm(pd) + ! + sd => cm(n)(l:u) + if(.not.associated(sd)) stop 41 + if(.not.associated(sd, cm(n)(l:u))) stop 42 + if(len(sd)/=e) stop 43 + if(sd/=cm(n)(l:u)) stop 44 + call schar_de(sd) + pd => cm(:)(l:u) + if(.not.associated(pd)) stop 45 + if(.not.associated(pd, cm(:)(l:u))) stop 46 + if(len(pd)/=e) stop 47 + if(any(pd/=cm(:)(l:u))) stop 48 + call achar_de(pd) + ! + sd => c1(n) + s1 => sd + if(.not.associated(s1)) stop 49 + if(.not.associated(s1, c1(n))) stop 50 + if(len(s1)/=1) stop 51 + if(s1/=c1(n)) stop 52 + call schar_c1(s1) + call schar_a1(s1) + pd => c1 + s1 => pd(n) + if(.not.associated(s1)) stop 53 + if(.not.associated(s1, c1(n))) stop 54 + if(len(s1)/=1) stop 55 + if(s1/=c1(n)) stop 56 + call schar_c1(s1) + call schar_a1(s1) + pd => c1 + p1 => pd + if(.not.associated(p1)) stop 57 + if(.not.associated(p1, c1)) stop 58 + if(len(p1)/=1) stop 59 + if(any(p1/=c1)) stop 60 + call achar_c1(p1) + call achar_a1(p1) + ! + sd => cm(n) + sm => sd + if(.not.associated(sm)) stop 61 + if(.not.associated(sm, cm(n))) stop 62 + if(len(sm)/=m) stop 63 + if(sm/=cm(n)) stop 64 + call schar_cm(sm) + call schar_am(sm) + pd => cm + sm => pd(n) + if(.not.associated(sm)) stop 65 + if(.not.associated(sm, cm(n))) stop 66 + if(len(sm)/=m) stop 67 + if(sm/=cm(n)) stop 68 + call schar_cm(sm) + call schar_am(sm) + pd => cm + pm => pd + if(.not.associated(pm)) stop 69 + if(.not.associated(pm, cm)) stop 70 + if(len(pm)/=m) stop 71 + if(any(pm/=cm)) stop 72 + call achar_cm(pm) + call achar_am(pm) + ! + sd => cm(n)(l:u) + se => sd + if(.not.associated(se)) stop 73 + if(.not.associated(se, cm(n)(l:u))) stop 74 + if(len(se)/=e) stop 75 + if(se/=cm(n)(l:u)) stop 76 + call schar_ce(se) + call schar_ae(se) + pd => cm(:)(l:u) + pe => pd + if(.not.associated(pe)) stop 77 + if(.not.associated(pe, cm(:)(l:u))) stop 78 + if(len(pe)/=e) stop 79 + if(any(pe/=cm(:)(l:u))) stop 80 + call achar_ce(pe) + call achar_ae(pe) + ! + su => c1(n) + if(.not.associated(su)) stop 81 + if(.not.associated(su, c1(n))) stop 82 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=1) stop 83 + if(su/=c1(n)) stop 84 + class default + stop 85 + end select + call schar_u1(su) + pu => c1 + if(.not.associated(pu)) stop 86 + if(.not.associated(pu, c1)) stop 87 + select type(pu) + type is(character(len=*, kind=k)) + if(len(pu)/=1) stop 88 + if(any(pu/=c1)) stop 89 + class default + stop 90 + end select + call achar_u1(pu) + ! + su => cm(n) + if(.not.associated(su)) stop 91 + if(.not.associated(su)) stop 92 + if(.not.associated(su, cm(n))) stop 93 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=m) stop 94 + if(su/=cm(n)) stop 95 + class default + stop 96 + end select + call schar_um(su) + pu => cm + if(.not.associated(pu)) stop 97 + if(.not.associated(pu, cm)) stop 98 + select type(pu) + type is(character(len=*, kind=k)) + if(len(pu)/=m) stop 99 + if(any(pu/=cm)) stop 100 + class default + stop 101 + end select + call achar_um(pu) + ! + su => cm(n)(l:u) + if(.not.associated(su)) stop 102 + if(.not.associated(su, cm(n)(l:u))) stop 103 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=e) stop 104 + if(su/=cm(n)(l:u)) stop 105 + class default + stop 106 + end select + call schar_ue(su) + pu => cm(:)(l:u) + if(.not.associated(pu)) stop 107 + if(.not.associated(pu, cm(:)(l:u))) stop 108 + select type(pu) + type is(character(len=*, kind=k)) + if(len(pu)/=e) stop 109 + if(any(pu/=cm(:)(l:u))) stop 110 + class default + stop 111 + end select + call achar_ue(pu) + ! + sd => c1(n) + su => sd + if(.not.associated(su)) stop 112 + if(.not.associated(su, c1(n))) stop 113 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=1) stop 114 + if(su/=c1(n)) stop 115 + class default + stop 116 + end select + call schar_u1(su) + pd => c1 + su => pd(n) + if(.not.associated(su)) stop 117 + if(.not.associated(su, c1(n))) stop 118 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=1) stop 119 + if(su/=c1(n)) stop 120 + class default + stop 121 + end select + call schar_u1(su) + pd => c1 + pu => pd + if(.not.associated(pu)) stop 122 + if(.not.associated(pu, c1)) stop 123 + select type(pu) + type is(character(len=*, kind=k)) + if(len(pu)/=1) stop 124 + if(any(pu/=c1)) stop 125 + class default + stop 126 + end select + call achar_u1(pu) + ! + sd => cm(n) + su => sd + if(.not.associated(su)) stop 127 + if(.not.associated(su, cm(n))) stop 128 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=m) stop 129 + if(su/=cm(n)) stop 130 + class default + stop 131 + end select + call schar_um(su) + pd => cm + su => pd(n) + if(.not.associated(su)) stop 132 + if(.not.associated(su, cm(n))) stop 133 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=m) stop 134 + if(su/=cm(n)) stop 135 + class default + stop 136 + end select + call schar_um(su) + pd => cm + pu => pd + if(.not.associated(pu)) stop 137 + if(.not.associated(pu, cm)) stop 138 + select type(pu) + type is(character(len=*, kind=k)) + if(len(pu)/=m) stop 139 + if(any(pu/=cm)) stop 140 + class default + stop 141 + end select + call achar_um(pu) + ! + sd => cm(n)(l:u) + su => sd + if(.not.associated(su)) stop 142 + if(.not.associated(su, cm(n)(l:u))) stop 143 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=e) stop 144 + if(su/=cm(n)(l:u)) stop 145 + class default + stop 146 + end select + call schar_ue(su) + pd => cm(:)(l:u) + su => pd(n) + if(.not.associated(su)) stop 147 + if(.not.associated(su, cm(n)(l:u))) stop 148 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=e) stop 149 + if(su/=cm(n)(l:u)) stop 150 + class default + stop 151 + end select + call schar_ue(su) + pd => cm(:)(l:u) + pu => pd + if(.not.associated(pu)) stop 152 + if(.not.associated(pu, cm(:)(l:u))) stop 153 + select type(pu) + type is(character(len=*, kind=k)) + if(len(pu)/=e) stop 154 + if(any(pu/=cm(:)(l:u))) stop 155 + class default + stop 156 + end select + call achar_ue(pu) + ! + sd => cm(n) + su => sd(l:u) + if(.not.associated(su)) stop 157 + if(.not.associated(su, cm(n)(l:u))) stop 158 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=e) stop 159 + if(su/=cm(n)(l:u)) stop 160 + class default + stop 161 + end select + call schar_ue(su) + pd => cm(:) + su => pd(n)(l:u) + if(.not.associated(su)) stop 162 + if(.not.associated(su, cm(n)(l:u))) stop 163 + select type(su) + type is(character(len=*, kind=k)) + if(len(su)/=e) stop 164 + if(su/=cm(n)(l:u)) stop 165 + class default + stop 166 + end select + call schar_ue(su) + pd => cm + pu => pd(:)(l:u) + if(.not.associated(pu)) stop 167 + if(.not.associated(pu, cm(:)(l:u))) stop 168 + select type(pu) + type is(character(len=*, kind=k)) + if(len(pu)/=e) stop 169 + if(any(pu/=cm(:)(l:u))) stop 170 + class default + stop 171 + end select + call achar_ue(pu) + ! + stop + +contains + + subroutine schar_c1(a) + character(kind=k), pointer, intent(in) :: a + + if(.not.associated(a)) stop 172 + if(.not.associated(a, c1(n))) stop 173 + if(len(a)/=1) stop 174 + if(a/=c1(n)) stop 175 + return + end subroutine schar_c1 + + subroutine achar_c1(a) + character(kind=k), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 176 + if(.not.associated(a, c1)) stop 177 + if(len(a)/=1) stop 178 + if(any(a/=c1)) stop 179 + return + end subroutine achar_c1 + + subroutine schar_cm(a) + character(kind=k, len=m), pointer, intent(in) :: a + + if(.not.associated(a)) stop 180 + if(.not.associated(a, cm(n))) stop 181 + if(len(a)/=m) stop 182 + if(a/=cm(n)) stop 183 + return + end subroutine schar_cm + + subroutine achar_cm(a) + character(kind=k, len=m), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 184 + if(.not.associated(a, cm)) stop 185 + if(len(a)/=m) stop 186 + if(any(a/=cm)) stop 187 + return + end subroutine achar_cm + + subroutine schar_ce(a) + character(kind=k, len=e), pointer, intent(in) :: a + + if(.not.associated(a)) stop 188 + if(.not.associated(a, cm(n)(l:u))) stop 189 + if(len(a)/=e) stop 190 + if(a/=cm(n)(l:u)) stop 191 + return + end subroutine schar_ce + + subroutine achar_ce(a) + character(kind=k, len=e), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 192 + if(.not.associated(a, cm(:)(l:u))) stop 193 + if(len(a)/=e) stop 194 + if(any(a/=cm(:)(l:u))) stop 195 + return + end subroutine achar_ce + + subroutine schar_a1(a) + character(kind=k, len=*), pointer, intent(in) :: a + + if(.not.associated(a)) stop 196 + if(.not.associated(a, c1(n))) stop 197 + if(len(a)/=1) stop 198 + if(a/=c1(n)) stop 199 + return + end subroutine schar_a1 + + subroutine achar_a1(a) + character(kind=k, len=*), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 200 + if(.not.associated(a, c1)) stop 201 + if(len(a)/=1) stop 202 + if(any(a/=c1)) stop 203 + return + end subroutine achar_a1 + + subroutine schar_am(a) + character(kind=k, len=*), pointer, intent(in) :: a + + if(.not.associated(a)) stop 204 + if(.not.associated(a, cm(n))) stop 205 + if(len(a)/=m) stop 206 + if(a/=cm(n)) stop 207 + return + end subroutine schar_am + + subroutine achar_am(a) + character(kind=k, len=*), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 208 + if(.not.associated(a, cm)) stop 209 + if(len(a)/=m) stop 210 + if(any(a/=cm)) stop 211 + return + end subroutine achar_am + + subroutine schar_ae(a) + character(kind=k, len=*), pointer, intent(in) :: a + + if(.not.associated(a)) stop 212 + if(.not.associated(a, cm(n)(l:u))) stop 213 + if(len(a)/=e) stop 214 + if(a/=cm(n)(l:u)) stop 215 + return + end subroutine schar_ae + + subroutine achar_ae(a) + character(kind=k, len=*), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 216 + if(.not.associated(a, cm(:)(l:u))) stop 217 + if(len(a)/=e) stop 218 + if(any(a/=cm(:)(l:u))) stop 219 + return + end subroutine achar_ae + + subroutine schar_d1(a) + character(kind=k, len=:), pointer, intent(in) :: a + + if(.not.associated(a)) stop 220 + if(.not.associated(a, c1(n))) stop 221 + if(len(a)/=1) stop 222 + if(a/=c1(n)) stop 223 + return + end subroutine schar_d1 + + subroutine achar_d1(a) + character(kind=k, len=:), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 224 + if(.not.associated(a, c1)) stop 225 + if(len(a)/=1) stop 226 + if(any(a/=c1)) stop 227 + return + end subroutine achar_d1 + + subroutine schar_dm(a) + character(kind=k, len=:), pointer, intent(in) :: a + + if(.not.associated(a)) stop 228 + if(.not.associated(a, cm(n))) stop 229 + if(len(a)/=m) stop 230 + if(a/=cm(n)) stop 231 + return + end subroutine schar_dm + + subroutine achar_dm(a) + character(kind=k, len=:), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 232 + if(.not.associated(a, cm)) stop 233 + if(len(a)/=m) stop 234 + if(any(a/=cm)) stop 235 + return + end subroutine achar_dm + + subroutine schar_de(a) + character(kind=k, len=:), pointer, intent(in) :: a + + if(.not.associated(a)) stop 236 + if(.not.associated(a, cm(n)(l:u))) stop 237 + if(len(a)/=e) stop 238 + if(a/=cm(n)(l:u)) stop 239 + return + end subroutine schar_de + + subroutine achar_de(a) + character(kind=k, len=:), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 240 + if(.not.associated(a, cm(:)(l:u))) stop 241 + if(len(a)/=e) stop 242 + if(any(a/=cm(:)(l:u))) stop 243 + return + end subroutine achar_de + + subroutine schar_u1(a) + class(*), pointer, intent(in) :: a + + if(.not.associated(a)) stop 244 + if(.not.associated(a, c1(n))) stop 245 + select type(a) + type is(character(len=*, kind=k)) + if(len(a)/=1) stop 246 + if(a/=c1(n)) stop 247 + class default + stop 248 + end select + return + end subroutine schar_u1 + + subroutine achar_u1(a) + class(*), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 249 + if(.not.associated(a, c1)) stop 250 + select type(a) + type is(character(len=*, kind=k)) + if(len(a)/=1) stop 251 + if(any(a/=c1)) stop 252 + class default + stop 253 + end select + return + end subroutine achar_u1 + + subroutine schar_um(a) + class(*), pointer, intent(in) :: a + + if(.not.associated(a)) stop 254 + if(.not.associated(a)) stop 255 + if(.not.associated(a, cm(n))) stop 256 + select type(a) + type is(character(len=*, kind=k)) + if(len(a)/=m) stop 257 + if(a/=cm(n)) stop 258 + class default + stop 259 + end select + return + end subroutine schar_um + + subroutine achar_um(a) + class(*), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 260 + if(.not.associated(a, cm)) stop 261 + select type(a) + type is(character(len=*, kind=k)) + if(len(a)/=m) stop 262 + if(any(a/=cm)) stop 263 + class default + stop 264 + end select + return + end subroutine achar_um + + subroutine schar_ue(a) + class(*), pointer, intent(in) :: a + + if(.not.associated(a)) stop 265 + if(.not.associated(a, cm(n)(l:u))) stop 266 + select type(a) + type is(character(len=*, kind=k)) + if(len(a)/=e) stop 267 + if(a/=cm(n)(l:u)) stop 268 + class default + stop 269 + end select + return + end subroutine schar_ue + + subroutine achar_ue(a) + class(*), pointer, intent(in) :: a(:) + + if(.not.associated(a)) stop 270 + if(.not.associated(a, cm(:)(l:u))) stop 271 + select type(a) + type is(character(len=*, kind=k)) + if(len(a)/=e) stop 272 + if(any(a/=cm(:)(l:u))) stop 273 + class default + stop 274 + end select + return + end subroutine achar_ue + +end program main_p diff --git a/Fortran/gfortran/regression/charlen_01.f90 b/Fortran/gfortran/regression/charlen_01.f90 --- /dev/null +++ b/Fortran/gfortran/regression/charlen_01.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! PR fortran/65173 +program min_obj + implicit none + integer, parameter :: a = 128 + type :: param_t + integer :: n= 0 + real*8, dimension(256), allocatable :: x ! { dg-error "must have a deferred shape" } + real*8, dimension(2,256), allocatable :: bounds ! { dg-error "must have a deferred shape" } + character(a), dimension(256), allocatable :: names ! { dg-error "must have a deferred shape" } + end type param_t + contains + subroutine extrace_params_from_section ( ) + character(*), dimension(), parameter :: & ! { dg-error "expression in array specification" } + & char_params = ['element', 'parametrization'] + end subroutine extrace_params_from_section +end program min_obj diff --git a/Fortran/gfortran/regression/charlen_02.f90 b/Fortran/gfortran/regression/charlen_02.f90 --- /dev/null +++ b/Fortran/gfortran/regression/charlen_02.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/65173 +program p + type t + character(1), allocatable :: n(256) ! { dg-error "must have a deferred shape" } + end type +end diff --git a/Fortran/gfortran/regression/charlen_04.f90 b/Fortran/gfortran/regression/charlen_04.f90 --- /dev/null +++ b/Fortran/gfortran/regression/charlen_04.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/65173 +program p + type t + character(*), allocatable :: x(*) ! { dg-error "must have a deferred shape" } + end type ! { dg-error "needs to be a constant specification" "" { target "*-*-*" } .-1 } +end diff --git a/Fortran/gfortran/regression/charlen_05.f90 b/Fortran/gfortran/regression/charlen_05.f90 --- /dev/null +++ b/Fortran/gfortran/regression/charlen_05.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/65173 +program p + type t + character(*) :: x y ! { dg-error "error in data declaration" } + end type ! { dg-error "needs to be a constant specification" "" { target "*-*-*" } .-1 } +end diff --git a/Fortran/gfortran/regression/charlen_06.f90 b/Fortran/gfortran/regression/charlen_06.f90 --- /dev/null +++ b/Fortran/gfortran/regression/charlen_06.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/65173 +program p + type t + character(*) :: x+1 ! { dg-error "error in data declaration" } + end type ! { dg-error "needs to be a constant specification" "" { target "*-*-*" } .-1 } +end diff --git a/Fortran/gfortran/regression/charlen_07.f90 b/Fortran/gfortran/regression/charlen_07.f90 --- /dev/null +++ b/Fortran/gfortran/regression/charlen_07.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/65173 +program p + type t + end type + type, extends(t) :: t2 + character x = ! { dg-error "error in data declaration" } + end type +end diff --git a/Fortran/gfortran/regression/charlen_08.f90 b/Fortran/gfortran/regression/charlen_08.f90 --- /dev/null +++ b/Fortran/gfortran/regression/charlen_08.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/65173 +program p + type t + end type + type, extends(t) :: t2 + character x 'x' ! { dg-error "error in data declaration" } + end type +end diff --git a/Fortran/gfortran/regression/charlen_09.f90 b/Fortran/gfortran/regression/charlen_09.f90 --- /dev/null +++ b/Fortran/gfortran/regression/charlen_09.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/65173 +program p + type t + end type + type, extends(t) :: t2 + character x(:) ! { dg-error "must have an explicit shape" } + end type +end diff --git a/Fortran/gfortran/regression/charlen_11.f90 b/Fortran/gfortran/regression/charlen_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/charlen_11.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/65173 +program p + type t + character, allocatable :: z1(:), z1(:) ! { dg-error "already declared at" } + end type +end diff --git a/Fortran/gfortran/regression/charlen_12.f90 b/Fortran/gfortran/regression/charlen_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/charlen_12.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/65173 +program p + type t + character, allocatable :: z1(:) ! { dg-error "." } + character, allocatable :: z1(:) ! { dg-error "already declared at" } + end type +end diff --git a/Fortran/gfortran/regression/charlen_13.f90 b/Fortran/gfortran/regression/charlen_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/charlen_13.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/69859 +program p + type t + character(2), allocatable :: a(*) ! { dg-error "must have a deferred shape" } + character(*), allocatable :: b(2) ! { dg-error "must have a deferred shape" } + ! { dg-error "needs to be a constant specification" "" { target "*-*-*" } .-1 } + character(*), allocatable :: c(*) ! { dg-error "must have a deferred shape" } + end type ! { dg-error "needs to be a constant specification" "" { target "*-*-*" } .-1 } +end diff --git a/Fortran/gfortran/regression/charlen_14.f90 b/Fortran/gfortran/regression/charlen_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/charlen_14.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR fortran/69064 +subroutine setup_check_path(path) ! { dg-error "has no IMPLICIT type" } + implicit none + character(len=path_len),intent(inout)::path ! { dg-error "Scalar INTEGER expression" } +end diff --git a/Fortran/gfortran/regression/charlen_15.f90 b/Fortran/gfortran/regression/charlen_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/charlen_15.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! PR fortran/78350 +module m + type t + character(2) :: c(1) = [character(3) :: 'abc'] + end type + type(t) :: x +end +program foo + use m + if (trim(x%c(1)) /= 'ab') STOP 1 +end program foo diff --git a/Fortran/gfortran/regression/charlen_16.f90 b/Fortran/gfortran/regression/charlen_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/charlen_16.f90 @@ -0,0 +1,9 @@ +! { dg-do run } +! PR fortran/78350 +program p + type t + character(2) :: c(1) = [character(3) :: 'abc'] + end type + type(t) :: x + if (trim(x%c(1)) /= 'ab') STOP 1 +end diff --git a/Fortran/gfortran/regression/charlen_17.f90 b/Fortran/gfortran/regression/charlen_17.f90 --- /dev/null +++ b/Fortran/gfortran/regression/charlen_17.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! PR 87673 - used to cause errors about non-pure functions. + +module x + implicit none +contains + pure function foo() result(res) + character(len=:), allocatable :: res + allocate (character(bar()) :: res) + end function foo + pure integer function bar() + bar = 1 + end function bar +end module x diff --git a/Fortran/gfortran/regression/charlen_18.f90 b/Fortran/gfortran/regression/charlen_18.f90 --- /dev/null +++ b/Fortran/gfortran/regression/charlen_18.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-fdec-structure" } +! +! Check fix for PR98517 +! +! Contributed by Eric Reischer +! + SUBROUTINE TEST_BUG + IMPLICIT NONE + + CHARACTER*(*) DEF_VAL + PARAMETER (DEF_VAL = 'ABCDEFGH') + + STRUCTURE /SOME_STRUCT/ + CHARACTER*64 SOME_VAR /DEF_VAL/ + END STRUCTURE + + END diff --git a/Fortran/gfortran/regression/check_bits_1.f90 b/Fortran/gfortran/regression/check_bits_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/check_bits_1.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +! { dg-options "-fcheck=bits -fdump-tree-original" } +! { dg-shouldfail "Fortran runtime error: SIZE argument (0) out of range 1:32 in intrinsic ISHFTC" } +! { dg-output "At line 44 .*" } +! +! Verify that the runtime checks for the bit manipulation intrinsic functions +! do not generate false-positives +program check + implicit none + integer :: i, k, pos, len, shift, size, nb + nb = bit_size (i) + i = 0 + do pos = 0, nb-1 + k = ibset (i, pos) + i = ibclr (k, pos) + if (btest (i, pos)) stop 1 + end do + do pos = 0, nb + do len = 0, nb-pos + i = ibits (i, pos, len) + end do + end do + do shift = 0, nb + k = ishft (i, shift) + i = ishft (k, -shift) + end do + do shift = 0, nb + k = shiftl (i, shift) ! Fortran 2008 + i = shiftr (k, shift) + i = shifta (i, shift) + k = lshift (i, shift) ! GNU extensions + i = rshift (k, shift) + end do + do shift = 0, nb + k = ishftc (i, shift) + i = ishftc (k, -shift) + do size = max (1,shift), nb + k = ishftc (i, shift, size) + i = ishftc (k, -shift, size) + end do + end do + size = 0 + ! The following line should fail with a runtime error: + k = ishftc (i, 0, size) + ! Should never get here with -fcheck=bits + stop 2 +end program check + +! { dg-final { scan-tree-dump-times "_gfortran_runtime_error_at" 21 "original" } } diff --git a/Fortran/gfortran/regression/check_bits_2.f90 b/Fortran/gfortran/regression/check_bits_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/check_bits_2.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! { dg-options "-fcheck=bits -fdump-tree-original" } +! { dg-shouldfail "Fortran runtime error: FROMPOS(64)+LEN(1)>BIT_SIZE(64) in intrinsic MVBITS" } +! { dg-output "At line 33 .*" } +! +! Verify that the runtime checks for the MVBITS intrinsic functions +! do not generate false-positives +program check + implicit none + integer, parameter :: bs4 = bit_size (1_4) + integer, parameter :: bs8 = bit_size (1_8) + integer(4), dimension(0:bs4) :: from4, frompos4, len4, to4, topos4 + integer(8), dimension(0:bs8) :: from8, frompos8, len8, to8, topos8 + integer :: i + from4 = -1 + to4 = -1 + len4 = [ (i, i=0,bs4) ] + frompos4 = bs4 - len4 + topos4 = frompos4 + call mvbits (from4, frompos4, len4, to4, topos4) + if (any (to4 /= -1)) stop 1 + from8 = -1 + to8 = -1 + len8 = [ (i, i=0,bs8) ] + frompos8 = bs8 - len8 + topos8 = frompos8 + call mvbits (from8, frompos8, len8, to8, topos8) + if (any (to8 /= -1)) stop 2 + from8 = -1 + to8 = -1 + len8(0) = 1 + ! The following line should fail with a runtime error: + call mvbits (from8, frompos8, len8, to8, topos8) + ! Should never get here with -fcheck=bits + stop 3 +end + +! { dg-final { scan-tree-dump-times "_gfortran_runtime_error_at" 15 "original" } } diff --git a/Fortran/gfortran/regression/check_bits_3.f90 b/Fortran/gfortran/regression/check_bits_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/check_bits_3.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! PR fortran/105986 +! Contributed by G.Steinmetz + +program p + integer :: i + logical, parameter :: a(*) = [(btest(8_4,i), i=-1,-1)] ! { dg-error "nonnegative" } + integer, parameter :: b(*) = [(ibclr(8_4,i), i=-1,-1)] ! { dg-error "nonnegative" } + integer, parameter :: c(*) = [(ibset(8_4,i), i=-1,-1)] ! { dg-error "nonnegative" } + logical, parameter :: d(*) = [(btest(8_1,i), i= 8, 8)] ! { dg-error "must be less" } + integer, parameter :: e(*) = [(ibclr(8_2,i), i=16,16)] ! { dg-error "must be less" } + integer, parameter :: f(*) = [(ibset(8_4,i), i=32,32)] ! { dg-error "must be less" } + integer, parameter :: g(*) = [(ibits(8_4,i,1),i=-1,-1)] ! { dg-error "nonnegative" } + integer, parameter :: h(*) = [(ibits(8_4,1,i),i=-1,-1)] ! { dg-error "nonnegative" } + integer, parameter :: j(*) = [(ibits(8_4,i,i),i=32,32)] ! { dg-error "must be less" } +end diff --git a/Fortran/gfortran/regression/chkbits.f90 b/Fortran/gfortran/regression/chkbits.f90 --- /dev/null +++ b/Fortran/gfortran/regression/chkbits.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! NOT() was not return the two's complement value as reported by +! PR fortran/25458. In checking other bit manipulation intrinsics, +! IBSET was found to be in error. +program chkbits + + implicit none + + integer(kind=1) i1 + integer(kind=2) i2 + integer(kind=4) i4 + integer(kind=8) i8 + + i1 = ibset(huge(0_1), bit_size(i1)-1) + i2 = ibset(huge(0_2), bit_size(i2)-1) + i4 = ibset(huge(0_4), bit_size(i4)-1) + i8 = ibset(huge(0_8), bit_size(i8)-1) + if (i1 /= -1 .or. i2 /= -1 .or. i4 /= -1 .or. i8 /= -1) STOP 1 + + i1 = ibclr(-1_1, bit_size(i1)-1) + i2 = ibclr(-1_2, bit_size(i2)-1) + i4 = ibclr(-1_4, bit_size(i4)-1) + i8 = ibclr(-1_8, bit_size(i8)-1) + if (i1 /= huge(0_1) .or. i2 /= huge(0_2)) STOP 2 + if (i4 /= huge(0_4) .or. i8 /= huge(0_8)) STOP 3 + + i1 = not(0_1) + i2 = not(0_2) + i4 = not(0_4) + i8 = not(0_8) + if (i1 /= -1 .or. i2 /= -1 .or. i4 /= -1 .or. i8 /= -1) STOP 4 + +end program chkbits diff --git a/Fortran/gfortran/regression/chmod_1.f90 b/Fortran/gfortran/regression/chmod_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/chmod_1.f90 @@ -0,0 +1,35 @@ +! { dg-do run { target { ! { *-*-mingw* *-*-cygwin* } } } } +! { dg-options "-std=gnu" } +! See PR38956. Test fails on cygwin when user has Administrator rights + implicit none + character(len=*), parameter :: n = "foobar_file_chmod_1" + integer :: i + + open (10,file=n) + close (10,status="delete") + + open (10,file=n) + close (10,status="keep") + + if (access(n,"") /= 0 .or. access(n," ") /= 0 .or. access(n,"r") /= 0 .or. & + access(n,"R") /= 0 .or. access(n,"w") /= 0 .or. access(n,"W") /= 0) & + STOP 1 + + call chmod (n, "a+x", i) + if (i == 0) then + if (access(n,"x") /= 0 .or. access(n,"X") /= 0) STOP 2 + end if + + call chmod (n, "a-w", i) + if (i == 0 .and. getuid() /= 0) then + if (access(n,"w") == 0 .or. access(n,"W") == 0) STOP 3 + end if + + open (10,file=n) + close (10,status="delete") + + if (access(n,"") == 0 .or. access(n," ") == 0 .or. access(n,"r") == 0 .or. & + access(n,"R") == 0 .or. access(n,"w") == 0 .or. access(n,"W") == 0) & + STOP 4 + + end diff --git a/Fortran/gfortran/regression/chmod_2.f90 b/Fortran/gfortran/regression/chmod_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/chmod_2.f90 @@ -0,0 +1,35 @@ +! { dg-do run { target { ! { *-*-mingw* *-*-cygwin* } } } } +! { dg-options "-std=gnu" } +! See PR38956. Test fails on cygwin when user has Administrator rights + implicit none + character(len=*), parameter :: n = "foobar_file_chmod_2" + integer :: i + + open (10,file=n) + close (10,status="delete") + + open (10,file=n) + close (10,status="keep") + + if (access(n,"") /= 0 .or. access(n," ") /= 0 .or. access(n,"r") /= 0 .or. & + access(n,"R") /= 0 .or. access(n,"w") /= 0 .or. access(n,"W") /= 0) & + STOP 1 + + i = chmod (n, "a+x") + if (i == 0) then + if (access(n,"x") /= 0 .or. access(n,"X") /= 0) STOP 2 + end if + + i = chmod (n, "a-w") + if (i == 0 .and. getuid() /= 0) then + if (access(n,"w") == 0 .or. access(n,"W") == 0) STOP 3 + end if + + open (10,file=n) + close (10,status="delete") + + if (access(n,"") == 0 .or. access(n," ") == 0 .or. access(n,"r") == 0 .or. & + access(n,"R") == 0 .or. access(n,"w") == 0 .or. access(n,"W") == 0) & + STOP 4 + + end diff --git a/Fortran/gfortran/regression/chmod_3.f90 b/Fortran/gfortran/regression/chmod_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/chmod_3.f90 @@ -0,0 +1,35 @@ +! { dg-do run { target { ! { *-*-mingw* *-*-cygwin* } } } } +! { dg-options "-std=gnu -fdefault-integer-8" } +! See PR38956. Test fails on cygwin when user has Administrator rights + implicit none + character(len=*), parameter :: n = "foobar_file_chmod_3" + integer :: i + + open (10,file=n) + close (10,status="delete") + + open (10,file=n) + close (10,status="keep") + + if (access(n,"") /= 0 .or. access(n," ") /= 0 .or. access(n,"r") /= 0 .or. & + access(n,"R") /= 0 .or. access(n,"w") /= 0 .or. access(n,"W") /= 0) & + STOP 1 + + i = chmod (n, "a+x") + if (i == 0) then + if (access(n,"x") /= 0 .or. access(n,"X") /= 0) STOP 2 + end if + + i = chmod (n, "a-w") + if (i == 0 .and. getuid() /= 0) then + if (access(n,"w") == 0 .or. access(n,"W") == 0) STOP 3 + end if + + open (10,file=n) + close (10,status="delete") + + if (access(n,"") == 0 .or. access(n," ") == 0 .or. access(n,"r") == 0 .or. & + access(n,"R") == 0 .or. access(n,"w") == 0 .or. access(n,"W") == 0) & + STOP 4 + + end diff --git a/Fortran/gfortran/regression/class_1.f03 b/Fortran/gfortran/regression/class_1.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_1.f03 @@ -0,0 +1,37 @@ +! { dg-do run } +! +! PR 40940: CLASS statement +! +! Contributed by Janus Weil + +implicit none + +type t + integer :: comp + class(t),pointer :: c2 +end type + +class(t),pointer :: c1 + +allocate(c1) + +c1%comp = 5 +c1%c2 => c1 + +print *,c1%comp + +call sub(c1) + +if (c1%comp/=5) STOP 1 + +deallocate(c1) + +contains + + subroutine sub (c3) + class(t) :: c3 + print *,c3%comp + end subroutine + +end + diff --git a/Fortran/gfortran/regression/class_10.f03 b/Fortran/gfortran/regression/class_10.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_10.f03 @@ -0,0 +1,30 @@ +! { dg-do compile } +! +! PR 41800: [OOP] ICE in fold_convert_loc, at fold-const.c:2789 +! +! Contributed by Harald Anlauf + +module abstract_gradient + + implicit none + private + + type, public, abstract :: gradient_class + contains + procedure, nopass :: inner_product + end type + +contains + + function inner_product () + class(gradient_class), pointer :: inner_product + inner_product => NULL() + end function + +end module + + + use abstract_gradient + class(gradient_class), pointer :: g_initial, ip_save + ip_save => g_initial%inner_product() ! ICE +end diff --git a/Fortran/gfortran/regression/class_11.f03 b/Fortran/gfortran/regression/class_11.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_11.f03 @@ -0,0 +1,37 @@ +! { dg-do compile } +! +! PR 41556 +! Contributed by Damian Rouson + + implicit none + + type ,abstract :: object + contains + procedure(assign_interface) ,deferred :: assign + generic :: assignment(=) => assign + end type + + abstract interface + subroutine assign_interface(lhs,rhs) + import :: object + class(object) ,intent(inout) :: lhs + class(object) ,intent(in) :: rhs + end subroutine + end interface + +! PR 41937 +! Contributed by Juergen Reuter + + type, abstract :: cuba_abstract_type + integer :: dim_f = 1 + real, dimension(:), allocatable :: integral + end type cuba_abstract_type + +contains + + subroutine cuba_abstract_alloc_dim_f(this) + class(cuba_abstract_type) :: this + allocate(this%integral(this%dim_f)) + end subroutine cuba_abstract_alloc_dim_f + +end diff --git a/Fortran/gfortran/regression/class_12.f03 b/Fortran/gfortran/regression/class_12.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_12.f03 @@ -0,0 +1,43 @@ +! { dg-do compile } +! +! PR 41556: [OOP] Errors in applying operator/assignment to an abstract type +! +! Contributed by Damian Rouson + +module abstract_algebra + implicit none + private + public :: rescale + public :: object + + type ,abstract :: object + contains + procedure(assign_interface) ,deferred :: assign + procedure(product_interface) ,deferred :: product + generic :: assignment(=) => assign + generic :: operator(*) => product + end type + + abstract interface + function product_interface(lhs,rhs) result(product) + import :: object + class(object) ,intent(in) :: lhs + class(object) ,allocatable :: product + real ,intent(in) :: rhs + end function + subroutine assign_interface(lhs,rhs) + import :: object + class(object) ,intent(inout) :: lhs + class(object) ,intent(in) :: rhs + end subroutine + end interface + +contains + + subroutine rescale(operand,scale) + class(object) :: operand + real ,intent(in) :: scale + operand = operand*scale + operand = operand%product(scale) + end subroutine +end module diff --git a/Fortran/gfortran/regression/class_13.f03 b/Fortran/gfortran/regression/class_13.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_13.f03 @@ -0,0 +1,36 @@ +! { dg-do compile } +! +! PR 42353: [OOP] Bogus Error: Name 'vtype$...' at (1) is an ambiguous reference ... +! +! Original test case by Harald Anlauf +! Modified by Janus Weil + +module concrete_vector + type :: trivial_vector_type + end type + class(trivial_vector_type), pointer :: this +end module concrete_vector + +module concrete_gradient +contains + subroutine my_to_vector (v) + use concrete_vector + class(trivial_vector_type) :: v + select type (v) + class is (trivial_vector_type) + end select + end subroutine +end module concrete_gradient + +module concrete_inner_product + use concrete_vector + use concrete_gradient +contains + real function my_dot_v_v (a) + class(trivial_vector_type) :: a + select type (a) + class is (trivial_vector_type) + end select + end function +end module concrete_inner_product + diff --git a/Fortran/gfortran/regression/class_14.f03 b/Fortran/gfortran/regression/class_14.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_14.f03 @@ -0,0 +1,52 @@ +! { dg-do compile } +! Test the final fix for PR42353, in which a compilation error was +! occurring because the derived type of the initializer of the vtab +! component '$extends' was not the same as that of the component. +! +! Contributed by Harald Anlauf +! +module abstract_vector + implicit none + + type, abstract :: vector_class + end type vector_class +end module abstract_vector +!------------------------- +module concrete_vector + use abstract_vector + implicit none + + type, extends(vector_class) :: trivial_vector_type + end type trivial_vector_type + + private :: my_assign +contains + subroutine my_assign (this,v) + class(trivial_vector_type), intent(inout) :: this + class(vector_class), intent(in) :: v + end subroutine my_assign +end module concrete_vector +!--------------------------- +module concrete_gradient + use abstract_vector + implicit none + + type, abstract, extends(vector_class) :: gradient_class + end type gradient_class + + type, extends(gradient_class) :: trivial_gradient_type + end type trivial_gradient_type + + private :: my_assign +contains + subroutine my_assign (this,v) + class(trivial_gradient_type), intent(inout) :: this + class(vector_class), intent(in) :: v + end subroutine my_assign +end module concrete_gradient +!---------------------------- +module concrete_inner_product + use concrete_vector + use concrete_gradient + implicit none +end module concrete_inner_product diff --git a/Fortran/gfortran/regression/class_15.f03 b/Fortran/gfortran/regression/class_15.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_15.f03 @@ -0,0 +1,41 @@ +! { dg-do compile } +! +! PR 42274: [fortran-dev Regression] ICE: segmentation fault +! +! Original test case by Salvatore Filippone +! Modified by Janus Weil + +module mod_A + type :: t1 + contains + procedure,nopass :: fun + end type +contains + logical function fun() + end function +end module + +module mod_B + use mod_A + type, extends(t1) :: t2 + contains + procedure :: sub1 + end type +contains + subroutine sub1(a) + class(t2) :: a + end subroutine +end module + +module mod_C +contains + subroutine sub2(b) + use mod_B + type(t2) :: b + end subroutine +end module + +module mod_D + use mod_A + use mod_C +end module diff --git a/Fortran/gfortran/regression/class_16.f03 b/Fortran/gfortran/regression/class_16.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_16.f03 @@ -0,0 +1,21 @@ +! { dg-do compile } +! +! PR 43896: [fortran-dev Regression] ICE in gfc_conv_variable, at fortran/trans-expr.c:551 +! +! Contributed by Fran Martinez Fadrique + +module m_rotation_matrix + + type t_rotation_matrix + contains + procedure :: array => rotation_matrix_array + end type + +contains + + function rotation_matrix_array( rot ) result(array) + class(t_rotation_matrix) :: rot + double precision, dimension(3,3) :: array + end function + +end module diff --git a/Fortran/gfortran/regression/class_17.f03 b/Fortran/gfortran/regression/class_17.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_17.f03 @@ -0,0 +1,62 @@ +! { dg-do compile } +! +! PR 43696: [OOP] Bogus error: Passed-object dummy argument must not be POINTER +! +! Contributed by Hans-Werner Boschmann + + +MODULE error_stack_module + implicit none + + type,abstract::serializable_class + contains + procedure(ser_DTV_RF),deferred::read_formatted + end type serializable_class + + abstract interface + subroutine ser_DTV_RF(dtv,unit,iotype,v_list,iostat,iomsg) + import serializable_class + CLASS(serializable_class),INTENT(INOUT) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER (LEN=*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: v_list(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + end subroutine ser_DTV_RF + end interface + + type,extends(serializable_class)::error_type + class(error_type),pointer::next=>null() + contains + procedure::read_formatted=>error_read_formatted + end type error_type + +contains + + recursive subroutine error_read_formatted(dtv,unit,iotype,v_list,iostat,iomsg) + CLASS(error_type),INTENT(INOUT) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER (LEN=*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: v_list(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + character(8),allocatable::type + character(8),allocatable::next + call basic_read_string(unit,type) + call basic_read_string(unit,next) + if(next=="NEXT")then + allocate(dtv%next) + call dtv%next%read_formatted(unit,iotype,v_list,iostat,iomsg) + end if + end subroutine error_read_formatted + +end MODULE error_stack_module + + +module b_module + implicit none + type::b_type + class(not_yet_defined_type_type),pointer::b_component ! { dg-error "has not been declared" } + end type b_type +end module b_module + diff --git a/Fortran/gfortran/regression/class_18.f03 b/Fortran/gfortran/regression/class_18.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_18.f03 @@ -0,0 +1,18 @@ +! { dg-do run } +! +! PR 43207: [OOP] ICE for class pointer => null() initialization +! +! Original test case by Tobias Burnus +! Modified by Janus Weil + + implicit none + type :: parent + end type + type(parent), target :: t + class(parent), pointer :: cp => null() + + if (associated(cp)) STOP 1 + cp => t + if (.not. associated(cp)) STOP 2 + +end diff --git a/Fortran/gfortran/regression/class_19.f03 b/Fortran/gfortran/regression/class_19.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_19.f03 @@ -0,0 +1,42 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! PR 43969: [OOP] ALLOCATED() with polymorphic variables +! +! Contributed by Salvatore Filippone + + +module foo_mod + type foo_inner + integer, allocatable :: v(:) + end type foo_inner + type foo_outer + class(foo_inner), allocatable :: int + end type foo_outer +contains +subroutine foo_checkit() + implicit none + type(foo_outer) :: try + type(foo_outer),allocatable :: try2 + class(foo_outer), allocatable :: try3 + + if (allocated(try%int)) STOP 1 + allocate(foo_outer :: try3) + if (allocated(try3%int)) STOP 2 + allocate(try2) + if (allocated(try2%int)) STOP 3 + +end subroutine foo_checkit +end module foo_mod + + +program main + + use foo_mod + implicit none + + call foo_checkit() + +end program main + +! { dg-final { scan-tree-dump-times "__builtin_free" 12 "original" } } diff --git a/Fortran/gfortran/regression/class_2.f03 b/Fortran/gfortran/regression/class_2.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_2.f03 @@ -0,0 +1,50 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR 40940: CLASS statement +! +! Contributed by Janus Weil + +use,intrinsic :: iso_c_binding + +type t1 + integer :: comp +end type + +type t2 + sequence + real :: r +end type + +type,bind(c) :: t3 + integer(c_int) :: i +end type + +type :: t4 + procedure(absint), pointer :: p ! { dg-error "Non-polymorphic passed-object dummy argument" } +end type + +type :: t5 + class(t1) :: c ! { dg-error "must be allocatable or pointer" } +end type + +abstract interface + subroutine absint(arg) + import :: t4 + type(t4) :: arg + end subroutine +end interface + +type t6 + integer :: i + class(t6), allocatable :: foo ! { dg-error "must have the POINTER attribute" } +end type t6 + + +class(t1) :: o1 ! { dg-error "must be dummy, allocatable or pointer" } + +class(t2), pointer :: o2 ! { dg-error "is not extensible" } +class(t3), pointer :: o3 ! { dg-error "is not extensible" } + +end + diff --git a/Fortran/gfortran/regression/class_20.f03 b/Fortran/gfortran/regression/class_20.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_20.f03 @@ -0,0 +1,40 @@ +! { dg-do compile } +! +! PR 44044: [OOP] SELECT TYPE with class-valued function +! comment #1 +! +! Note: All three error messages are being checked for double occurrence, +! using the trick from PR 30612. +! +! Contributed by Janus Weil + + +implicit none + +type :: t +end type + +type :: s + sequence +end type + +contains + + function fun() ! { dg-bogus "must be dummy, allocatable or pointer.*must be dummy, allocatable or pointer" } + class(t) :: fun + end function + + function fun2() ! { dg-bogus "cannot have a deferred shape.*cannot have a deferred shape" } + integer,dimension(:) :: fun2 + end function + + function fun3() result(res) ! { dg-bogus "is not extensible.*is not extensible" } + class(s),pointer :: res + end function + +end + + +! { dg-error "must be dummy, allocatable or pointer" "" { target *-*-* } 23 } +! { dg-error "cannot have a deferred shape" "" { target *-*-* } 27 } +! { dg-error "is not extensible" "" { target *-*-* } 31 } diff --git a/Fortran/gfortran/regression/class_21.f03 b/Fortran/gfortran/regression/class_21.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_21.f03 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR 43990: [OOP] ICE in output_constructor_regular_field, at varasm.c:4995 +! +! Reported by Hans-Werner Boschmann + +module m + + type :: t + logical :: l = .true. + class(t),pointer :: cp => null() + end type + + type(t),save :: default_t + +end module diff --git a/Fortran/gfortran/regression/class_22.f03 b/Fortran/gfortran/regression/class_22.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_22.f03 @@ -0,0 +1,29 @@ +! { dg-do compile } +! +! PR 44212: [OOP] ICE when defining a pointer component before defining the class and calling a TBP then +! +! Contributed by Hans-Werner Boschmann + +module ice_module + + type :: B_type + class(A_type),pointer :: A_comp + end type B_type + + type :: A_type + contains + procedure :: A_proc + end type A_type + +contains + + subroutine A_proc(this) + class(A_type),target,intent(inout) :: this + end subroutine A_proc + + subroutine ice_proc(this) + class(A_type) :: this + call this%A_proc() + end subroutine ice_proc + +end module ice_module diff --git a/Fortran/gfortran/regression/class_23.f03 b/Fortran/gfortran/regression/class_23.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_23.f03 @@ -0,0 +1,24 @@ +! { dg-do compile } +! +! PR 42051: [OOP] ICE on array-valued function with CLASS formal argument +! +! Original test case by Damian Rouson +! Modified by Janus Weil + + type grid + end type + +contains + + function return_x(this) result(this_x) + class(grid) :: this + real ,dimension(1) :: this_x + end function + + subroutine output() + type(grid) :: mesh + real ,dimension(1) :: x + x = return_x(mesh) + end subroutine + +end diff --git a/Fortran/gfortran/regression/class_24.f03 b/Fortran/gfortran/regression/class_24.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_24.f03 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +! PR 44869: [OOP] Missing TARGET check - and wrong code or accepts-invalid? +! +! Contributed by Satish.BD + + type :: test_case + end type + + type :: test_suite + type(test_case) :: list + end type + +contains + + subroutine sub(self) + class(test_suite), intent(inout) :: self + type(test_case), pointer :: tst_case + tst_case => self%list ! { dg-error "is neither TARGET nor POINTER" } + end subroutine + +end diff --git a/Fortran/gfortran/regression/class_25.f03 b/Fortran/gfortran/regression/class_25.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_25.f03 @@ -0,0 +1,26 @@ +! { dg-do run } +! +! PR [OOP] Compile-time errors on typed allocation and pointer function result assignment +! +! Contributed by Damian Rouson + +module m + + implicit none + + type foo + end type + + type ,extends(foo) :: bar + end type + +contains + + function new_bar() + class(foo) ,pointer :: new_bar + allocate(bar :: new_bar) + end function + +end module + +end diff --git a/Fortran/gfortran/regression/class_26.f03 b/Fortran/gfortran/regression/class_26.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_26.f03 @@ -0,0 +1,28 @@ +! { dg-do run } +! +! PR 44065: [OOP] Undefined reference to vtab$... +! +! Contributed by Salvatore Filippone + +module s_mat_mod + implicit none + type :: s_sparse_mat + end type +contains + subroutine s_set_triangle(a) + class(s_sparse_mat), intent(inout) :: a + end subroutine +end module + +module s_tester +implicit none +contains + subroutine s_ussv_2 + use s_mat_mod + type(s_sparse_mat) :: a + call s_set_triangle(a) + end subroutine +end module + +end + diff --git a/Fortran/gfortran/regression/class_27.f03 b/Fortran/gfortran/regression/class_27.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_27.f03 @@ -0,0 +1,65 @@ +! { dg-do compile } +! +! PR 46330: [4.6 Regression] [OOP] ICE after revision 166368 +! +! Contributed by Dominique d'Humieres +! Taken from http://groups.google.com/group/comp.lang.fortran/browse_thread/thread/76f99e7fd4f3e772 + +module type2_type + implicit none + type, abstract :: Type2 + end type Type2 +end module type2_type + +module extended2A_type + use type2_type + implicit none + type, extends(Type2) :: Extended2A + real(kind(1.0D0)) :: coeff1 = 1. + contains + procedure :: setCoeff1 => Extended2A_setCoeff1 + end type Extended2A + contains + function Extended2A_new(c1, c2) result(typePtr_) + real(kind(1.0D0)), optional, intent(in) :: c1 + real(kind(1.0D0)), optional, intent(in) :: c2 + type(Extended2A), pointer :: typePtr_ + type(Extended2A), save, allocatable, target :: type_ + allocate(type_) + typePtr_ => null() + if (present(c1)) call type_%setCoeff1(c1) + typePtr_ => type_ + if ( .not.(associated (typePtr_))) then + stop 'Error initializing Extended2A Pointer.' + endif + end function Extended2A_new + subroutine Extended2A_setCoeff1(this,c1) + class(Extended2A) :: this + real(kind(1.0D0)), intent(in) :: c1 + this% coeff1 = c1 + end subroutine Extended2A_setCoeff1 +end module extended2A_type + +module type1_type + use type2_type + implicit none + type Type1 + class(type2), pointer :: type2Ptr => null() + contains + procedure :: initProc => Type1_initProc + end type Type1 + contains + function Type1_initProc(this) result(iError) + use extended2A_type + implicit none + class(Type1) :: this + integer :: iError + this% type2Ptr => extended2A_new() + if ( .not.( associated(this% type2Ptr))) then + iError = 1 + write(*,'(A)') "Something Wrong." + else + iError = 0 + endif + end function Type1_initProc +end module type1_type diff --git a/Fortran/gfortran/regression/class_28.f03 b/Fortran/gfortran/regression/class_28.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_28.f03 @@ -0,0 +1,43 @@ +! { dg-do compile } +! +! PR 46344: [4.6 Regression] [OOP] ICE with allocatable CLASS components +! +! Contributed by Salvatore Filippone + +module m + + type t1 + end type + + type t2 + class(t1), allocatable :: cc + end type + + class(t2), allocatable :: sm + +end module m + + +module m2 + + type t1 + end type + + type t2 + class(t1), allocatable :: c + end type + + type(t1) :: w + +end module m2 + + +program p + use m + implicit none + + type(t2), allocatable :: x(:) + + allocate(x(1)) + +end program p diff --git a/Fortran/gfortran/regression/class_29.f03 b/Fortran/gfortran/regression/class_29.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_29.f03 @@ -0,0 +1,32 @@ +! { dg-do compile } +! +! PR 46313: [OOP] OOP-ABI issue, ALLOCATE issue, CLASS renaming issue +! +! Contributed by Tobias Burnus + +module m1 + type mytype + real :: a(10) = 2 + end type +end module m1 + +module m2 + type mytype + real :: b(10) = 8 + end type +end module m2 + +program p +use m1, t1 => mytype +use m2, t2 => mytype +implicit none + +class(t1), allocatable :: x +class(t2), allocatable :: y + +allocate (t1 :: x) +allocate (t2 :: y) + +print *, x%a +print *, y%b +end diff --git a/Fortran/gfortran/regression/class_3.f03 b/Fortran/gfortran/regression/class_3.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_3.f03 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! PR 40940: [F03] CLASS statement +! +! Contributed by Janus Weil + + type :: t + integer :: comp + end type + + class(t), pointer :: cl ! { dg-error "CLASS statement" } + +end + diff --git a/Fortran/gfortran/regression/class_30.f90 b/Fortran/gfortran/regression/class_30.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_30.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! +! PR fortran/46244 (comments 7 to 9) +! +! gfortran accepted CLASS in bind(C) and SEQUENCE types +! +type :: t + integer :: i +end type t + +type t2 + sequence + class(t), pointer :: x ! { dg-error "Polymorphic component x at .1. in SEQUENCE or BIND" } +end type t2 + +type, bind(C):: t3 + class(t), pointer :: y + ! { dg-error "Polymorphic component y at .1. in SEQUENCE or BIND" "" { target *-*-* } .-1 } +end type t3 +end diff --git a/Fortran/gfortran/regression/class_31.f90 b/Fortran/gfortran/regression/class_31.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_31.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! +! PR fortran/46413 +! +type t + integer :: ii =5 +end type t +class(t), allocatable :: x +allocate (t :: x) + +print *,x ! { dg-error "Data transfer element at .1. cannot be polymorphic" } +end diff --git a/Fortran/gfortran/regression/class_32.f90 b/Fortran/gfortran/regression/class_32.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_32.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! +! PR 45827: [4.6 Regression] [OOP] mio_component_ref(): Component not found +! +! Contributed by Daniel Franke + +MODULE m + + TYPE, ABSTRACT :: t + PRIVATE + INTEGER :: n + CONTAINS + PROCEDURE :: get + END TYPE + + ABSTRACT INTERFACE + SUBROUTINE create(this) + IMPORT t + CLASS(t) :: this + END SUBROUTINE + END INTERFACE + +CONTAINS + + FUNCTION get(this) + CLASS(t) :: this + REAL, DIMENSION(this%n) :: get + END FUNCTION + + SUBROUTINE destroy(this) + CLASS(t) :: this + END SUBROUTINE + +END MODULE + + +PROGRAM p + USE m +END diff --git a/Fortran/gfortran/regression/class_33.f90 b/Fortran/gfortran/regression/class_33.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_33.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! PR 46971: [4.6 Regression] [OOP] ICE on long class names +! +! Contributed by Andrew Benson + +module Molecular_Abundances_Structure + type molecularAbundancesStructure + end type + class(molecularAbundancesStructure), pointer :: molecules +end module diff --git a/Fortran/gfortran/regression/class_34.f90 b/Fortran/gfortran/regression/class_34.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_34.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +! PR 46448: [4.6 Regression] [OOP] symbol `__copy_...' is already defined +! +! Contributed by Janus Weil + +module m0 + type :: t + end type +end module + +module m1 + use m0 + class(t), pointer :: c1 +end module + +module m2 + use m0 + class(t), pointer :: c2 +end module + +end diff --git a/Fortran/gfortran/regression/class_35.f90 b/Fortran/gfortran/regression/class_35.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_35.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! +! PR 46313: [OOP] class container naming collisions +! +! Contributed by Tobias Burnus + +module one + type two_three + end type +end module + +module one_two + type three + end type +end module + +use one +use one_two +class(two_three), allocatable :: a1 +class(three), allocatable :: a2 + +if (same_type_as(a1,a2)) STOP 1 + +end diff --git a/Fortran/gfortran/regression/class_36.f03 b/Fortran/gfortran/regression/class_36.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_36.f03 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! PR 47572: [OOP] Invalid: Allocatable polymorphic with init expression. +! +! Contributed by Edmondo Giovannozzi +! cf. http://groups.google.com/group/comp.lang.fortran/browse_thread/thread/763785b16883ed68 + +program scalar_allocation + type test + real :: a + end type + class (test), allocatable :: b = test(3.4) ! { dg-error "cannot have an initializer" } + print *,allocated(b) +end program diff --git a/Fortran/gfortran/regression/class_37.f03 b/Fortran/gfortran/regression/class_37.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_37.f03 @@ -0,0 +1,262 @@ +! { dg-do compile } +! { dg-require-visibility "" } +! Test fix for PR47082, in which an ICE in the ALLOCATE at line 248. +! +! Contributed by Salvatore Filippone +! +module psb_penv_mod + + interface psb_init + module procedure psb_init + end interface + + interface psb_exit + module procedure psb_exit + end interface + + interface psb_info + module procedure psb_info + end interface + + integer, private, save :: nctxt=0 + + + +contains + + + subroutine psb_init(ictxt,np,basectxt,ids) + implicit none + integer, intent(out) :: ictxt + integer, intent(in), optional :: np, basectxt, ids(:) + + + ictxt = nctxt + nctxt = nctxt + 1 + + end subroutine psb_init + + subroutine psb_exit(ictxt,close) + implicit none + integer, intent(inout) :: ictxt + logical, intent(in), optional :: close + + nctxt = max(0, nctxt - 1) + + end subroutine psb_exit + + + subroutine psb_info(ictxt,iam,np) + + implicit none + + integer, intent(in) :: ictxt + integer, intent(out) :: iam, np + + iam = 0 + np = 1 + + end subroutine psb_info + + +end module psb_penv_mod + + +module psb_indx_map_mod + + type :: psb_indx_map + + integer :: state = -1 + integer :: ictxt = -1 + integer :: mpic = -1 + integer :: global_rows = -1 + integer :: global_cols = -1 + integer :: local_rows = -1 + integer :: local_cols = -1 + + + end type psb_indx_map + +end module psb_indx_map_mod + + + +module psb_gen_block_map_mod + use psb_indx_map_mod + + type, extends(psb_indx_map) :: psb_gen_block_map + integer :: min_glob_row = -1 + integer :: max_glob_row = -1 + integer, allocatable :: loc_to_glob(:), srt_l2g(:,:), vnl(:) + contains + + procedure, pass(idxmap) :: gen_block_map_init => block_init + + end type psb_gen_block_map + + private :: block_init + +contains + + subroutine block_init(idxmap,ictxt,nl,info) + use psb_penv_mod + implicit none + class(psb_gen_block_map), intent(inout) :: idxmap + integer, intent(in) :: ictxt, nl + integer, intent(out) :: info + ! To be implemented + integer :: iam, np, i, j, ntot + integer, allocatable :: vnl(:) + + info = 0 + call psb_info(ictxt,iam,np) + if (np < 0) then + info = -1 + return + end if + + allocate(vnl(0:np),stat=info) + if (info /= 0) then + info = -2 + return + end if + + vnl(:) = 0 + vnl(iam) = nl + ntot = sum(vnl) + vnl(1:np) = vnl(0:np-1) + vnl(0) = 0 + do i=1,np + vnl(i) = vnl(i) + vnl(i-1) + end do + if (ntot /= vnl(np)) then +! !$ write(0,*) ' Mismatch in block_init ',ntot,vnl(np) + end if + + idxmap%global_rows = ntot + idxmap%global_cols = ntot + idxmap%local_rows = nl + idxmap%local_cols = nl + idxmap%ictxt = ictxt + idxmap%state = 1 + + idxmap%min_glob_row = vnl(iam)+1 + idxmap%max_glob_row = vnl(iam+1) + call move_alloc(vnl,idxmap%vnl) + allocate(idxmap%loc_to_glob(nl),stat=info) + if (info /= 0) then + info = -2 + return + end if + + end subroutine block_init + +end module psb_gen_block_map_mod + + +module psb_descriptor_type + use psb_indx_map_mod + + implicit none + + + type psb_desc_type + integer, allocatable :: matrix_data(:) + integer, allocatable :: halo_index(:) + integer, allocatable :: ext_index(:) + integer, allocatable :: ovrlap_index(:) + integer, allocatable :: ovrlap_elem(:,:) + integer, allocatable :: ovr_mst_idx(:) + integer, allocatable :: bnd_elem(:) + class(psb_indx_map), allocatable :: indxmap + integer, allocatable :: lprm(:) + type(psb_desc_type), pointer :: base_desc => null() + integer, allocatable :: idx_space(:) + end type psb_desc_type + + +end module psb_descriptor_type + +module psb_cd_if_tools_mod + + use psb_descriptor_type + use psb_gen_block_map_mod + + interface psb_cdcpy + subroutine psb_cdcpy(desc_in, desc_out, info) + use psb_descriptor_type + + implicit none + !....parameters... + + type(psb_desc_type), intent(in) :: desc_in + type(psb_desc_type), intent(out) :: desc_out + integer, intent(out) :: info + end subroutine psb_cdcpy + end interface + + +end module psb_cd_if_tools_mod + +module psb_cd_tools_mod + + use psb_cd_if_tools_mod + + interface psb_cdall + + subroutine psb_cdall(ictxt, desc, info,mg,ng,vg,vl,flag,nl,repl, globalcheck) + use psb_descriptor_type + implicit None + Integer, intent(in) :: mg,ng,ictxt, vg(:), vl(:),nl + integer, intent(in) :: flag + logical, intent(in) :: repl, globalcheck + integer, intent(out) :: info + type(psb_desc_type), intent(out) :: desc + + optional :: mg,ng,vg,vl,flag,nl,repl, globalcheck + end subroutine psb_cdall + + end interface + +end module psb_cd_tools_mod +module psb_base_tools_mod + use psb_cd_tools_mod +end module psb_base_tools_mod + +subroutine psb_cdall(ictxt, desc, info,mg,ng,vg,vl,flag,nl,repl, globalcheck) + use psb_descriptor_type + use psb_gen_block_map_mod + use psb_base_tools_mod, psb_protect_name => psb_cdall + implicit None + Integer, intent(in) :: mg,ng,ictxt, vg(:), vl(:),nl + integer, intent(in) :: flag + logical, intent(in) :: repl, globalcheck + integer, intent(out) :: info + type(psb_desc_type), intent(out) :: desc + + optional :: mg,ng,vg,vl,flag,nl,repl, globalcheck + integer :: err_act, n_, flag_, i, me, np, nlp, nnv, lr + integer, allocatable :: itmpsz(:) + + + + info = 0 + desc%base_desc => null() + if (allocated(desc%indxmap)) then + write(0,*) 'Allocated on an intent(OUT) var?' + end if + + allocate(psb_gen_block_map :: desc%indxmap, stat=info) + if (info == 0) then + select type(aa => desc%indxmap) + type is (psb_gen_block_map) + call aa%gen_block_map_init(ictxt,nl,info) + class default + ! This cannot happen + info = -1 + end select + end if + + return + +end subroutine psb_cdall diff --git a/Fortran/gfortran/regression/class_38.f03 b/Fortran/gfortran/regression/class_38.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_38.f03 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +! PR 47728: [OOP] ICE on invalid CLASS declaration +! +! Contributed by Arjen Markus + +program test_objects + + implicit none + + type, abstract :: shape + end type + + type, extends(shape) :: rectangle + real :: width, height + end type + + class(shape), dimension(2) :: object ! { dg-error "must be dummy, allocatable or pointer" } + + object(1) = rectangle( 1.0, 2.0 ) ! { dg-error "Unclassifiable statement" } + +end program test_objects diff --git a/Fortran/gfortran/regression/class_39.f03 b/Fortran/gfortran/regression/class_39.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_39.f03 @@ -0,0 +1,13 @@ +! { dg-do compile } +! +! PR 47745: [OOP] Segfault with CLASS(*) and derived type dummy arguments +! +! Contributed by Rodney Polkinghorne + + type, abstract :: T + end type T +contains + class(T) function add() ! { dg-error "must be dummy, allocatable or pointer" } + add = 1 ! { dg-error "Nonallocatable variable must not be polymorphic in intrinsic assignment" } + end function +end diff --git a/Fortran/gfortran/regression/class_40.f03 b/Fortran/gfortran/regression/class_40.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_40.f03 @@ -0,0 +1,34 @@ +! { dg-do run } +! +! PR 47767: [OOP] SELECT TYPE fails to execute correct TYPE IS block +! +! Contributed by Andrew Benson + +module Tree_Nodes + type treeNode + contains + procedure :: walk + end type +contains + subroutine walk (thisNode) + class (treeNode) :: thisNode + print *, SAME_TYPE_AS (thisNode, treeNode()) + end subroutine +end module + +module Merger_Trees + use Tree_Nodes + private + type(treeNode), public :: baseNode +end module + +module Merger_Tree_Build + use Merger_Trees +end module + +program test + use Merger_Tree_Build + use Tree_Nodes + type(treeNode) :: node + call walk (node) +end program diff --git a/Fortran/gfortran/regression/class_41.f03 b/Fortran/gfortran/regression/class_41.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_41.f03 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +! PR 48059: [4.6 Regression][OOP] ICE in in gfc_conv_component_ref: character function of extended type +! +! Contributed by Hans-Werner Boschmann + +module a_module + type :: a_type + integer::length=0 + end type a_type + type,extends(a_type) :: b_type + end type b_type +contains + function a_string(this) result(form) + class(a_type),intent(in)::this + character(max(1,this%length))::form + end function a_string + subroutine b_sub(this) + class(b_type),intent(inout),target::this + print *,a_string(this) + end subroutine b_sub +end module a_module diff --git a/Fortran/gfortran/regression/class_42.f03 b/Fortran/gfortran/regression/class_42.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_42.f03 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! PR 48291: [4.6/4.7 Regression] [OOP] internal compiler error, new_symbol(): Symbol name too long +! +! Contributed by Adrian Prantl + +module Overload_AnException_Impl + type :: Overload_AnException_impl_t + end type +contains + subroutine ctor_impl(self) + class(Overload_AnException_impl_t) :: self + end subroutine +end module diff --git a/Fortran/gfortran/regression/class_43.f03 b/Fortran/gfortran/regression/class_43.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_43.f03 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! PR 49417: [4.6/4.7 Regression] [OOP] ICE on invalid CLASS component declaration +! +! Contributed by Andrew Benson + + type :: nodeWrapper + end type nodeWrapper + + type, extends(nodeWrapper) :: treeNode + class(nodeWrapper) :: subComponent ! { dg-error "must be allocatable or pointer" } + end type treeNode + +end diff --git a/Fortran/gfortran/regression/class_44.f03 b/Fortran/gfortran/regression/class_44.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_44.f03 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! PR 49112: [4.6/4.7 Regression] [OOP] Missing type-bound procedure, "duplicate save" warnings and internal compiler error +! +! Contributed by John + + implicit none + save + + type :: DateTime + end type + + class(DateTime), allocatable :: dt + +end diff --git a/Fortran/gfortran/regression/class_45a.f03 b/Fortran/gfortran/regression/class_45a.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_45a.f03 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR 50227: [4.7 Regression] [OOP] ICE-on-valid with allocatable class variable +! +! Contributed by Andrew Benson + +module G_Nodes + private + + type, public :: t0 + end type + + type, public, extends(t0) :: t1 + end type + +contains + + function basicGet(self) + implicit none + class(t0), pointer :: basicGet + class(t0), target, intent(in) :: self + select type (self) + type is (t1) + basicGet => self + end select + end function basicGet + +end module G_Nodes diff --git a/Fortran/gfortran/regression/class_45b.f03 b/Fortran/gfortran/regression/class_45b.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_45b.f03 @@ -0,0 +1,13 @@ +! { dg-do link } +! { dg-compile-aux-modules "class_45a.f03" } +! +! PR 50227: [4.7 Regression] [OOP] ICE-on-valid with allocatable class variable +! +! Contributed by Andrew Benson + +program Test + use G_Nodes + class(t0), allocatable :: c + allocate(t1 :: c) +end program Test +! { dg-final { cleanup-modules "G_Nodes" } } diff --git a/Fortran/gfortran/regression/class_46.f03 b/Fortran/gfortran/regression/class_46.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_46.f03 @@ -0,0 +1,16 @@ +! { dg-do run } +! +! PR 50625: [4.6/4.7 Regression][OOP] ALLOCATABLE attribute lost for module CLASS variables +! +! Contributed by Tobias Burnus + +module m +type t +end type t +class(t), allocatable :: x +end module m + +use m +implicit none +if (allocated(x)) STOP 1 +end diff --git a/Fortran/gfortran/regression/class_47.f90 b/Fortran/gfortran/regression/class_47.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_47.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! +! PR fortran/51913 +! +! Contributed by Alexander Tismer +! +MODULE m_sparseMatrix + + implicit none + + type :: sparseMatrix_t + + end type sparseMatrix_t +END MODULE m_sparseMatrix + +!=============================================================================== +module m_subroutine +! USE m_sparseMatrix !< when uncommenting this line program works fine + + implicit none + + contains + subroutine test(matrix) + use m_sparseMatrix + class(sparseMatrix_t), pointer :: matrix + end subroutine +end module + +!=============================================================================== +PROGRAM main + use m_subroutine + USE m_sparseMatrix + implicit none + + CLASS(sparseMatrix_t), pointer :: sparseMatrix + + call test(sparseMatrix) +END PROGRAM diff --git a/Fortran/gfortran/regression/class_48.f90 b/Fortran/gfortran/regression/class_48.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_48.f90 @@ -0,0 +1,161 @@ +! { dg-do run } +! +! PR fortran/51972 +! Also tests fixes for PR52102 +! +! Check whether DT assignment with polymorphic components works. +! + +subroutine test1 () + type t + integer :: x + end type t + + type t2 + class(t), allocatable :: a + end type t2 + + type(t2) :: one, two + + one = two + if (allocated (one%a)) STOP 1 + + allocate (two%a) + two%a%x = 7890 + one = two + if (one%a%x /= 7890) STOP 2 + + deallocate (two%a) + one = two + if (allocated (one%a)) STOP 3 +end subroutine test1 + +subroutine test2 () + type t + integer, allocatable :: x(:) + end type t + + type t2 + class(t), allocatable :: a + end type t2 + + type(t2) :: one, two + + one = two + if (allocated (one%a)) STOP 4 + + allocate (two%a) + one = two + if (.not.allocated (one%a)) STOP 5 + if (allocated (one%a%x)) STOP 6 + + allocate (two%a%x(2)) + two%a%x(:) = 7890 + one = two + if (any (one%a%x /= 7890)) STOP 7 + + deallocate (two%a) + one = two + if (allocated (one%a)) STOP 8 +end subroutine test2 + + +subroutine test3 () + type t + integer :: x + end type t + + type t2 + class(t), allocatable :: a(:) + end type t2 + + type(t2) :: one, two + +! Test allocate with array source - PR52102 + allocate (two%a(2), source = [t(4), t(6)]) + + if (allocated (one%a)) STOP 9 + + one = two + if (.not.allocated (one%a)) STOP 10 + + if ((one%a(1)%x /= 4)) STOP 11 + if ((one%a(2)%x /= 6)) STOP 12 + + deallocate (two%a) + one = two + + if (allocated (one%a)) STOP 13 + +! Test allocate with no source followed by assignments. + allocate (two%a(2)) + two%a(1)%x = 5 + two%a(2)%x = 7 + + if (allocated (one%a)) STOP 14 + + one = two + if (.not.allocated (one%a)) STOP 15 + + if ((one%a(1)%x /= 5)) STOP 16 + if ((one%a(2)%x /= 7)) STOP 17 + + deallocate (two%a) + one = two + if (allocated (one%a)) STOP 18 +end subroutine test3 + +subroutine test4 () + type t + integer, allocatable :: x(:) + end type t + + type t2 + class(t), allocatable :: a(:) + end type t2 + + type(t2) :: one, two + + if (allocated (one%a)) STOP 19 + if (allocated (two%a)) STOP 20 + + allocate (two%a(2)) + + if (allocated (two%a(1)%x)) STOP 21 + if (allocated (two%a(2)%x)) STOP 22 + allocate (two%a(1)%x(3), source=[1,2,3]) + allocate (two%a(2)%x(5), source=[5,6,7,8,9]) + one = two + if (.not. allocated (one%a)) STOP 23 + if (.not. allocated (one%a(1)%x)) STOP 24 + if (.not. allocated (one%a(2)%x)) STOP 25 + + if (size(one%a) /= 2) STOP 26 + if (size(one%a(1)%x) /= 3) STOP 27 + if (size(one%a(2)%x) /= 5) STOP 28 + if (any (one%a(1)%x /= [1,2,3])) STOP 29 + if (any (one%a(2)%x /= [5,6,7,8,9])) STOP 30 + + deallocate (two%a(1)%x) + one = two + if (.not. allocated (one%a)) STOP 31 + if (allocated (one%a(1)%x)) STOP 32 + if (.not. allocated (one%a(2)%x)) STOP 33 + + if (size(one%a) /= 2) STOP 34 + if (size(one%a(2)%x) /= 5) STOP 35 + if (any (one%a(2)%x /= [5,6,7,8,9])) STOP 36 + + deallocate (two%a) + one = two + if (allocated (one%a)) STOP 37 + if (allocated (two%a)) STOP 38 +end subroutine test4 + + +call test1 () +call test2 () +call test3 () +call test4 () +end + diff --git a/Fortran/gfortran/regression/class_49.f90 b/Fortran/gfortran/regression/class_49.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_49.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! PR fortran/52029 +! + +elemental subroutine foo() + type t + end type t + class(t), allocatable :: x + if (allocated(x)) i = 5 +end diff --git a/Fortran/gfortran/regression/class_4a.f03 b/Fortran/gfortran/regression/class_4a.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_4a.f03 @@ -0,0 +1,15 @@ +! { dg-do link } +! { dg-additional-sources "class_4b.f03 class_4c.f03" } +! +! Test the fix for PR41583, in which the different source files +! would generate the same 'vindex' for different class declared +! types. +! +! The test comprises class_4a, class_4b and class_4c.f03 + +! Contributed by Tobias Burnus +! +module m + type t + end type t +end module m diff --git a/Fortran/gfortran/regression/class_4b.f03 b/Fortran/gfortran/regression/class_4b.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_4b.f03 @@ -0,0 +1,16 @@ +! Don't compile this anywhere. +! { dg-do compile { target { lp64 && { ! lp64 } } } } +! +! Test the fix for PR41583, in which the different source files +! would generate the same 'vindex' for different class declared +! types. +! +! The test comprises class_4a, class_4b class_4c.f03 +! +! Contributed by Tobias Burnus +! +module m2 + use m + type, extends(t) :: t2 + end type t2 +end module m2 diff --git a/Fortran/gfortran/regression/class_4c.f03 b/Fortran/gfortran/regression/class_4c.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_4c.f03 @@ -0,0 +1,29 @@ +! Don't compile this anywhere. +! { dg-do compile { target { lp64 && { ! lp64 } } } } +! +! Test the fix for PR41583, in which the different source files +! would generate the same 'vindex' for different class declared +! types. +! +! The test comprises class_4a, class_4b and class_4c.f03 +! +! Contributed by Tobias Burnus +! + use m + use m2 + type,extends(t) :: t3 + end type t3 + + integer :: i + class(t), allocatable :: a + allocate(t3 :: a) + select type(a) + type is(t) + i = 1 + type is(t2) + i = 2 + type is(t3) + i = 3 + end select + print *, i +end diff --git a/Fortran/gfortran/regression/class_5.f03 b/Fortran/gfortran/regression/class_5.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_5.f03 @@ -0,0 +1,30 @@ +! { dg-do compile } +! +! PR 41719: [OOP] invalid: Intrinsic assignment involving polymorphic variables +! +! Contributed by Tobias Burnus + + implicit none + + type t1 + integer :: a + end type + + type, extends(t1) :: t2 + integer :: b + end type + + class(t1),pointer :: cp + type(t2) :: x + + x = t2(45,478) + allocate(t2 :: cp) + + cp = x ! { dg-error "Nonallocatable variable must not be polymorphic" } + + select type (cp) + type is (t2) + print *, cp%a, cp%b + end select + +end diff --git a/Fortran/gfortran/regression/class_51.f90 b/Fortran/gfortran/regression/class_51.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_51.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/52270 +! +! From IR F08/0073 by Malcolm Cohen +! + + Program m013 + Type t + Real c + End Type + Type(t),Target :: x + Call sub(x) + Print *,x%c + if (x%c /= 3) STOP 1 + Contains + Subroutine sub(p) + Class(t),Pointer,Intent(In) :: p + p%c = 3 + End Subroutine + End Program + +! { dg-final { scan-tree-dump-times "sub \\(&class" 1 "original" } } diff --git a/Fortran/gfortran/regression/class_52.f90 b/Fortran/gfortran/regression/class_52.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_52.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/52270 +! +! From IR F08/0073 by Malcolm Cohen +! + + Program m013 + Type t + Real c + End Type + Type(t),Target :: x + Call sub(x) ! { dg-error "Fortran 2008: Non-pointer actual argument" } + Print *,x%c + if (x%c /= 3) STOP 1 + Contains + Subroutine sub(p) + Class(t),Pointer,Intent(In) :: p + p%c = 3 + End Subroutine + End Program + diff --git a/Fortran/gfortran/regression/class_53.f90 b/Fortran/gfortran/regression/class_53.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_53.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! +! PR 54778: [OOP] an ICE on invalid OO code +! +! Contributed by Sylwester Arabas + +implicit none + +type :: arr_t + real :: at +end type + +type(arr_t) :: this +class(arr_t) :: elem ! { dg-error "must be dummy, allocatable or pointer" } + +elem = this ! { dg-error "Nonallocatable variable must not be polymorphic in intrinsic assignment" } + +end diff --git a/Fortran/gfortran/regression/class_54.f90 b/Fortran/gfortran/regression/class_54.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_54.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! +! PR 53718: [4.7/4.8 regression] [OOP] gfortran generates asm label twice in the same output file +! +! Contributed by Adrian Prantl + +module m + type t + end type +end module + +subroutine sub1 + use m + class(t), pointer :: a1 +end subroutine + +subroutine sub2 + use m + class(t), pointer :: a2 +end subroutine diff --git a/Fortran/gfortran/regression/class_55.f90 b/Fortran/gfortran/regression/class_55.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_55.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! +! PR 55983: [4.7/4.8 Regression] ICE in find_typebound_proc_uop, at fortran/class.c:2711 +! +! Contributed by Sylwester Arabas + + type :: mpdata_t + class(bcd_t), pointer :: bcx, bcy ! { dg-error "has not been declared" } + end type + type(mpdata_t) :: this + call this%bcx%fill_halos() ! { dg-error "is being used before it is defined" } +end diff --git a/Fortran/gfortran/regression/class_56.f90 b/Fortran/gfortran/regression/class_56.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_56.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! Test fix for PR56575. +! +! Contributed by A Kasahara +! +module lib_container + implicit none + + type:: Object + end type Object + + type:: Container + class(Object):: v ! { dg-error "must be allocatable or pointer" } + end type Container + +contains + + subroutine proc(self) + class(Container), intent(inout):: self + end subroutine proc +end module lib_container + diff --git a/Fortran/gfortran/regression/class_57.f90 b/Fortran/gfortran/regression/class_57.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_57.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! +! PR 59502: [OOP] ICE on invalid on pointer assignment to non-pointer CLASS +! +! Contributed by Andrew Benson + + implicit none + + type :: d + end type + + type :: p + class(d) :: cc ! { dg-error "must be allocatable or pointer" } + end type + +contains + + function pc(pd) + type(p) :: pc + class(d), intent(in), target :: pd + pc%cc => pd ! { dg-error "is not a member of" } + end function + +end diff --git a/Fortran/gfortran/regression/class_58.f90 b/Fortran/gfortran/regression/class_58.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_58.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! +! PR 68440: [OOP] ICE on declaring class variable with wrong attribute +! +! Contributed by Gerhard Steinmetz + +subroutine s + type t + end type + class(t), parameter :: x = t() ! { dg-error "cannot have the PARAMETER attribute" } + class(t), parameter :: y = x ! { dg-error "cannot have the PARAMETER attribute" } + class(t) :: z = t() ! { dg-error "must be dummy, allocatable or pointer" } +end diff --git a/Fortran/gfortran/regression/class_59.f90 b/Fortran/gfortran/regression/class_59.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_59.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! +! PR 71894: [OOP] ICE in gfc_add_component_ref, at fortran/class.c:227 +! +! Contributed by Gerhard Steinmetz + +subroutine s1 + type t + integer :: n + end type + type(t) :: x + class(t) :: y ! { dg-error "must be dummy, allocatable or pointer" } + x = y +end + +subroutine s2 + type t + end type + class(t) :: x ! { dg-error "must be dummy, allocatable or pointer" } + class(t), allocatable :: y + select type (y) + type is (t) + y = x + end select +end diff --git a/Fortran/gfortran/regression/class_6.f03 b/Fortran/gfortran/regression/class_6.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_6.f03 @@ -0,0 +1,21 @@ +! { dg-do run } +! +! PR 41629: [OOP] gimplification error on valid code +! +! Contributed by Janus Weil + + type t1 + integer :: comp + end type + + type(t1), target :: a + + class(t1) :: x + pointer :: x ! This is valid + + a%comp = 3 + x => a + print *,x%comp + if (x%comp/=3) STOP 1 + +end diff --git a/Fortran/gfortran/regression/class_60.f90 b/Fortran/gfortran/regression/class_60.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_60.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! +! PR 66366: [OOP] ICE on invalid with non-allocatable CLASS variable +! +! Contributed by Andrew Benson + +module bug + + type :: t1d + contains + procedure :: interpolate => interp + end type t1d + + type :: tff + class(t1d) :: transfer ! { dg-error "must be allocatable or pointer" } + end type tff + +contains + + double precision function interp(self) + implicit none + class(t1d), intent(inout) :: self + return + end function interp + + double precision function fvb(self) + implicit none + class(tff), intent(inout) :: self + fvb=self%transfer%interpolate() ! { dg-error "is not a member of" } + return + end function fvb + +end module bug diff --git a/Fortran/gfortran/regression/class_61.f90 b/Fortran/gfortran/regression/class_61.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_61.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! PR 78573: [7 Regression] [OOP] ICE in resolve_component, at fortran/resolve.c:13405 +! +! Contributed by Gerhard Steinmetz + +program p + type t1 + class(t2), pointer :: q(2) ! { dg-error "must have a deferred shape" } + end type +end diff --git a/Fortran/gfortran/regression/class_62.f90 b/Fortran/gfortran/regression/class_62.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_62.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! { dg-options "-fcheck=recursion" } +! +! PR 80361: [5/6/7 Regression] bogus recursive call to nonrecursive procedure with -fcheck=recursion +! +! Contributed by Jürgen Reuter + +program main_ut + + implicit none + + type :: prt_spec_expr_t + end type + + type :: prt_expr_t + class(prt_spec_expr_t), allocatable :: x + end type + + type, extends (prt_spec_expr_t) :: prt_spec_list_t + type(prt_expr_t) :: e + end type + + class(prt_spec_list_t), allocatable :: y + + allocate (y) + allocate (prt_spec_list_t :: y%e%x) + deallocate(y) + +end program diff --git a/Fortran/gfortran/regression/class_63.f90 b/Fortran/gfortran/regression/class_63.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_63.f90 @@ -0,0 +1,80 @@ +! { dg-do run } +! +! Tests the fix for PR81758, in which the vpointer for 'ptr' in +! function 'pointer_value' would be set to the vtable of the component +! 'container' rather than that of the component 'vec_elem'. In this test +! case it is ensured that there is a single typebound procedure for both +! types, so that different values are returned. In the original problem +! completely different procedures were involved so that a segfault resulted. +! +! Reduced from the original code of Dimitry Liakh by +! Paul Thomas +! +module types + type, public:: gfc_container_t + contains + procedure, public:: get_value => ContTypeGetValue + end type gfc_container_t + + !Element of a container: + type, public:: gfc_cont_elem_t + integer :: value_p + contains + procedure, public:: get_value => ContElemGetValue + end type gfc_cont_elem_t + + !Vector element: + type, extends(gfc_cont_elem_t), public:: vector_elem_t + end type vector_elem_t + + !Vector: + type, extends(gfc_container_t), public:: vector_t + type(vector_elem_t), allocatable, private :: vec_elem + end type vector_t + + type, public :: vector_iter_t + class(vector_t), pointer, private :: container => NULL() + contains + procedure, public:: get_vector_value => vector_Value + procedure, public:: get_pointer_value => pointer_value + end type + +contains + integer function ContElemGetValue (this) + class(gfc_cont_elem_t) :: this + ContElemGetValue = this%value_p + end function + + integer function ContTypeGetValue (this) + class(gfc_container_t) :: this + ContTypeGetValue = 0 + end function + + integer function vector_Value (this) + class(vector_iter_t) :: this + vector_value = this%container%vec_elem%get_value() + end function + + integer function pointer_value (this) + class(vector_iter_t), target :: this + class(gfc_cont_elem_t), pointer :: ptr + ptr => this%container%vec_elem + pointer_value = ptr%get_value() + end function + + subroutine factory (arg) + class (vector_iter_t), pointer :: arg + allocate (vector_iter_t :: arg) + allocate (vector_t :: arg%container) + allocate (arg%container%vec_elem) + arg%container%vec_elem%value_p = 99 + end subroutine +end module + + use types + class (vector_iter_t), pointer :: x + + call factory (x) + if (x%get_vector_value() .ne. 99) STOP 1 + if (x%get_pointer_value() .ne. 99) STOP 2 +end diff --git a/Fortran/gfortran/regression/class_64.f90 b/Fortran/gfortran/regression/class_64.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_64.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Test the fix for PR80850 in which the _len field was not being +! set for 'arg' in the call to 'foo'. +! + type :: mytype + integer :: i + end type + class (mytype), pointer :: c + + allocate (c, source = mytype (99_8)) + + call foo(c) + call bar(c) + + deallocate (c) + +contains + + subroutine foo (arg) + class(*) :: arg + select type (arg) + type is (mytype) + if (arg%i .ne. 99_8) STOP 1 + end select + end subroutine + + subroutine bar (arg) + class(mytype) :: arg + select type (arg) + type is (mytype) + if (arg%i .ne. 99_8) STOP 2 + end select + end subroutine + +end +! { dg-final { scan-tree-dump-times "arg.*._len" 1 "original" } } diff --git a/Fortran/gfortran/regression/class_65.f90 b/Fortran/gfortran/regression/class_65.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_65.f90 @@ -0,0 +1,41 @@ +! { dg-do run } +! +! Test the fix for PR81447 in which a vtable was not being created +! in the module 'm' so that x->vptr in 's' did not have the same +! value as that in 'p'. +! +! Contributed by Mat Cross +! +Module m + Type :: t + integer :: i + End Type +End Module + +Program p + Use m + Class (t), Allocatable :: x + Interface + Subroutine s(x) + Use m + Class (t), Allocatable :: x + End Subroutine + End Interface + Call s(x) + Select Type (x) + Type Is (t) + Continue + Class Is (t) + STOP 1 + Class Default + STOP 2 + End Select +! Print *, 'ok' +End Program + +Subroutine s(x) + Use m, Only: t + Implicit None + Class (t), Allocatable :: x + Allocate (t :: x) +End Subroutine diff --git a/Fortran/gfortran/regression/class_66.f90 b/Fortran/gfortran/regression/class_66.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_66.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! +! Test the fix for PR78641 in which an ICE occured on assignment +! of a class array constructor to a derived type array. +! +! Contributed by Damian Rouson +! + implicit none + type foo + integer :: i = 99 + end type + type(foo) :: bar(4) + class(foo), allocatable :: barfoo + + allocate(barfoo,source = f(11)) + bar = [f(33), [f(22), barfoo], f(1)] + if (any (bar%i .ne. [33, 22, 11, 1])) STOP 1 + deallocate (barfoo) + +contains + + function f(arg) result(foobar) + class(foo), allocatable :: foobar + integer :: arg + allocate(foobar,source = foo(arg)) + end function + +end program diff --git a/Fortran/gfortran/regression/class_67.f90 b/Fortran/gfortran/regression/class_67.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_67.f90 @@ -0,0 +1,55 @@ +! { dg-do run } +! +! Test the fix for PR78990 in which the scalarization of the assignment +! in the main program failed for two reasons: (i) The conversion of 'v1' +! into a class actual was being done after the call to 'return_t1', giving +! rise to the ICE reported in comment #1; and (ii) The 'info' descriptor, +! required for scalarization was not set, which gave rise to the ICE noted +! by the contributor. +! +! Contributed by Chris Macmackin +! +module test_type + implicit none + + type t1 + integer :: i + contains + procedure :: assign + generic :: assignment(=) => assign + end type t1 + +contains + + elemental subroutine assign(this,rhs) + class(t1), intent(inout) :: this + class(t1), intent(in) :: rhs + this%i = rhs%i + end subroutine assign + + function return_t1(arg) + class(t1), dimension(:), intent(in) :: arg + class(t1), dimension(:), allocatable :: return_t1 + allocate(return_t1(size(arg)), source=arg) + end function return_t1 + + function return_t1_p(arg) + class(t1), dimension(:), intent(in), target :: arg + class(t1), dimension(:), pointer :: return_t1_p + return_t1_p => arg + end function return_t1_p +end module test_type + +program test + use test_type + implicit none + + type(t1), dimension(3) :: v1, v2 + v1%i = [1,2,3] + v2 = return_t1(v1) + if (any (v2%i .ne. v1%i)) STOP 1 + + v1%i = [4,5,6] + v2 = return_t1_p(v1) + if (any (v2%i .ne. v1%i)) STOP 2 +end program test diff --git a/Fortran/gfortran/regression/class_68.f90 b/Fortran/gfortran/regression/class_68.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_68.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! +! Test the fix for PR83148. +! +! Contributed by Neil Carlson +! +module fhypre + use iso_c_binding, only: c_ptr, c_null_ptr + use iso_c_binding, only: hypre_obj => c_ptr, hypre_null_obj => c_null_ptr + private + public :: hypre_obj, hypre_null_obj +end module + +module hypre_hybrid_type + use fhypre + type hypre_hybrid + type(hypre_obj) :: solver = hypre_null_obj + end type hypre_hybrid +end module + + use hypre_hybrid_type + class(hypre_hybrid), allocatable :: x + allocate (x) +end + diff --git a/Fortran/gfortran/regression/class_69.f90 b/Fortran/gfortran/regression/class_69.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_69.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! +! PR 88047: [9 Regression] ICE in gfc_find_vtab, at fortran/class.c:2843 +! +! Contributed by G. Steinmetz + +subroutine sub_a + type t + end type + class(t) :: x(2) ! { dg-error "must be dummy, allocatable or pointer" } + class(t), parameter :: a(2) = t() ! { dg-error "cannot have the PARAMETER attribute" } + x = a ! { dg-error "Nonallocatable variable must not be polymorphic in intrinsic assignment" } +end + +subroutine sub_b + type t + integer :: n + end type + class(t) :: a, x ! { dg-error "must be dummy, allocatable or pointer" } + x = a ! { dg-error "Nonallocatable variable must not be polymorphic in intrinsic assignment" } +end diff --git a/Fortran/gfortran/regression/class_7.f03 b/Fortran/gfortran/regression/class_7.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_7.f03 @@ -0,0 +1,21 @@ +! { dg-do compile } +! Test fixes for PR41587 and PR41608. +! +! Contributed by Tobias Burnus +! +! PR41587: used to accept the declaration of component 'foo' + type t0 + integer :: j = 42 + end type t0 + type t + integer :: i + class(t0), allocatable :: foo(3) ! { dg-error "deferred shape" } + end type t + +! PR41608: Would ICE on missing type decl + class(t1), pointer :: c ! { dg-error "before it is defined" } + + select type (c) ! { dg-error "shall be polymorphic" } + type is (t0) + end select +end diff --git a/Fortran/gfortran/regression/class_70.f03 b/Fortran/gfortran/regression/class_70.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_70.f03 @@ -0,0 +1,38 @@ +! { dg-do run } +! +! Test the fix for PR57284 - [OOP] ICE with find_array_spec for polymorphic +! arrays. Once thw ICE was fixed, work was needed to fix a segfault while +! determining the size of 'z'. +! +! Contributed by Lorenz Huedepohl +! +module testmod + type type_t + integer :: idx + end type type_t + type type_u + type(type_t), allocatable :: cmp(:) + end type +contains + function foo(a, b) result(add) + class(type_t), intent(in) :: a(:), b(size(a)) + type(type_t) :: add(size(a)) + add%idx = a%idx + b%idx + end function +end module testmod +program p + use testmod + class(type_t), allocatable, dimension(:) :: x, y, z + class(type_u), allocatable :: w + allocate (x, y, source = [type_t (1), type_t(2)]) + z = foo (x, y) + if (any (z%idx .ne. [2, 4])) stop 1 + +! Try something a bit more complicated than the original. + + allocate (w) + allocate (w%cmp, source = [type_t (2), type_t(3)]) + z = foo (w%cmp, y) + if (any (z%idx .ne. [3, 5])) stop 2 + deallocate (w, x, y, z) +end program diff --git a/Fortran/gfortran/regression/class_71.f90 b/Fortran/gfortran/regression/class_71.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_71.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! +! PR fortran/91586 +! +! Contributed by G. Steinmetz +! +program p + type t + class(*), allocatable :: a + end type + class(t) :: x, y ! { dg-error "must be dummy, allocatable or pointer" } + y = x ! { dg-error "Nonallocatable variable must not be polymorphic in intrinsic assignment" } +end diff --git a/Fortran/gfortran/regression/class_72.f90 b/Fortran/gfortran/regression/class_72.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_72.f90 @@ -0,0 +1,83 @@ +! PR fortran/102745 + +implicit none + +type t +end type t + +type, extends(t) :: t2 +end type t2 + +type t3 +end type t3 + +type(t), allocatable :: var +type(t2), allocatable :: v2ar +type(t3), allocatable :: v3ar +class(t), allocatable :: cvar +class(t2), allocatable :: c2var +class(t3), allocatable :: c3var + +call f(var) +call f(v2ar) ! { dg-error "passed TYPE.t2. to TYPE.t." } +call f(v2ar%t) +call f(cvar) +call f(c2var) ! { dg-error "passed CLASS.t2. to TYPE.t." } +call f(c2var%t) + +call f2(var) ! { dg-error "passed TYPE.t. to TYPE.t2." } +call f2(v2ar) +call f2(cvar) ! { dg-error "passed CLASS.t. to TYPE.t2." } +call f2(c2var) + + +var = var +var = v2ar ! { dg-error "TYPE.t2. to TYPE.t." } +var = cvar +var = c2var ! { dg-error "TYPE.t2. to TYPE.t." } + +v2ar = var ! { dg-error "Cannot convert TYPE.t. to TYPE.t2." } +v2ar = v2ar +v2ar = cvar ! { dg-error "Cannot convert TYPE.t. to TYPE.t2." } +v2ar = c2var + +cvar = var +cvar = v2ar +cvar = cvar +cvar = c2var + +c2var = var ! { dg-error "Cannot convert TYPE.t. to CLASS.t2." } +c2var = v3ar ! { dg-error "Cannot convert TYPE.t3. to CLASS.t2." } +c2var = v2ar +c2var = cvar ! { dg-error "Cannot convert CLASS.t. to CLASS.t2." } +c2var = c3var ! { dg-error "Cannot convert CLASS.t3. to CLASS.t2." } +c2var = c2var + +allocate (var, source=var) +allocate (var, source=v2ar) ! { dg-error "incompatible with source-expr" } +allocate (var, source=cvar) +allocate (var, source=c2var) ! { dg-error "incompatible with source-expr" } + +allocate (v2ar, source=var) ! { dg-error "incompatible with source-expr" } +allocate (v2ar, source=v2ar) +allocate (v2ar, source=cvar) ! { dg-error "incompatible with source-expr" } +allocate (v2ar, source=c2var) + +allocate (cvar, source=var) +allocate (cvar, source=v2ar) +allocate (cvar, source=cvar) +allocate (cvar, source=c2var) + +allocate (c2var, source=var) ! { dg-error "incompatible with source-expr" } +allocate (c2var, source=v2ar) +allocate (c2var, source=cvar) ! { dg-error "incompatible with source-expr" } +allocate (c2var, source=c2var) + +contains + subroutine f(x) + type(t) :: x + end + subroutine f2(x) + type(t2) :: x + end +end diff --git a/Fortran/gfortran/regression/class_73.f90 b/Fortran/gfortran/regression/class_73.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_73.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! Error recovery on invalid CLASS(), PARAMETER declarations +! PR fortran/103137 +! PR fortran/103138 +! PR fortran/103693 +! PR fortran/105243 +! Contributed by G.Steinmetz + +program p + type t + character(3) :: c = '(a)' + end type + class(t), parameter :: x = 1. ! { dg-error "PARAMETER attribute" } + class(*), parameter :: y = t() ! { dg-error "PARAMETER attribute" } + class(*), parameter :: z = 1 ! { dg-error "PARAMETER attribute" } + print x%c ! { dg-error "Syntax error" } +end diff --git a/Fortran/gfortran/regression/class_74.f90 b/Fortran/gfortran/regression/class_74.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_74.f90 @@ -0,0 +1,151 @@ +! { dg-do compile } +! { dg-additional-options "-fcoarray=single" } +! +! PR fortran/106856 +! +! Contributed by G. Steinmetz +! +subroutine foo + interface + subroutine bar(x) + type(*) :: x + end subroutine bar + end interface + class(*) :: x, y + allocatable :: x + dimension :: x(:), y(:,:) + codimension :: x[:] + pointer :: y + y => null() + if (allocated(x)) then + call bar(x(2)[1]) + end if + if (associated(y)) then + call bar(y(2,2)) + end if +end subroutine foo + + +program p + class(*), allocatable :: x, y + y = 'abc' + call s1(x, y) +contains + subroutine s1(x, y) + class(*) :: x, y + end + subroutine s2(x, y) + class(*), allocatable :: x, y + optional :: x + end +end + + +subroutine s1 (x) + class(*) :: x + allocatable :: x + dimension :: x(:) + if (allocated (x)) print *, size (x) +end + +subroutine s2 (x) + class(*) :: x + allocatable :: x(:) + if (allocated (x)) print *, size (x) +end + +subroutine s3 (x) + class(*) :: x(:) + allocatable :: x + if (allocated (x)) print *, size (x) +end + +subroutine s4 (x) + class(*) :: x + dimension :: x(:) + allocatable :: x + if (allocated (x)) print *, size (x) +end + + +subroutine c0 (x) + class(*) :: x + allocatable :: x + codimension :: x[:] + dimension :: x(:) + if (allocated (x)) print *, size (x) +end + +subroutine c1 (x) + class(*) :: x(:) + allocatable :: x[:] + if (allocated (x)) print *, size (x) +end + +subroutine c2 (x) + class(*) :: x[:] + allocatable :: x(:) + if (allocated (x)) print *, size (x) +end + +subroutine c3 (x) + class(*) :: x(:)[:] + allocatable :: x + if (allocated (x)) print *, size (x) +end + +subroutine c4 (x) + class(*) :: x + dimension :: x(:) + codimension :: x[:] + allocatable :: x + if (allocated (x)) print *, size (x) +end + + +subroutine p1 (x) + class(*) :: x + pointer :: x + dimension :: x(:) + if (associated (x)) print *, size (x) +end + +subroutine p2 (x) + class(*) :: x + pointer :: x(:) + if (associated (x)) print *, size (x) +end + +subroutine p3 (x) + class(*) :: x(:) + pointer :: x + if (associated (x)) print *, size (x) +end + +subroutine p4 (x) + class(*) :: x + dimension :: x(:) + pointer :: x + if (associated (x)) print *, size (x) +end + + +! Testcase by Mikael Morin +subroutine mm () + pointer :: y + dimension :: y(:,:) + class(*) :: y + if (associated (y)) print *, size (y) +end + +! Testcase from pr53951 +subroutine pr53951 () + type t + end type t + class(t), pointer :: C + TARGET :: A + class(t), allocatable :: A, B + TARGET :: B + C => A ! Valid + C => B ! Valid, but was rejected +end diff --git a/Fortran/gfortran/regression/class_75.f90 b/Fortran/gfortran/regression/class_75.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_75.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-additional-options "-fcoarray=single" } +! +! PR fortran/106856 +! +! +! +subroutine foo(x,y) + class(*), optional :: x, y + optional :: x ! { dg-error "Duplicate OPTIONAL attribute" } + target :: x + allocatable :: x + target :: x ! { dg-error "Duplicate TARGET attribute" } + allocatable :: x ! { dg-error "Duplicate ALLOCATABLE attribute" } + pointer :: y + contiguous :: y + pointer :: y ! { dg-error "Duplicate POINTER attribute" } + contiguous :: y ! { dg-error "Duplicate CONTIGUOUS attribute" } + codimension :: x[:] + dimension :: x(:,:) + dimension :: y(:,:,:) + codimension :: x[:] ! { dg-error "Duplicate CODIMENSION attribute" } + dimension :: y(:) ! { dg-error "Duplicate DIMENSION attribute" } +end diff --git a/Fortran/gfortran/regression/class_8.f03 b/Fortran/gfortran/regression/class_8.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_8.f03 @@ -0,0 +1,16 @@ +! { dg-do compile } +! Test fixes for PR41618. +! +! Contributed by Janus Weil +! + type t1 + integer :: comp + class(t1),pointer :: cc + end type + + class(t1) :: x ! { dg-error "must be dummy, allocatable or pointer" } + + x%comp = 3 + print *,x%comp + +end diff --git a/Fortran/gfortran/regression/class_9.f03 b/Fortran/gfortran/regression/class_9.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_9.f03 @@ -0,0 +1,67 @@ +! { dg-do run } +! Test the fix for PR41706, in which arguments of class methods that +! were themselves class methods did not work. +! +! Contributed by Janus Weil +! +module m +type :: t + real :: v = 1.5 +contains + procedure, nopass :: a + procedure, nopass :: b + procedure, pass :: c + procedure, nopass :: d +end type + +contains + + real function a (x) + real :: x + a = 2.*x + end function + + real function b (x) + real :: x + b = 3.*x + end function + + real function c (x) + class (t) :: x + c = 4.*x%v + end function + + subroutine d (x) + real :: x + if (abs(x-3.0)>1E-3) STOP 1 + end subroutine + + subroutine s (x) + class(t) :: x + real :: r + r = x%a (1.1) ! worked + if (r .ne. a (1.1)) STOP 1 + + r = x%a (b (1.2)) ! worked + if (r .ne. a(b (1.2))) STOP 2 + + r = b ( x%a (1.3)) ! worked + if (r .ne. b(a (1.3))) STOP 3 + + r = x%a(x%b (1.4)) ! failed + if (r .ne. a(b (1.4))) STOP 4 + + r = x%a(x%c ()) ! failed + if (r .ne. a(c (x))) STOP 5 + + call x%d (x%a(1.5)) ! failed + + end subroutine + +end + + use m + class(t),allocatable :: x + allocate(x) + call s (x) +end diff --git a/Fortran/gfortran/regression/class_alias.f90 b/Fortran/gfortran/regression/class_alias.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_alias.f90 @@ -0,0 +1,94 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! test for aliasing violations when converting class objects with +! different target and pointer attributes. +! +module test_module + + implicit none + + type, public :: test + integer :: x + end type test + +contains + + subroutine do_it6 (par2_t) + class (test), target :: par2_t + par2_t%x = par2_t%x + 1 + end subroutine do_it6 + + subroutine do_it5 (par1_p) + class (test), pointer, intent(in) :: par1_p + ! pointer -> target + ! { dg-final { scan-tree-dump "par2_t\[^\n]*VIEW_CONVERT_EXPR\[^\n]*par1_p" "original" } } + call do_it6 (par1_p) + end subroutine do_it5 + + subroutine do_it4 (par_p) + class (test), pointer, intent(in) :: par_p + ! pointer -> pointer + ! { dg-final { scan-tree-dump-not "par1_p\[^\n]*VIEW_CONVERT_EXPR\[^\n]*par_p" "original" } } + call do_it5 (par_p) + end subroutine do_it4 + + subroutine do_it3 (par1_t) + class (test), target :: par1_t + ! target -> pointer + ! { dg-final { scan-tree-dump "par_p\[^\n]*VIEW_CONVERT_EXPR\[^\n]*par1_t" "original" } } + call do_it4 (par1_t) + end subroutine do_it3 + + subroutine do_it2 (par_t) + class (test), target :: par_t + ! target -> target + ! { dg-final { scan-tree-dump-not "par1_t\[^\n]*VIEW_CONVERT_EXPR\[^\n]*par_t" "original" } } + call do_it3 (par_t) + end subroutine do_it2 + + subroutine do_it1 (par1_a) + class (test), allocatable :: par1_a + ! allocatable -> target + ! { dg-final { scan-tree-dump "par_t\[^\n]*VIEW_CONVERT_EXPR\[^\n]*par1_a" "original" } } + call do_it2 (par1_a) + end subroutine do_it1 + + subroutine do_it (par_a) + class (test), allocatable :: par_a + ! allocatable -> allocatable + ! { dg-final { scan-tree-dump-not "par1_a\[^\n]*VIEW_CONVERT_EXPR\[^\n]*par_a" "original" } } + call do_it1 (par_a) + end subroutine do_it + +end module test_module + +use test_module + + implicit none + class (test), allocatable :: var_a + class (test), pointer :: var_p + + + allocate (var_a) + allocate (var_p) + var_a%x = 0 + var_p%x = 0 + + ! allocatable -> allocatable + ! { dg-final { scan-tree-dump-not "par_a\[^\n]*VIEW_CONVERT_EXPR\[^\n]*var_a" "original" } } + call do_it (var_a) + ! allocatable -> target + ! { dg-final { scan-tree-dump "par_t\[^\n]*VIEW_CONVERT_EXPR\[^\n]*var_a" "original" } } + call do_it2 (var_a) + ! pointer -> target + ! { dg-final { scan-tree-dump "par_t\[^\n]*VIEW_CONVERT_EXPR\[^\n]*var_p" "original" } } + call do_it2 (var_p) + ! pointer -> pointer + ! { dg-final { scan-tree-dump-not "par_p\[^\n]*VIEW_CONVERT_EXPR\[^\n]*var_p" "original" } } + call do_it4 (var_p) + if (var_a%x .ne. 2) STOP 1 + if (var_p%x .ne. 2) STOP 2 + deallocate (var_a) + deallocate (var_p) +end diff --git a/Fortran/gfortran/regression/class_allocate_1.f03 b/Fortran/gfortran/regression/class_allocate_1.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_allocate_1.f03 @@ -0,0 +1,98 @@ +! { dg-do run } +! +! Allocating CLASS variables. +! +! Contributed by Janus Weil + + implicit none + + type t1 + integer :: comp = 5 + class(t1),pointer :: cc + end type + + type, extends(t1) :: t2 + integer :: j + end type + + type, extends(t2) :: t3 + integer :: k + end type + + class(t1),pointer :: cp, cp2 + type(t2),pointer :: cp3 + type(t3) :: x + integer :: i + + + ! (1) check that vindex is set correctly (for different cases) + + i = 0 + allocate(cp) + select type (cp) + type is (t1) + i = 1 + type is (t2) + i = 2 + type is (t3) + i = 3 + end select + deallocate(cp) + if (i /= 1) STOP 1 + + i = 0 + allocate(t2 :: cp) + select type (cp) + type is (t1) + i = 1 + type is (t2) + i = 2 + type is (t3) + i = 3 + end select + deallocate(cp) + if (i /= 2) STOP 2 + + i = 0 + allocate(cp, source = x) + select type (cp) + type is (t1) + i = 1 + type is (t2) + i = 2 + type is (t3) + i = 3 + end select + deallocate(cp) + if (i /= 3) STOP 3 + + i = 0 + allocate(t2 :: cp2) + allocate(cp, source = cp2) + allocate(t2 :: cp3) + allocate(cp, source=cp3) + select type (cp) + type is (t1) + i = 1 + type is (t2) + i = 2 + type is (t3) + i = 3 + end select + deallocate(cp) + deallocate(cp2) + if (i /= 2) STOP 4 + + + ! (2) check initialization (default initialization vs. SOURCE) + + allocate(cp) + if (cp%comp /= 5) STOP 5 + deallocate(cp) + + x%comp = 4 + allocate(cp, source=x) + if (cp%comp /= 4) STOP 6 + deallocate(cp) + +end diff --git a/Fortran/gfortran/regression/class_allocate_10.f03 b/Fortran/gfortran/regression/class_allocate_10.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_allocate_10.f03 @@ -0,0 +1,62 @@ +! { dg-do run } +! PR51870 - ALLOCATE with class function expression for SOURCE failed. +! This version of the test allocates class arrays with MOLD. +! +! Reported by Tobias Burnus +! +module show_producer_class + implicit none + type integrand + integer :: variable = 1 + end type integrand + + type show_producer + contains + procedure ,nopass :: create_show + procedure ,nopass :: create_show_array + end type +contains + function create_show () result(new_integrand) + class(integrand) ,allocatable :: new_integrand + allocate(new_integrand) + new_integrand%variable = -1 + end function + function create_show_array (n) result(new_integrand) + class(integrand) ,allocatable :: new_integrand(:) + integer :: n, i + allocate(new_integrand(n)) + select type (new_integrand) + type is (integrand); new_integrand%variable = [(i, i= 1, n)] + end select + end function +end module + +program main + use show_producer_class + implicit none + class(integrand) ,allocatable :: kernel1(:), kernel2(:) + type(show_producer) :: executive_producer + + allocate(kernel1(5), kernel2(5),mold=executive_producer%create_show_array (5)) + select type(kernel1) + type is (integrand); if (any (kernel1%variable .ne. 1)) STOP 1 + end select + + deallocate (kernel1) + + allocate(kernel1(3),mold=executive_producer%create_show ()) + select type(kernel1) + type is (integrand); if (any (kernel1%variable .ne. 1)) STOP 2 + end select + + deallocate (kernel1) + + select type(kernel2) + type is (integrand); kernel2%variable = [1,2,3,4,5] + end select + + allocate(kernel1(3),source = kernel2(3:5)) + select type(kernel1) + type is (integrand); if (any (kernel1%variable .ne. [3,4,5])) STOP 3 + end select +end program diff --git a/Fortran/gfortran/regression/class_allocate_11.f03 b/Fortran/gfortran/regression/class_allocate_11.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_allocate_11.f03 @@ -0,0 +1,60 @@ +! { dg-do run } +! PR48705 - ALLOCATE with class function expression for SOURCE failed. +! This is the original test in the PR. +! +! Reported by Tobias Burnus +! +module generic_deferred + implicit none + type, abstract :: addable + contains + private + procedure(add), deferred :: a + generic, public :: operator(+) => a + end type addable + abstract interface + function add(x, y) result(res) + import :: addable + class(addable), intent(in) :: x, y + class(addable), allocatable :: res + end function add + end interface + type, extends(addable) :: vec + integer :: i(2) + contains + procedure :: a => a_vec + end type +contains + function a_vec(x, y) result(res) + class(vec), intent(in) :: x + class(addable), intent(in) :: y + class(addable), allocatable :: res + integer :: ii(2) + select type(y) + class is (vec) + ii = y%i + end select + allocate(vec :: res) + select type(res) + type is (vec) + res%i = x%i + ii + end select + end function +end module generic_deferred +program prog + use generic_deferred + implicit none + type(vec) :: x, y + class(addable), allocatable :: z +! x = vec( (/1,2/) ); y = vec( (/2,-2/) ) + x%i = (/1,2/); y%i = (/2,-2/) + allocate(z, source= x + y) + select type(z) + type is(vec) + if (z%i(1) /= 3 .or. z%i(2) /= 0) then + write(*,*) 'FAIL' + else + write(*,*) 'OK' + end if + end select +end program prog diff --git a/Fortran/gfortran/regression/class_allocate_12.f90 b/Fortran/gfortran/regression/class_allocate_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_allocate_12.f90 @@ -0,0 +1,90 @@ +! { dg-do run } +! +! PR fortran/51972 +! +! Contributed by Damian Rouson +! +module surrogate_module + type ,abstract :: surrogate + end type +end module + +module strategy_module + use surrogate_module + + type :: strategy + end type +end module + +module integrand_module + use surrogate_module + use strategy_module + implicit none + + type ,abstract, extends(surrogate) :: integrand + class(strategy), allocatable :: quadrature + end type +end module integrand_module + +module lorenz_module + use strategy_module + use integrand_module + implicit none + + type ,extends(integrand) :: lorenz + real, dimension(:), allocatable :: state + contains + procedure ,public :: assign => assign_lorenz + end type +contains + type(lorenz) function constructor(initial_state, this_strategy) + real ,dimension(:) ,intent(in) :: initial_state + class(strategy) ,intent(in) :: this_strategy + constructor%state=initial_state + allocate (constructor%quadrature, source=this_strategy) + end function + + subroutine assign_lorenz(lhs,rhs) + class(lorenz) ,intent(inout) :: lhs + class(integrand) ,intent(in) :: rhs + select type(rhs) + class is (lorenz) + allocate (lhs%quadrature, source=rhs%quadrature) + lhs%state=rhs%state + end select + end subroutine +end module lorenz_module + +module runge_kutta_2nd_module + use surrogate_module,only : surrogate + use strategy_module ,only : strategy + use integrand_module,only : integrand + implicit none + + type, extends(strategy) ,public :: runge_kutta_2nd + contains + procedure, nopass :: integrate + end type +contains + subroutine integrate(this) + class(surrogate) ,intent(inout) :: this + class(integrand) ,allocatable :: this_half + + select type (this) + class is (integrand) + allocate (this_half, source=this) + end select + end subroutine +end module + +program main + use lorenz_module + use runge_kutta_2nd_module ,only : runge_kutta_2nd, integrate + implicit none + + type(runge_kutta_2nd) :: timed_lorenz_integrator + type(lorenz) :: attractor + + attractor = constructor( [1., 1., 1.] , timed_lorenz_integrator) + call integrate(attractor) +end program main diff --git a/Fortran/gfortran/regression/class_allocate_13.f90 b/Fortran/gfortran/regression/class_allocate_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_allocate_13.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! +! PR 54784: [4.7/4.8 Regression] [OOP] wrong code in polymorphic allocation with SOURCE +! +! Contributed by Jeremy Kozdon + +program bug + implicit none + + type :: block + real, allocatable :: fields + end type + + type :: list + class(block),allocatable :: B + end type + + type :: domain + type(list),dimension(2) :: L + end type + + type(domain) :: d + type(block) :: b1 + + allocate(b1%fields,source=5.) + + allocate(d%L(2)%B,source=b1) ! wrong code + + if (d%L(2)%B%fields/=5.) STOP 1 + +end program diff --git a/Fortran/gfortran/regression/class_allocate_14.f90 b/Fortran/gfortran/regression/class_allocate_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_allocate_14.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/56845 +! +module m +type t +integer ::a +end type t +contains +subroutine sub + type(t), save, allocatable :: x + class(t), save,allocatable :: y + if (.not. same_type_as(x,y)) STOP 1 +end subroutine sub +subroutine sub2 + type(t), save, allocatable :: a(:) + class(t), save,allocatable :: b(:) + if (.not. same_type_as(a,b)) STOP 2 +end subroutine sub2 +end module m + +use m +call sub() +call sub2() +end + +! { dg-final { scan-tree-dump-times "static struct __class_m_T_1_0a b = {._data={.data=0B}, ._vptr=&__vtab_m_T};" 1 "original" } } +! { dg-final { scan-tree-dump-times "static struct __class_m_T_a y = {._data=0B, ._vptr=&__vtab_m_T};" 1 "original" } } + diff --git a/Fortran/gfortran/regression/class_allocate_15.f90 b/Fortran/gfortran/regression/class_allocate_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_allocate_15.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original -fdump-tree-original -fmax-stack-var-size=1" } +! +! PR fortran/56845 +! +type t +end type t +type, extends(t) :: t2 +end type t2 +type(t) :: y +call foo() +call bar() +contains + subroutine foo() + class(t), allocatable :: x + if(allocated(x)) STOP 1 + if(.not.same_type_as(x,y)) STOP 2 + allocate (t2 :: x) + end + subroutine bar() + class(t), allocatable :: x(:) + if(allocated(x)) STOP 3 + if(.not.same_type_as(x,y)) STOP 4 + allocate (t2 :: x(4)) + end +end +! { dg-final { scan-tree-dump-times "__builtin_free" 2 "original" } } diff --git a/Fortran/gfortran/regression/class_allocate_16.f90 b/Fortran/gfortran/regression/class_allocate_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_allocate_16.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR 59589: [4.9 Regression] [OOP] Memory leak when deallocating polymorphic +! +! Contributed by Rich Townsend + + implicit none + + type :: foo + real, allocatable :: x(:) + end type + + type :: bar + type(foo) :: f + end type + + class(bar), allocatable :: b + + allocate(bar::b) + allocate(b%f%x(1000000)) + b%f%x = 1. + deallocate(b) + +end + +! { dg-final { scan-tree-dump-times "__builtin_free" 4 "original" } } diff --git a/Fortran/gfortran/regression/class_allocate_17.f90 b/Fortran/gfortran/regression/class_allocate_17.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_allocate_17.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR 60922: [4.9/5 regression] Memory leak with allocatable CLASS components +! +! Contributed by Salvatore Filippone + +program test_leak + implicit none + + type d_base_vect_type + end type + + type d_vect_type + class(d_base_vect_type), allocatable :: v + end type + + call test() + +contains + + subroutine test() + class(d_vect_type), allocatable :: x + allocate(x) + allocate(x%v) + print *,"allocated!" + end subroutine + +end + +! { dg-final { scan-tree-dump-times "fini_coarray" 1 "original" } } diff --git a/Fortran/gfortran/regression/class_allocate_18.f90 b/Fortran/gfortran/regression/class_allocate_18.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_allocate_18.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! +! PR 64230: [4.9/5 Regression] Invalid memory reference in a compiler-generated finalizer for allocatable component +! +! Contributed by Mat Cross + +Program main + Implicit None + Type :: t1 + End Type + Type, Extends (t1) :: t2 + Integer, Allocatable :: i + End Type + Type, Extends (t2) :: t3 + Integer, Allocatable :: j + End Type + Class (t1), Allocatable :: t + Allocate (t3 :: t) + print *,"allocated!" + Deallocate (t) +End diff --git a/Fortran/gfortran/regression/class_allocate_19.f03 b/Fortran/gfortran/regression/class_allocate_19.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_allocate_19.f03 @@ -0,0 +1,47 @@ +! { dg-do run } +! +! Contributed by: Vladimir Fuka + +use iso_c_binding +implicit none +real, target :: e +class(*), allocatable, target :: a(:) +e = 1.0 +call add_element_poly(a,e) +if (size(a) /= 1) STOP 1 +call add_element_poly(a,e) +if (size(a) /= 2) STOP 2 +select type (a) + type is (real) + if (any (a /= [ 1, 1])) STOP 3 +end select +contains + subroutine add_element_poly(a,e) + use iso_c_binding + class(*),allocatable,intent(inout),target :: a(:) + class(*),intent(in),target :: e + class(*),allocatable,target :: tmp(:) + type(c_ptr) :: dummy + + interface + function memcpy(dest,src,n) bind(C,name="memcpy") result(res) + import + type(c_ptr) :: res + integer(c_intptr_t),value :: dest + integer(c_intptr_t),value :: src + integer(c_size_t),value :: n + end function + end interface + + if (.not.allocated(a)) then + allocate(a(1), source=e) + else + allocate(tmp(size(a)),source=a) + deallocate(a) + allocate(a(size(tmp)+1),mold=e) + dummy = memcpy(loc(a(1)),loc(tmp),sizeof(tmp)) + dummy = memcpy(loc(a(size(tmp)+1)),loc(e),sizeof(e)) + end if + end subroutine +end + diff --git a/Fortran/gfortran/regression/class_allocate_2.f03 b/Fortran/gfortran/regression/class_allocate_2.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_allocate_2.f03 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! PR fortran/41582 +! +subroutine test() +type :: t +end type t +class(t), allocatable :: c,d +allocate(t :: d) +allocate(c,source=d) +end + +type, abstract :: t +end type t +type t2 + class(t), pointer :: t +end type t2 + +class(t), allocatable :: a,c,d +type(t2) :: b +allocate(a) ! { dg-error "requires a type-spec or source-expr" } +allocate(b%t) ! { dg-error "requires a type-spec or source-expr" } +end diff --git a/Fortran/gfortran/regression/class_allocate_20.f90 b/Fortran/gfortran/regression/class_allocate_20.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_allocate_20.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! +! PR fortran/64921 +! Test that the finalization wrapper procedure get the always_explicit +! attribute so that the array is not passed without descriptor from +! T3's finalization wrapper procedure to T2's one. +! +! Contributed by Mat Cross + +Program test + Implicit None + Type :: t1 + Integer, Allocatable :: i + End Type + Type :: t2 + Integer, Allocatable :: i + End Type + Type, Extends (t1) :: t3 + Type (t2) :: j + End Type + Type, Extends (t3) :: t4 + Integer, Allocatable :: k + End Type + Call s + Print *, 'ok' +Contains + Subroutine s + Class (t1), Allocatable :: x + Allocate (t4 :: x) + End Subroutine +End Program +! { dg-output "ok" } diff --git a/Fortran/gfortran/regression/class_allocate_21.f90 b/Fortran/gfortran/regression/class_allocate_21.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_allocate_21.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! +! Testcase for pr57117 + +implicit none + + type :: ti + integer :: i + end type + + class(ti), allocatable :: x(:,:), z(:) + integer :: i + + allocate(x(3,3)) + x%i = reshape([( i, i = 1, 9 )], [3, 3]) + allocate(z(9), source=reshape(x, (/ 9 /))) + + if (any( z%i /= [( i, i = 1, 9 )])) STOP 1 + deallocate (x, z) +end + diff --git a/Fortran/gfortran/regression/class_allocate_22.f90 b/Fortran/gfortran/regression/class_allocate_22.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_allocate_22.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! +! Check pr57117 is fixed. + +program pr57117 + implicit none + + type :: ti + integer :: i + end type + + class(ti), allocatable :: x(:,:), y(:,:) + integer :: i + + allocate(x(2,6)) + select type (x) + class is (ti) + x%i = reshape([(i,i=1, 12)],[2,6]) + end select + allocate(y, source=transpose(x)) + + if (any( ubound(y) /= [6,2])) STOP 1 + if (any(reshape(y(:,:)%i, [12]) /= [ 1,3,5,7,9,11, 2,4,6,8,10,12])) STOP 2 + deallocate (x,y) +end + diff --git a/Fortran/gfortran/regression/class_allocate_23.f08 b/Fortran/gfortran/regression/class_allocate_23.f08 --- /dev/null +++ b/Fortran/gfortran/regression/class_allocate_23.f08 @@ -0,0 +1,31 @@ +! { dg-do run } +! +! Test that pr78356 is fixed. +! Contributed by Janus Weil and Andrew Benson + +program p + implicit none + type ac + end type + type, extends(ac) :: a + integer, allocatable :: b + end type + type n + class(ac), allocatable :: acr(:) + end type + type(n) :: s,t + allocate(a :: s%acr(1)) + call nncp(s,t) + select type (cl => t%acr(1)) + class is (a) + if (allocated(cl%b)) error stop + class default + error stop + end select +contains + subroutine nncp(self,tg) + type(n) :: self, tg + allocate(tg%acr(1),source=self%acr(1)) + end +end + diff --git a/Fortran/gfortran/regression/class_allocate_24.f90 b/Fortran/gfortran/regression/class_allocate_24.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_allocate_24.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-fcheck=mem" } +! +! Compile time check only, to test that the ICE is fixed in the assignment of the +! default initializer of the class to sf. + +implicit none + +type :: t + integer, pointer :: data => null () +end type + +class(t), dimension(:), allocatable :: sf +allocate (t :: sf (1)) +end + diff --git a/Fortran/gfortran/regression/class_allocate_25.f90 b/Fortran/gfortran/regression/class_allocate_25.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_allocate_25.f90 @@ -0,0 +1,58 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! In the course of fixing PR83118, lots of issues came up with class array +! assignment, where temporaries are generated. This testcase checks that +! the use of assignment by allocate with source is OK, especially with array +! constructors using class arrays. While this test did run previously, the +! temporaries for such arrays were malformed with the class as the type and +! element lengths of 72 bytes rather than the 4 bytes of the decalred type. +! +! Contributed by Dominique d'Humieres +! +type t1 + integer :: i = 5 +end type t1 +type, extends(t1) :: t2 + integer :: j = 6 +end type t2 + +class(t1), allocatable :: a(:), b(:), c(:) +integer :: i + +allocate(t2 :: a(3)) +allocate(t2 :: b(5)) +if (.not.check_t1 (a, [(5, i = 1, 3)], 2)) stop 1 + +allocate(c, source=[a, b ]) ! F2008, PR 44672 +if (.not.check_t1 (c, [(5, i = 1, 8)], 1)) stop 2 + +deallocate(c) +allocate(c(8), source=[ a, b ]) +if (.not.check_t1 (c, [(5, i = 1, 8)], 1)) stop 3 + +deallocate(c) +c = [t1 :: a, b ] ! F2008, PR 43366 +if (.not.check_t1 (c, [(5, i = 1, 8)], 1)) stop 4 +deallocate(a, b, c) + +contains + + logical function check_t1 (arg, array, t) + class(t1) :: arg(:) + integer :: array (:), t + check_t1 = .true. + select type (arg) + type is (t1) + if (any (arg%i .ne. array)) check_t1 = .false. + if (t .eq. 2) check_t1 = .false. + type is (t2) + if (any (arg%i .ne. array)) check_t1 = .false. + if (t .eq. 1) check_t1 = .false. + class default + check_t1 = .false. + end select + end function check_t1 + +end +! { dg-final { scan-tree-dump-times "elem_len=72" 0 "original" } } diff --git a/Fortran/gfortran/regression/class_allocate_3.f03 b/Fortran/gfortran/regression/class_allocate_3.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_allocate_3.f03 @@ -0,0 +1,39 @@ +! { dg-do run } +! +! PR 41581: [OOP] Allocation of a CLASS with SOURCE= does not work +! +! Contributed by Tobias Burnus + + type t + end type t + + type,extends(t) :: t2 + integer :: i = 54 + real :: r = 384.02 + end type t2 + + class(t), allocatable :: m1, m2 + + allocate(t2 :: m2) + select type(m2) + type is (t2) + print *, m2%i, m2%r + if (m2%i/=54) STOP 1 + if (abs(m2%r-384.02)>1E-3) STOP 2 + m2%i = 42 + m2%r = -4.0 + class default + STOP 3 + end select + + allocate(m1, source=m2) + select type(m1) + type is (t2) + print *, m1%i, m1%r + if (m1%i/=42) STOP 4 + if (abs(m1%r+4.0)>1E-3) STOP 5 + class default + STOP 6 + end select + +end diff --git a/Fortran/gfortran/regression/class_allocate_4.f03 b/Fortran/gfortran/regression/class_allocate_4.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_allocate_4.f03 @@ -0,0 +1,23 @@ +! { dg-do run } +! +! PR 41714: [OOP] ALLOCATE SOURCE= does not properly copy the value from SOURCE +! +! Contributed by Tobias Burnus + +type t + integer :: i +end type t +type, extends(t) :: t2 + integer :: j +end type t2 + +class(t), allocatable :: a +allocate(a, source=t2(1,2)) +print *,a%i +if(a%i /= 1) STOP 1 +select type (a) + type is (t2) + print *,a%j + if(a%j /= 2) STOP 2 +end select +end diff --git a/Fortran/gfortran/regression/class_allocate_5.f90 b/Fortran/gfortran/regression/class_allocate_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_allocate_5.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! +! PR fortran/45451 +! +! Contributed by Salvatore Filippone and Janus Weil +! +! Check that ALLOCATE with SOURCE= does a deep copy. +! +program bug23 + implicit none + + type :: psb_base_sparse_mat + integer, allocatable :: irp(:) + end type psb_base_sparse_mat + + class(psb_base_sparse_mat), allocatable :: a + type(psb_base_sparse_mat) :: acsr + + allocate(acsr%irp(4)) + acsr%irp(1:4) = (/1,3,4,5/) + + write(*,*) acsr%irp(:) + + allocate(a,source=acsr) + + write(*,*) a%irp(:) + + call move_alloc(acsr%irp, a%irp) + + write(*,*) a%irp(:) + + if (any (a%irp /= [1,3,4,5])) STOP 1 +end program bug23 + diff --git a/Fortran/gfortran/regression/class_allocate_6.f03 b/Fortran/gfortran/regression/class_allocate_6.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_allocate_6.f03 @@ -0,0 +1,46 @@ +! { dg-do run } +! +! PR 46174: [OOP] ALLOCATE with SOURCE: Deep copy missing +! +! Contributed by Tobias Burnus + +implicit none +type t +end type t + +type, extends(t) :: t2 + integer, allocatable :: a(:) +end type t2 + +class(t), allocatable :: x, y +integer :: i + +allocate(t2 :: x) +select type(x) + type is (t2) + allocate(x%a(10)) + x%a = [ (i, i = 1,10) ] + print '(*(i3))', x%a + class default + STOP 1 +end select + +allocate(y, source=x) + +select type(x) + type is (t2) + x%a = [ (i, i = 11,20) ] + print '(*(i3))', x%a + class default + STOP 2 +end select + +select type(y) + type is (t2) + print '(*(i3))', y%a + if (any (y%a /= [ (i, i = 1,10) ])) STOP 3 + class default + STOP 4 +end select + +end diff --git a/Fortran/gfortran/regression/class_allocate_7.f03 b/Fortran/gfortran/regression/class_allocate_7.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_allocate_7.f03 @@ -0,0 +1,33 @@ +! { dg-do run } +! PR51870 - ALLOCATE with class function expression for SOURCE failed. +! This is the original test in the PR. +! +! Reported by Tobias Burnus +! +module show_producer_class + implicit none + type integrand + integer :: variable = -1 + end type integrand + + type show_producer + contains + procedure ,nopass :: create_show + end type +contains + function create_show () result(new_integrand) + class(integrand) ,allocatable :: new_integrand + allocate(new_integrand) + new_integrand%variable = 99 + end function +end module + +program main + use show_producer_class + implicit none + class(integrand) ,allocatable :: kernel + type(show_producer) :: executive_producer + + allocate(kernel,source=executive_producer%create_show ()) + if (kernel%variable .ne. 99) STOP 1 +end program diff --git a/Fortran/gfortran/regression/class_allocate_8.f03 b/Fortran/gfortran/regression/class_allocate_8.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_allocate_8.f03 @@ -0,0 +1,51 @@ +! { dg-do run } +! PR51870 - ALLOCATE with class function expression for SOURCE failed. +! This version of the test allocates class arrays. +! +! Reported by Tobias Burnus +! +module show_producer_class + implicit none + type integrand + integer :: variable = 0 + end type integrand + + type show_producer + contains + procedure ,nopass :: create_show + procedure ,nopass :: create_show_array + end type +contains + function create_show () result(new_integrand) + class(integrand) ,allocatable :: new_integrand + allocate(new_integrand) + new_integrand%variable = -1 + end function + function create_show_array (n) result(new_integrand) + class(integrand) ,allocatable :: new_integrand(:) + integer :: n, i + allocate(new_integrand(n)) + select type (new_integrand) + type is (integrand); new_integrand%variable = [(i, i= 1, n)] + end select + end function +end module + +program main + use show_producer_class + implicit none + class(integrand) ,allocatable :: kernel(:) + type(show_producer) :: executive_producer + + allocate(kernel(5),source=executive_producer%create_show_array (5)) + select type(kernel) + type is (integrand); if (any (kernel%variable .ne. [1,2,3,4,5])) STOP 1 + end select + + deallocate (kernel) + + allocate(kernel(3),source=executive_producer%create_show ()) + select type(kernel) + type is (integrand); if (any (kernel%variable .ne. -1)) STOP 2 + end select +end program diff --git a/Fortran/gfortran/regression/class_allocate_9.f03 b/Fortran/gfortran/regression/class_allocate_9.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_allocate_9.f03 @@ -0,0 +1,34 @@ +! { dg-do run } +! PR51870 - ALLOCATE with class function expression for SOURCE failed. +! This is the original test in the PR. +! +! Reported by Tobias Burnus +! +module show_producer_class + implicit none + type integrand + integer :: variable = -1 + end type integrand + + type show_producer + contains + procedure ,nopass :: create_show + end type +contains + function create_show () result(new_integrand) + class(integrand) ,allocatable :: new_integrand + allocate(new_integrand) + new_integrand%variable = 99 + end function +end module + +program main + use show_producer_class + implicit none + class(integrand) ,allocatable :: kernel1, kernel2 + type(show_producer) :: executive_producer + + allocate(kernel1, kernel2,mold=executive_producer%create_show ()) + if (kernel1%variable .ne. -1) STOP 1 + if (kernel2%variable .ne. -1) STOP 2 +end program diff --git a/Fortran/gfortran/regression/class_array_1.f03 b/Fortran/gfortran/regression/class_array_1.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_array_1.f03 @@ -0,0 +1,76 @@ +! { dg-do run } +! +! Test functionality of allocatable class arrays: +! ALLOCATE with source, ALLOCATED, DEALLOCATE, passing as arguments for +! ELEMENTAL and non-ELEMENTAL procedures, SELECT TYPE and LOWER/UPPER. +! + type :: type1 + integer :: i + end type + type, extends(type1) :: type2 + real :: r + end type + class(type1), allocatable, dimension (:) :: x + + allocate(x(2), source = type2(42,42.0)) + call display(x, [1], [2], t2 = [type2(42,42.0),type2(42,42.0)]) + call display(x, [1], [2], t2 = [type2(111,99.0),type2(111,99.0)]) + if (allocated (x)) deallocate (x) + + allocate(x(1:4), source = [(type2(i,42.0 + float (i)), i = 1, 4)]) + call display(x, [1], [4], t2 = [(type2(i,42.0 + float (i)), i = 1, 4)]) + call display(x, [1], [4], t2 = [(type2(111,99.0), i = 1, 4)]) + + if (any (disp (x) .ne. [99.0,99.0,99.0,99.0])) STOP 1 + + if (allocated (x)) deallocate (x) + + allocate(x(1:4), source = type1(42)) + call display(x, [1], [4], t1 = [(type1(42), i = 1, 4)]) + call display(x, [1], [4], t1 = [type1(42),type1(99),type1(42),type1(42)]) + if (any (disp (x) .ne. [0.0,0.0,0.0,0.0])) STOP 2 + +contains + subroutine display(x, lower, upper, t1, t2) + class(type1), allocatable, dimension (:) :: x + integer, dimension (:) :: lower, upper + type(type1), optional, dimension(:) :: t1 + type(type2), optional, dimension(:) :: t2 + select type (x) + type is (type1) + if (present (t1)) then + if (any (x%i .ne. t1%i)) STOP 3 + else + STOP 4 + end if + x(2)%i = 99 + type is (type2) + if (present (t2)) then + if (any (x%i .ne. t2%i)) STOP 5 + if (any (x%r .ne. t2%r)) STOP 6 + else + STOP 7 + end if + x%i = 111 + x%r = 99.0 + end select + call bounds (x, lower, upper) + end subroutine + subroutine bounds (x, lower, upper) + class(type1), allocatable, dimension (:) :: x + integer, dimension (:) :: lower, upper + if (any (lower .ne. lbound (x))) STOP 8 + if (any (upper .ne. ubound (x))) STOP 9 + end subroutine + elemental function disp(y) result(ans) + class(type1), intent(in) :: y + real :: ans + select type (y) + type is (type1) + ans = 0.0 + type is (type2) + ans = y%r + end select + end function +end + diff --git a/Fortran/gfortran/regression/class_array_10.f03 b/Fortran/gfortran/regression/class_array_10.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_array_10.f03 @@ -0,0 +1,18 @@ +! { dg-do compile } +! +! PR fortran/41587 +! This program was leading to an ICE related to class allocatable arrays +! +! Contributed by Dominique D'Humieres + +type t0 + integer :: j = 42 +end type t0 +type t + integer :: i + class(t0), allocatable :: foo(:) +end type t +type(t) :: k +allocate(t0 :: k%foo(3)) +print *, k%foo%j +end diff --git a/Fortran/gfortran/regression/class_array_11.f03 b/Fortran/gfortran/regression/class_array_11.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_array_11.f03 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! PR fortran/46356 +! This program was leading to an ICE related to class arrays +! +! Original testcase by Ian Harvey +! Reduced by Janus Weil + + IMPLICIT NONE + + TYPE :: ParentVector + INTEGER :: a + END TYPE ParentVector + +CONTAINS + + SUBROUTINE vector_operation(pvec) + CLASS(ParentVector), INTENT(INOUT) :: pvec(:) + print *,pvec(1)%a + END SUBROUTINE + +END + diff --git a/Fortran/gfortran/regression/class_array_12.f03 b/Fortran/gfortran/regression/class_array_12.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_array_12.f03 @@ -0,0 +1,31 @@ +! { dg-do compile } +! +! PR fortran/51754 +! This program was leading to an ICE related to class arrays +! +! Contributed by Andrew Benson + +module test + private + + type :: componentB + end type componentB + + type :: treeNode + class(componentB), allocatable, dimension(:) :: componentB + end type treeNode + +contains + + function BGet(self) + implicit none + class(componentB), pointer :: BGet + class(treeNode), target, intent(in) :: self + select type (self) + class is (treeNode) + BGet => self%componentB(1) + end select + return + end function BGet + +end module test diff --git a/Fortran/gfortran/regression/class_array_13.f90 b/Fortran/gfortran/regression/class_array_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_array_13.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/41587 +! + +type t0 + integer :: j = 42 +end type t0 + +type t + integer :: i + class(t0), allocatable :: foo(3) ! { dg-error "must have a deferred shape" } +end type t + +type t2 + integer :: i + class(t0), pointer :: foo(3) ! { dg-error "must have a deferred shape" } +end type t2 + +type t3 + integer :: i + class(t0), allocatable :: foo[3] ! { dg-error "Upper bound of last coarray dimension must be '\\*'" } +end type t3 + +end diff --git a/Fortran/gfortran/regression/class_array_14.f90 b/Fortran/gfortran/regression/class_array_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_array_14.f90 @@ -0,0 +1,53 @@ +! { dg-do run } +! +! PR fortran/54618 +! +! Check whether default initialization works with INTENT(OUT) +! and ALLOCATABLE and no segfault occurs with OPTIONAL. +! + +subroutine test1() + type typ1 + integer :: i = 6 + end type typ1 + + type(typ1) :: x + + x%i = 77 + call f(x) + if (x%i /= 6) STOP 1 + call f() +contains + subroutine f(y1) + class(typ1), intent(out), optional :: y1 + end subroutine f +end subroutine test1 + +subroutine test2() + type mytype + end type mytype + type, extends(mytype):: mytype2 + end type mytype2 + + class(mytype), allocatable :: x,y + allocate (mytype2 :: x) + call g(x) + if (allocated (x) .or. .not. same_type_as (x,y)) STOP 2 + + allocate (mytype2 :: x) + call h(x) + if (allocated (x) .or. .not. same_type_as (x,y)) STOP 3 + + call h() +contains + subroutine g(y2) + class(mytype), intent(out), allocatable :: y2 + end subroutine g + subroutine h(y3) + class(mytype), optional, intent(out), allocatable :: y3 + end subroutine h +end subroutine test2 + +call test1() +call test2() +end diff --git a/Fortran/gfortran/regression/class_array_15.f03 b/Fortran/gfortran/regression/class_array_15.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_array_15.f03 @@ -0,0 +1,118 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! Tests the fixes for three bugs with the same underlying cause. All are regressions +! that come about because class array elements end up with a different tree type +! to the class array. In addition, the language specific flag that marks a class +! container is not being set. +! +! PR53876 contributed by Prince Ogunbade +! PR54990 contributed by Janus Weil +! PR54992 contributed by Tobias Burnus +! The two latter bugs were reported by Andrew Benson +! starting at http://gcc.gnu.org/ml/fortran/2012-10/msg00087.html +! +module G_Nodes + type :: nc + type(tn), pointer :: hostNode + end type nc + type, extends(nc) :: ncBh + end type ncBh + type, public, extends(ncBh) :: ncBhStd + double precision :: massSeedData + end type ncBhStd + type, public :: tn + class (ncBh), allocatable, dimension(:) :: cBh + end type tn + type(ncBhStd) :: defaultBhC +contains + subroutine Node_C_Bh_Move(targetNode) + implicit none + type (tn ), intent(inout) , target :: targetNode + class(ncBh), allocatable , dimension(:) :: instancesTemporary +! These two lines resulted in the wrong result: + allocate(instancesTemporary(2),source=defaultBhC) + call Move_Alloc(instancesTemporary,targetNode%cBh) +! These two lines gave the correct result: +!!deallocate(targetNode%cBh) +!!allocate(targetNode%cBh(2)) + targetNode%cBh(1)%hostNode => targetNode + targetNode%cBh(2)%hostNode => targetNode + return + end subroutine Node_C_Bh_Move + function bhGet(self,instance) + implicit none + class (ncBh), pointer :: bhGet + class (tn ), intent(inout), target :: self + integer , intent(in ) :: instance + bhGet => self%cBh(instance) + return + end function bhGet +end module G_Nodes + + call pr53876 + call pr54990 + call pr54992 +end + +subroutine pr53876 + IMPLICIT NONE + TYPE :: individual + integer :: icomp ! Add an extra component to test offset + REAL, DIMENSION(:), ALLOCATABLE :: genes + END TYPE + CLASS(individual), DIMENSION(:), ALLOCATABLE :: indv + allocate (indv(2), source = [individual(1, [99,999]), & + individual(2, [999,9999])]) + CALL display_indv(indv(2)) ! Similarly, reference 2nd element to test offset +CONTAINS + SUBROUTINE display_indv(self) + CLASS(individual), INTENT(IN) :: self + if (any(self%genes .ne. [999,9999]) )STOP 1 + END SUBROUTINE +END + +subroutine pr54990 + implicit none + type :: ncBhStd + integer :: i + end type + type, extends(ncBhStd) :: ncBhStde + integer :: i2(2) + end type + type :: tn + integer :: i ! Add an extra component to test offset + class (ncBhStd), allocatable, dimension(:) :: cBh + end type + integer :: i + type(tn), target :: a + allocate (a%cBh(2), source = [(ncBhStde(i*99, [1,2]), i = 1,2)]) + select type (q => a%cBh(2)) ! Similarly, reference 2nd element to test offset + type is (ncBhStd) + STOP 2 + type is (ncBhStde) + if (q%i .ne. 198) STOP 3! This tests that the component really gets the + end select ! language specific flag denoting a class type +end + +subroutine pr54992 ! This test remains as the original. + use G_Nodes + implicit none + type (tn), target :: b + class(ncBh), pointer :: bh + class(ncBh), allocatable, dimension(:) :: t + allocate(b%cBh(1),source=defaultBhC) + b%cBh(1)%hostNode => b +! #1 this worked + if (loc(b) .ne. loc(b%cBh(1)%hostNode)) STOP 4 + call Node_C_Bh_Move(b) +! #2 this worked + if (loc(b) .ne. loc(b%cBh(1)%hostNode)) STOP 5 + if (loc(b) .ne. loc(b%cBh(2)%hostNode)) STOP 6 +! #3 this did not + bh => bhGet(b,instance=1) + if (loc (b) .ne. loc(bh%hostNode)) STOP 7 + bh => bhGet(b,instance=2) + if (loc (b) .ne. loc(bh%hostNode)) STOP 8 +end +! { dg-final { scan-tree-dump-times "builtin_free" 12 "original" } } diff --git a/Fortran/gfortran/regression/class_array_16.f90 b/Fortran/gfortran/regression/class_array_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_array_16.f90 @@ -0,0 +1,70 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +module m + implicit none + type t + end type t + + type, extends(t) :: t2 + end type t2 + + type(t) :: var_t + type(t2) :: var_t2 +contains + subroutine sub(x) + class(t), allocatable, intent(out) :: x(:) + + if (allocated (x)) STOP 1 + if (.not. same_type_as(x, var_t)) STOP 2 + + allocate (t2 :: x(5)) + end subroutine sub + + subroutine sub2(x) + class(t), allocatable, OPTIONAL, intent(out) :: x(:) + + if (.not. present(x)) return + if (allocated (x)) STOP 3 + if (.not. same_type_as(x, var_t)) STOP 4 + + allocate (t2 :: x(5)) + end subroutine sub2 +end module m + +use m +implicit none +class(t), save, allocatable :: y(:) + +if (allocated (y)) STOP 5 +if (.not. same_type_as(y,var_t)) STOP 6 + +call sub(y) +if (.not.allocated(y)) STOP 7 +if (.not. same_type_as(y, var_t2)) STOP 8 +if (size (y) /= 5) STOP 9 + +call sub(y) +if (.not.allocated(y)) STOP 10 +if (.not. same_type_as(y, var_t2)) STOP 11 +if (size (y) /= 5) STOP 12 + +deallocate (y) +if (allocated (y)) STOP 13 +if (.not. same_type_as(y,var_t)) STOP 14 + +call sub2() + +call sub2(y) +if (.not.allocated(y)) STOP 15 +if (.not. same_type_as(y, var_t2)) STOP 16 +if (size (y) /= 5) STOP 17 + +call sub2(y) +if (.not.allocated(y)) STOP 18 +if (.not. same_type_as(y, var_t2)) STOP 19 +if (size (y) /= 5) STOP 20 +end + +! { dg-final { scan-tree-dump-times "__builtin_free" 5 "original" } } +! { dg-final { scan-tree-dump-times "finally" 0 "original" } } diff --git a/Fortran/gfortran/regression/class_array_17.f90 b/Fortran/gfortran/regression/class_array_17.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_array_17.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/57456 +! +module m + implicit none + type t + integer :: i + end type t + type, extends(t) :: t2 + integer :: j + end type t2 +end module m + +program test + use m + implicit none + integer :: i + class(t), save, allocatable :: y(:) + + allocate (t2 :: y(5)) + select type(y) + type is (t2) + do i = 1, 5 + y(i)%i = i + y(i)%j = i*10 + end do + end select + deallocate(y) +end + +! { dg-final { scan-tree-dump-times "__builtin_malloc \\(40\\);" 1 "original" } } diff --git a/Fortran/gfortran/regression/class_array_18.f90 b/Fortran/gfortran/regression/class_array_18.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_array_18.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR fortran/57535 +! +program test + implicit none + type t + integer :: ii = 55 + end type t +contains + function func2() + class(t), allocatable :: func2(:) + allocate(func2(3)) + func2%ii = [111,222,333] + end function func2 +end program test diff --git a/Fortran/gfortran/regression/class_array_19.f90 b/Fortran/gfortran/regression/class_array_19.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_array_19.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! PR 57285: [OOP] ICE on invalid: "gfc_array_dimen_size(): Bad dimension" due to SIZE intrinsic with invalid dim on CLASS dummy +! +! Contributed by Lorenz Hüdepohl + + type type_t + end type +contains + subroutine foo(a) + class(type_t), intent(in) :: a(:) + type(type_t) :: c(size(a,dim=2)) ! { dg-error "is not a valid dimension index" } + end subroutine +end diff --git a/Fortran/gfortran/regression/class_array_2.f03 b/Fortran/gfortran/regression/class_array_2.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_array_2.f03 @@ -0,0 +1,78 @@ +! { dg-do run } +! +! Test functionality of pointer class arrays: +! ALLOCATE with source, ASSOCIATED, DEALLOCATE, passing as arguments for +! ELEMENTAL and non-ELEMENTAL procedures, SELECT TYPE and LOWER/UPPER. +! + type :: type1 + integer :: i + end type + type, extends(type1) :: type2 + real :: r + end type + class(type1), pointer, dimension (:) :: x + + allocate(x(2), source = type2(42,42.0)) + call display(x, [1], [2], t2 = [type2(42,42.0),type2(42,42.0)]) + call display(x, [1], [2], t2 = [type2(111,99.0),type2(111,99.0)]) + if (associated (x)) deallocate (x) + + allocate(x(1:4), source = [(type2(i,42.0 + float (i)), i = 1, 4)]) + call display(x, [1], [4], t2 = [(type2(i,42.0 + float (i)), i = 1, 4)]) + call display(x, [1], [4], t2 = [(type2(111,99.0), i = 1, 4)]) + + if (any (disp (x) .ne. [99.0,99.0,99.0,99.0])) STOP 1 + + if (associated (x)) deallocate (x) + + allocate(x(1:4), source = type1(42)) + call display(x, [1], [4], t1 = [(type1(42), i = 1, 4)]) + call display(x, [1], [4], t1 = [type1(42),type1(99),type1(42),type1(42)]) + if (any (disp (x) .ne. [0.0,0.0,0.0,0.0])) STOP 2 + + if (associated (x)) deallocate (x) + +contains + subroutine display(x, lower, upper, t1, t2) + class(type1), pointer, dimension (:) :: x + integer, dimension (:) :: lower, upper + type(type1), optional, dimension(:) :: t1 + type(type2), optional, dimension(:) :: t2 + select type (x) + type is (type1) + if (present (t1)) then + if (any (x%i .ne. t1%i)) STOP 3 + else + STOP 4 + end if + x(2)%i = 99 + type is (type2) + if (present (t2)) then + if (any (x%i .ne. t2%i)) STOP 5 + if (any (x%r .ne. t2%r)) STOP 6 + else + STOP 7 + end if + x%i = 111 + x%r = 99.0 + end select + call bounds (x, lower, upper) + end subroutine + subroutine bounds (x, lower, upper) + class(type1), pointer, dimension (:) :: x + integer, dimension (:) :: lower, upper + if (any (lower .ne. lbound (x))) STOP 8 + if (any (upper .ne. ubound (x))) STOP 9 + end subroutine + elemental function disp(y) result(ans) + class(type1), intent(in) :: y + real :: ans + select type (y) + type is (type1) + ans = 0.0 + type is (type2) + ans = y%r + end select + end function +end + diff --git a/Fortran/gfortran/regression/class_array_20.f03 b/Fortran/gfortran/regression/class_array_20.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_array_20.f03 @@ -0,0 +1,100 @@ +! { dg-do run } +! +! Test contributed by Thomas L. Clune via pr60322 +! and Antony Lewis via pr64692 + +program class_array_20 + implicit none + + type Foo + end type + + type(foo), dimension(2:3) :: arg + integer :: oneDarr(2) + integer :: twoDarr(2,3) + integer :: x, y + double precision :: P(2, 2) + + ! Checking for PR/60322 + call copyFromClassArray([Foo(), Foo()]) + call copyFromClassArray(arg) + call copyFromClassArray(arg(:)) + + x= 3 + y= 4 + oneDarr = [x, y] + call W([x, y]) + call W(oneDarr) + call W([3, 4]) + + twoDarr = reshape([3, 4, 5, 5, 6, 7], [2, 3]) + call WtwoD(twoDarr) + call WtwoD(reshape([3, 4, 5, 5, 6, 7], [2, 3])) + + ! Checking for PR/64692 + P(1:2, 1) = [1.d0, 2.d0] + P(1:2, 2) = [3.d0, 4.d0] + call AddArray(P(1:2, 2)) + +contains + + subroutine copyFromClassArray(classarray) + class (Foo), intent(in) :: classarray(:) + + if (lbound(classarray, 1) .ne. 1) STOP 1 + if (ubound(classarray, 1) .ne. 2) STOP 2 + if (size(classarray) .ne. 2) STOP 3 + end subroutine + + subroutine AddArray(P) + class(*), target, intent(in) :: P(:) + class(*), pointer :: Pt(:) + + allocate(Pt(1:size(P)), source= P) + + select type (P) + type is (double precision) + if (abs(P(1)-3.d0) .gt. 1.d-8) STOP 4 + if (abs(P(2)-4.d0) .gt. 1.d-8) STOP 5 + class default + STOP 6 + end select + + select type (Pt) + type is (double precision) + if (abs(Pt(1)-3.d0) .gt. 1.d-8) STOP 7 + if (abs(Pt(2)-4.d0) .gt. 1.d-8) STOP 8 + class default + STOP 9 + end select + end subroutine + + subroutine W(ar) + class(*), intent(in) :: ar(:) + + if (lbound(ar, 1) /= 1) STOP 10 + select type (ar) + type is (integer) + ! The indeces 1:2 are essential here, or else one would not + ! note, that the array internally starts at 0, although the + ! check for the lbound above went fine. + if (any (ar(1:2) .ne. [3, 4])) STOP 11 + class default + STOP 12 + end select + end subroutine + + subroutine WtwoD(ar) + class(*), intent(in) :: ar(:,:) + + if (any (lbound(ar) /= [1, 1])) STOP 13 + select type (ar) + type is (integer) + if (any (reshape(ar(1:2,1:3), [6]) .ne. [3, 4, 5, 5, 6, 7])) & + STOP 14 + class default + STOP 15 + end select + end subroutine +end program class_array_20 + diff --git a/Fortran/gfortran/regression/class_array_21.f03 b/Fortran/gfortran/regression/class_array_21.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_array_21.f03 @@ -0,0 +1,97 @@ +! { dg-do run } +! +! Contributed by Andre Vehreschild +! Check more elaborate class array addressing. + +module m1 + + type InnerBaseT + integer, allocatable :: a(:) + end type InnerBaseT + + type, extends(InnerBaseT) :: InnerT + integer :: i + end type InnerT + + type BaseT + class(InnerT), allocatable :: arr(:,:) + contains + procedure P + end type BaseT + +contains + + subroutine indir(this, mat) + class(BaseT) :: this + class(InnerT), intent(inout) :: mat(:,:) + + call this%P(mat) + end subroutine indir + + subroutine P(this, mat) + class(BaseT) :: this + class(InnerT), intent(inout) :: mat(:,:) + integer :: i,j + + mat%i = 42 + do i= 1, ubound(mat, 1) + do j= 1, ubound(mat, 2) + if (.not. allocated(mat(i,j)%a)) then + allocate(mat(i,j)%a(10), source = 72) + end if + end do + end do + mat(1,1)%i = 9 + mat(1,1)%a(5) = 1 + end subroutine + +end module m1 + +program test + use m1 + + class(BaseT), allocatable, target :: o + class(InnerT), pointer :: i_p(:,:) + class(InnerBaseT), allocatable :: i_a(:,:) + integer i,j,l + + allocate(o) + allocate(o%arr(2,2)) + allocate(InnerT::i_a(2,2)) + o%arr%i = 1 + + i_p => o%arr + call o%P(i_p) + if (any(o%arr%i /= reshape([9,42,42,42],[2,2]))) STOP 1 + do l= 1, 10 + do i= 1, 2 + do j= 1,2 + if ((i == 1 .and. j == 1 .and. l == 5 .and. & + o%arr(i,j)%a(5) /= 1) & + .or. (.not. (i == 1 .and. j == 1 .and. l == 5) & + .and. o%arr(i,j)%a(l) /= 72)) STOP 2 + end do + end do + end do + + select type (i_a) + type is (InnerT) + call o%P(i_a) + do l= 1, 10 + do i= 1, 2 + do j= 1,2 + if ((i == 1 .and. j == 1 .and. l == 5 .and. & + i_a(i,j)%a(5) /= 1) & + .or. (.not. (i == 1 .and. j == 1 .and. l == 5) & + .and. i_a(i,j)%a(l) /= 72)) STOP 3 + end do + end do + end do + end select + + i_p%i = 4 + call indir(o, i_p) + if (any(o%arr%i /= reshape([9,42,42,42],[2,2]))) STOP 4 +end program test + +! vim:ts=2:sts=2:cindent:sw=2:tw=80: diff --git a/Fortran/gfortran/regression/class_array_22.f03 b/Fortran/gfortran/regression/class_array_22.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_array_22.f03 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-frepack-arrays " } +! +! Original class_array_11.f03 but with -frepack-arrays a new +! ICE was produced reported in +! PR fortran/69659 +! +! Original testcase by Ian Harvey +! Reduced by Janus Weil + + IMPLICIT NONE + + TYPE :: ParentVector + INTEGER :: a + END TYPE ParentVector + +CONTAINS + + SUBROUTINE vector_operation(pvec) + CLASS(ParentVector), INTENT(INOUT) :: pvec(:) + print *,pvec(1)%a + END SUBROUTINE + +END + diff --git a/Fortran/gfortran/regression/class_array_23.f03 b/Fortran/gfortran/regression/class_array_23.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_array_23.f03 @@ -0,0 +1,37 @@ +! { dg-do run } +! +! Test the fix for PR84538 in which the scalarizer was taking the size +! of 't', rather than 'te', to generate array references. +! +! Contributed by Andrew Benson +! +module bugMod + public + type :: t + integer :: i + end type t + type, extends(t) :: te + integer :: j + end type te +contains + subroutine check(n) + implicit none + class(t), intent(inout), dimension(:) :: n + integer :: i(2) + i = n%i ! Original testcase had this in a write statement. However, + ! it is the scalarizer that is getting the span wrong and so + ! this assignment failed too. + if (any (i .ne. [8,3])) stop 1 + return + end subroutine check +end module bugMod + +program bug + use bugMod + class(t), allocatable, dimension(:) :: n + allocate(te :: n(2)) + n(1:2)%i=[8,3] + if (any (n%i .ne. [8,3])) stop 2 + call check(n) + deallocate (n) +end program bug diff --git a/Fortran/gfortran/regression/class_array_3.f03 b/Fortran/gfortran/regression/class_array_3.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_array_3.f03 @@ -0,0 +1,138 @@ +! { dg-do run } +! +! class based quick sort program - starting point comment #0 of pr41539 +! +! Note assignment with vector index reference fails because temporary +! allocation does not occur - also false dependency detected. Nullification +! of temp descriptor data causes a segfault. +! +module m_qsort + implicit none + type, abstract :: sort_t + contains + procedure(disp), deferred :: disp + procedure(lt_cmp), deferred :: lt_cmp + procedure(assign), deferred :: assign + generic :: operator(<) => lt_cmp + generic :: assignment(=) => assign + end type sort_t + interface + elemental integer function disp(a) + import + class(sort_t), intent(in) :: a + end function disp + end interface + interface + impure elemental logical function lt_cmp(a,b) + import + class(sort_t), intent(in) :: a, b + end function lt_cmp + end interface + interface + impure elemental subroutine assign(a,b) + import + class(sort_t), intent(out) :: a + class(sort_t), intent(in) :: b + end subroutine assign + end interface +contains + + subroutine qsort(a) + class(sort_t), intent(inout),allocatable :: a(:) + class(sort_t), allocatable :: tmp (:) + integer, allocatable :: index_array (:) + integer :: i + allocate (tmp(size (a, 1)), source = a) + index_array = [(i, i = 1, size (a, 1))] + call internal_qsort (tmp, index_array) ! Do not move class elements around until end + a = tmp(index_array) + end subroutine qsort + + recursive subroutine internal_qsort (x, iarray) + class(sort_t), intent(inout),allocatable :: x(:) + class(sort_t), allocatable :: ptr + integer, allocatable :: iarray(:), above(:), below(:), itmp(:) + integer :: pivot, nelem, i, iptr + if (.not.allocated (iarray)) return + nelem = size (iarray, 1) + if (nelem .le. 1) return + pivot = nelem / 2 + allocate (ptr, source = x(iarray(pivot))) ! Pointer to the pivot element + do i = 1, nelem + iptr = iarray(i) ! Index for i'th element + if (ptr%lt_cmp (x(iptr))) then ! Compare pivot with i'th element + itmp = [iptr] + above = concat (itmp, above) ! Invert order to prevent infinite loops + else + itmp = [iptr] + below = concat (itmp, below) ! -ditto- + end if + end do + call internal_qsort (x, above) ! Recursive sort of 'above' and 'below' + call internal_qsort (x, below) + iarray = concat (below, above) ! Concatenate the result + end subroutine internal_qsort + + function concat (ia, ib) result (ic) + integer, allocatable, dimension(:) :: ia, ib, ic + if (allocated (ia) .and. allocated (ib)) then + ic = [ia, ib] + else if (allocated (ia)) then + ic = ia + else if (allocated (ib)) then + ic = ib + end if + end function concat +end module m_qsort + +module test + use m_qsort + implicit none + type, extends(sort_t) :: sort_int_t + integer :: i + contains + procedure :: disp => disp_int + procedure :: lt_cmp => lt_cmp_int + procedure :: assign => assign_int + end type +contains + elemental integer function disp_int(a) + class(sort_int_t), intent(in) :: a + disp_int = a%i + end function disp_int + impure elemental subroutine assign_int (a, b) + class(sort_int_t), intent(out) :: a + class(sort_t), intent(in) :: b ! TODO: gfortran does not throw 'class(sort_int_t)' + select type (b) + class is (sort_int_t) + a%i = b%i + class default + a%i = -1 + end select + end subroutine assign_int + impure elemental logical function lt_cmp_int(a,b) result(cmp) + class(sort_int_t), intent(in) :: a + class(sort_t), intent(in) :: b + select type(b) + type is(sort_int_t) + if (a%i < b%i) then + cmp = .true. + else + cmp = .false. + end if + class default + ERROR STOP "Don't compare apples with oranges" + end select + end function lt_cmp_int +end module test + +program main + use test + class(sort_t), allocatable :: A(:) + integer :: i, m(5)= [7 , 4, 5, 2, 3] + allocate (A(5), source = [(sort_int_t(m(i)), i=1,5)]) +! print *, "Before qsort: ", A%disp() + call qsort(A) +! print *, "After qsort: ", A%disp() + if (any (A%disp() .ne. [2,3,4,5,7])) STOP 1 +end program main diff --git a/Fortran/gfortran/regression/class_array_4.f03 b/Fortran/gfortran/regression/class_array_4.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_array_4.f03 @@ -0,0 +1,25 @@ +! { dg-do run } +! PR43214 - implementation of class arrays +! +! Contributed by Tobias Burnus +! +module m + type t + real :: r = 99 + contains + procedure, pass :: foo => foo + end type t +contains + elemental subroutine foo(x, i) + class(t),intent(in) :: x + integer,intent(inout) :: i + i = x%r + i + end subroutine foo +end module m + + use m + type(t) :: x(3) + integer :: n(3) = [0,100,200] + call x(:)%foo(n) + if (any(n .ne. [99,199,299])) STOP 1 +end diff --git a/Fortran/gfortran/regression/class_array_5.f03 b/Fortran/gfortran/regression/class_array_5.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_array_5.f03 @@ -0,0 +1,24 @@ +! { dg-do compile } +! PR44568 - class array impelementation. +! +! Contributed by Hans-Werner Boschmann +! +module ice6 + + type::a_type + contains + procedure::do_something + end type a_type + + contains + + subroutine do_something(this) + class(a_type),intent(in)::this + end subroutine do_something + + subroutine do_something_else() + class(a_type),dimension(:),allocatable::values + call values(1)%do_something() + end subroutine do_something_else + +end module ice6 diff --git a/Fortran/gfortran/regression/class_array_6.f03 b/Fortran/gfortran/regression/class_array_6.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_array_6.f03 @@ -0,0 +1,32 @@ +! { dg-do compile } +! PR46356 - class arrays +! +! Contributed by Ian Harvey +! +MODULE procedure_intent_nonsense + IMPLICIT NONE + PRIVATE + TYPE, PUBLIC :: Parent + INTEGER :: comp + END TYPE Parent + + TYPE :: ParentVector + INTEGER :: a + ! CLASS(Parent), ALLOCATABLE :: a + END TYPE ParentVector +CONTAINS + SUBROUTINE vector_operation(pvec) + CLASS(ParentVector), INTENT(INOUT) :: pvec(:) + INTEGER :: i + !--- + DO i = 1, SIZE(pvec) + CALL item_operation(pvec(i)) + END DO + ! PRINT *, pvec(1)%a%comp + END SUBROUTINE vector_operation + + SUBROUTINE item_operation(pvec) + CLASS(ParentVector), INTENT(INOUT) :: pvec + !TYPE(ParentVector), INTENT(INOUT) :: pvec + END SUBROUTINE item_operation +END MODULE procedure_intent_nonsense diff --git a/Fortran/gfortran/regression/class_array_7.f03 b/Fortran/gfortran/regression/class_array_7.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_array_7.f03 @@ -0,0 +1,58 @@ +! { dg-do run } +! PR46990 - class array implementation +! +! Contributed by Wolfgang Kilian on comp.lang.fortran - see comment #7 of PR +! +module realloc + implicit none + + type :: base_type + integer :: i + contains + procedure :: assign + generic :: assignment(=) => assign ! define generic assignment + end type base_type + + type, extends(base_type) :: extended_type + integer :: j + end type extended_type + +contains + + impure elemental subroutine assign (a, b) + class(base_type), intent(out) :: a + type(base_type), intent(in) :: b + a%i = b%i + end subroutine assign + + subroutine reallocate (a) + class(base_type), dimension(:), allocatable, intent(inout) :: a + class(base_type), dimension(:), allocatable :: tmp + allocate (tmp (2 * size (a))) ! how to alloc b with same type as a ? + if (trim (print_type ("tmp", tmp)) .ne. "tmp is base_type") STOP 1 + tmp(:size(a)) = a ! polymorphic l.h.s. + call move_alloc (from=tmp, to=a) + end subroutine reallocate + + character(20) function print_type (name, a) + character(*), intent(in) :: name + class(base_type), dimension(:), intent(in) :: a + select type (a) + type is (base_type); print_type = NAME // " is base_type" + type is (extended_type); print_type = NAME // " is extended_type" + end select + end function + +end module realloc + +program main + use realloc + implicit none + class(base_type), dimension(:), allocatable :: a + + allocate (extended_type :: a(10)) + if (trim (print_type ("a", a)) .ne. "a is extended_type") STOP 2 + call reallocate (a) + if (trim (print_type ("a", a)) .ne. "a is base_type") STOP 3 + deallocate (a) +end program main diff --git a/Fortran/gfortran/regression/class_array_8.f03 b/Fortran/gfortran/regression/class_array_8.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_array_8.f03 @@ -0,0 +1,18 @@ +! { dg-do run } +! PR43969 - class array implementation +! +! Contributed by Janus Weil +! + implicit none + + type indx_map + end type + + type desc_type + class(indx_map), allocatable :: indxmap(:) + end type + + type(desc_type) :: desc + if (allocated(desc%indxmap)) STOP 1 + +end diff --git a/Fortran/gfortran/regression/class_array_9.f03 b/Fortran/gfortran/regression/class_array_9.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_array_9.f03 @@ -0,0 +1,44 @@ +! { dg-do run } +! Test typebound elemental functions on class arrays +! +module m + type :: t1 + integer :: i + contains + procedure, pass :: disp => disp_t1 + end type t1 + + type, extends(t1) :: t2 + real :: r + contains + procedure, pass :: disp => disp_t2 + end type t2 + +contains + integer elemental function disp_t1 (q) + class(t1), intent(in) :: q + disp_t1 = q%i + end function + + integer elemental function disp_t2 (q) + class(t2), intent(in) :: q + disp_t2 = int (q%r) + end function +end module + + use m + class(t1), allocatable :: x(:) + allocate (x(4), source = [(t1 (i), i=1,4)]) + if (any (x%disp () .ne. [1,2,3,4])) STOP 1 + if (any (x(2:3)%disp () .ne. [2,3])) STOP 2 + if (any (x(4:3:-1)%disp () .ne. [4,3])) STOP 3 + if (x(4)%disp () .ne. 4) STOP 4 + + deallocate (x) + allocate (x(4), source = [(t2 (2 * i, real (i) + 0.333), i=1,4)]) + if (any (x%disp () .ne. [1,2,3,4])) STOP 5 + if (any (x(2:3)%disp () .ne. [2,3])) STOP 6 + if (any (x(4:3:-1)%disp () .ne. [4,3])) STOP 7 + if (x(4)%disp () .ne. 4) STOP 8 + +end diff --git a/Fortran/gfortran/regression/class_assign_1.f08 b/Fortran/gfortran/regression/class_assign_1.f08 --- /dev/null +++ b/Fortran/gfortran/regression/class_assign_1.f08 @@ -0,0 +1,71 @@ +! { dg-do run } +! +! Check that reallocation of the lhs is done with the correct memory size. + + +module base_mod + + type, abstract :: base + contains + procedure(base_add), deferred :: add + generic :: operator(+) => add + end type base + + abstract interface + module function base_add(l, r) result(res) + class(base), intent(in) :: l + integer, intent(in) :: r + class(base), allocatable :: res + end function base_add + end interface + +contains + + subroutine foo(x) + class(base), intent(inout), allocatable :: x + class(base), allocatable :: t + + t = x + 2 + x = t + 40 + end subroutine foo + +end module base_mod + +module extend_mod + use base_mod + + type, extends(base) :: extend + integer :: i + contains + procedure :: add + end type extend + +contains + module function add(l, r) result(res) + class(extend), intent(in) :: l + integer, intent(in) :: r + class(base), allocatable :: res + select type (l) + class is (extend) + res = extend(l%i + r) + class default + error stop "Unkown class to add to." + end select + end function +end module extend_mod + +program test_poly_ass + use extend_mod + use base_mod + + class(base), allocatable :: obj + obj = extend(0) + call foo(obj) + select type (obj) + class is (extend) + if (obj%i /= 42) error stop + class default + error stop "Result's type wrong." + end select +end program test_poly_ass + diff --git a/Fortran/gfortran/regression/class_assign_2.f90 b/Fortran/gfortran/regression/class_assign_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_assign_2.f90 @@ -0,0 +1,22 @@ +! { dg-do link } +! +! PR 86484:[OOP] Undefined symbol when using polymorphic intrinsic assignment +! +! Contributed by Rich Townsend + +program test_assign + + implicit none + + type :: foo_t + end type + + type, extends (foo_t) :: bar_t + end type + + class(foo_t), allocatable :: f + type(bar_t) :: b + + f = b + +end diff --git a/Fortran/gfortran/regression/class_assign_3.f90 b/Fortran/gfortran/regression/class_assign_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_assign_3.f90 @@ -0,0 +1,9 @@ +! { dg-do link } +! +! PR 84543: undefined reference to __copy_INTEGER_4_.3788 +! +! Contributed by Neil Carlson + +class(*), allocatable :: x +x = 42 +end diff --git a/Fortran/gfortran/regression/class_assign_4.f90 b/Fortran/gfortran/regression/class_assign_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_assign_4.f90 @@ -0,0 +1,185 @@ +! { dg-do run } +! +! In the course of fixing PR83118, lots of issues came up with class array +! assignment, where temporaries are generated. This testcase checks that +! it all works correctly. +! +! Contributed by Paul Thomas +! +module m + implicit none + type :: t1 + integer :: i + CONTAINS + end type + type, extends(t1) :: t2 + real :: r + end type + + interface operator(+) + module procedure add_t1 + end interface + +contains + function add_t1 (a, b) result (c) + class(t1), intent(in) :: a(:), b(:) + class(t1), allocatable :: c(:) + allocate (c, source = a) + c%i = a%i + b%i + select type (c) + type is (t2) + select type (b) + type is (t2) + c%r = c%r + b%r + end select + end select + end function add_t1 + +end module m + +subroutine test_t1 + use m + implicit none + + class(t1), dimension(:), allocatable :: x, y + + x = [t2(1,10.0),t2(2,20.0),t2(3,30.0)] + if (.not.check_t1 (x, [1,2,3], 2, [10, 20, 30]) ) stop 1 + + y = x + x = realloc_t1 (y) + if (.not.check_t1 (x, [3,2,1], 1) ) stop 2 + + x = realloc_t1 (x) + if (.not.check_t1 (x, [2,3,1], 1) ) stop 3 + + x = x([3,1,2]) + if (.not.check_t1 (x, [1,2,3], 1) ) stop 4 + + x = x(3:1:-1) + y + if (.not.check_t1 (x, [4,4,4], 1) ) stop 5 + + x = y + x(3:1:-1) + if (.not.check_t1 (x, [5,6,7], 2) ) stop 6 + +! Now check that the dynamic type survives assignments. + x = [t2(1,10.0),t2(2,20.0),t2(3,30.0)] + y = x + + x = y(3:1:-1) + if (.not.check_t1 (x, [3,2,1], 2, [30,20,10]) ) stop 7 + + x = x(3:1:-1) + y + if (.not.check_t1 (x, [2,4,6], 2, [20,40,60]) ) stop 8 + + x = x(3:1:-1) + if (.not.check_t1 (x, [6,4,2], 2, [60,40,20]) ) stop 9 + + x = x([3,2,1]) + if (.not.check_t1 (x, [2,4,6], 2, [20,40,60]) ) stop 10 + +contains + + function realloc_t1 (arg) result (res) + class(t1), dimension(:), allocatable :: arg + class(t1), dimension(:), allocatable :: res + select type (arg) + type is (t2) + allocate (res, source = [t1 (arg(3)%i), t1 (arg(2)%i), t1 (arg(1)%i)]) + type is (t1) + allocate (res, source = [t1 (arg(2)%i), t1 (arg(1)%i), t1 (arg(3)%i)]) + end select + end function realloc_t1 + + logical function check_t1 (arg, array, t, array2) + class(t1) :: arg(:) + integer :: array (:), t + integer, optional :: array2(:) + check_t1 = .true. + select type (arg) + type is (t1) + if (any (arg%i .ne. array)) check_t1 = .false. + if (t .eq. 2) check_t1 = .false. + type is (t2) + if (any (arg%i .ne. array)) check_t1 = .false. + if (t .eq. 1) check_t1 = .false. + if (present (array2)) then + if (any(int (arg%r) .ne. array2)) check_t1 = .false. + end if + class default + check_t1 = .false. + end select + end function check_t1 + +end subroutine test_t1 + +subroutine test_star + use m + implicit none + + class(*), dimension(:), allocatable :: x, y + + x = [t2(1,10.0),t2(2,20.0),t2(3,30.0)] + if (.not.check_star (x, [1,2,3], 2) ) stop 11 + + y = x + x = realloc_star (y) + if (.not.check_star (x, [3,2,1], 1) ) stop 12 + + x = realloc_star (x) + if (.not.check_star (x, [2,3,1], 1) ) stop 13 + + x = x([3,1,2]) + if (.not.check_star (x, [1,2,3], 1) ) stop 14 + + x = x(3:1:-1) + if (.not.check_star (x, [3,2,1], 1) ) stop 15 + +! Make sure that all is similarly well with type t2. + x = [t2(1,10.0),t2(2,20.0),t2(3,30.0)] + + x = x([3,1,2]) + if (.not.check_star (x, [3,1,2], 2, [30,10,20]) ) stop 16 + + x = x(3:1:-1) + if (.not.check_star (x, [2,1,3], 2, [20,10,30]) ) stop 17 + +contains + + function realloc_star (arg) result (res) + class(*), dimension(:), allocatable :: arg + class(*), dimension(:), allocatable :: res + select type (arg) + type is (t2) + allocate (res, source = [t1 (arg(3)%i), t1 (arg(2)%i), t1 (arg(1)%i)]) + type is (t1) + allocate (res, source = [t1 (arg(2)%i), t1 (arg(1)%i), t1 (arg(3)%i)]) + end select + end function realloc_star + + logical function check_star (arg, array, t, array2) + class(*) :: arg(:) + integer :: array (:), t + integer, optional :: array2(:) + check_star = .true. + select type (arg) + type is (t1) + if (any (arg%i .ne. array)) check_star = .false. + if (t .eq. 2) check_star = .false. + type is (t2) + if (any (arg%i .ne. array)) check_star = .false. + if (t .eq. 1) check_star = .false. + if (present (array2)) then + if (any (int(arg%r) .ne. array2)) check_star = .false. + endif + class default + check_star = .false. + end select + end function check_star + +end subroutine test_star + + + call test_t1 + call test_star +end diff --git a/Fortran/gfortran/regression/class_defined_operator_1.f03 b/Fortran/gfortran/regression/class_defined_operator_1.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_defined_operator_1.f03 @@ -0,0 +1,102 @@ +! { dg-do run } +! Test the fix for PR42385, in which CLASS defined operators +! compiled but were not correctly dynamically dispatched. +! +! Contributed by Janus Weil +! +module foo_module + implicit none + private + public :: foo + + type :: foo + integer :: foo_x + contains + procedure :: times => times_foo + procedure :: assign => assign_foo + generic :: operator(*) => times + generic :: assignment(=) => assign + end type + +contains + + function times_foo(this,factor) result(product) + class(foo) ,intent(in) :: this + class(foo) ,allocatable :: product + integer, intent(in) :: factor + allocate (product, source = this) + product%foo_x = -product%foo_x * factor + end function + + subroutine assign_foo(lhs,rhs) + class(foo) ,intent(inout) :: lhs + class(foo) ,intent(in) :: rhs + lhs%foo_x = -rhs%foo_x + end subroutine + +end module + +module bar_module + use foo_module ,only : foo + implicit none + private + public :: bar + + type ,extends(foo) :: bar + integer :: bar_x + contains + procedure :: times => times_bar + procedure :: assign => assign_bar + end type + +contains + subroutine assign_bar(lhs,rhs) + class(bar) ,intent(inout) :: lhs + class(foo) ,intent(in) :: rhs + select type(rhs) + type is (bar) + lhs%bar_x = rhs%bar_x + lhs%foo_x = -rhs%foo_x + end select + end subroutine + function times_bar(this,factor) result(product) + class(bar) ,intent(in) :: this + integer, intent(in) :: factor + class(foo), allocatable :: product + select type(this) + type is (bar) + allocate(product,source=this) + select type(product) + type is(bar) + product%bar_x = 2*this%bar_x*factor + end select + end select + end function +end module + +program main + use foo_module ,only : foo + use bar_module ,only : bar + implicit none + type(foo) :: unitf + type(bar) :: unitb + +! foo's assign negates, whilst its '*' negates and mutliplies. + unitf%foo_x = 1 + call rescale(unitf, 42) + if (unitf%foo_x .ne. 42) STOP 1 + +! bar's assign negates foo_x, whilst its '*' copies foo_x +! and does a multiply by twice factor. + unitb%foo_x = 1 + unitb%bar_x = 2 + call rescale(unitb, 3) + if (unitb%bar_x .ne. 12) STOP 2 + if (unitb%foo_x .ne. -1) STOP 3 +contains + subroutine rescale(this,scale) + class(foo) ,intent(inout) :: this + integer, intent(in) :: scale + this = this*scale + end subroutine +end program diff --git a/Fortran/gfortran/regression/class_defined_operator_2.f03 b/Fortran/gfortran/regression/class_defined_operator_2.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_defined_operator_2.f03 @@ -0,0 +1,31 @@ +! { dg-do run } +! +! Test the fix for PR99124 which used to ICE as shown. +! +! Contributed by Gerhard Steinmetz +! +module m + type t + integer :: i + contains + procedure :: f + generic :: operator(+) => f + end type +contains + elemental function f(a, b) result(c) + class(t), intent(in) :: a, b + type(t) :: c + c = t(a%i + b%i) + end +end +program p + use m + class(t), allocatable :: x(:), y(:), z + allocate (x, source = [t(1), t(2)]) + allocate (y, source = [t(1), t(2)]) + x = x(2) + y ! ICE + if (any (x%i .ne. [3, 4])) stop 1 + z = x(1) + x = z + y ! ICE + if (any (x%i .ne. [4, 5])) stop 2 +end diff --git a/Fortran/gfortran/regression/class_dummy_1.f03 b/Fortran/gfortran/regression/class_dummy_1.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_dummy_1.f03 @@ -0,0 +1,43 @@ +! { dg-do run } +! +! PR 44541: [OOP] wrong code for polymorphic variable with INTENT(OUT)/Alloc w/ MOLD +! +! Contributed by Tobias Burnus + + implicit none + + type t + integer :: a = 1 + end type t + + type, extends(t) :: t2 + integer :: b = 3 + end type t2 + + type(t2) :: y + + y%a = 44 + y%b = 55 + call intent_out (y) + if (y%a/=1 .or. y%b/=3) STOP 1 + + y%a = 66 + y%b = 77 + call intent_out_unused (y) + if (y%a/=1 .or. y%b/=3) STOP 2 + +contains + + subroutine intent_out(x) + class(t), intent(out) :: x + select type (x) + type is (t2) + if (x%a/=1 .or. x%b/=3) STOP 3 + end select + end subroutine + + subroutine intent_out_unused(x) + class(t), intent(out) :: x + end subroutine + +end diff --git a/Fortran/gfortran/regression/class_dummy_2.f03 b/Fortran/gfortran/regression/class_dummy_2.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_dummy_2.f03 @@ -0,0 +1,31 @@ +! { dg-do run } +! +! PR 45674: [OOP] Undefined references for extended types +! +! Contributed by Dietmar Ebner + +module fails_mod + implicit none + type :: a_t + integer :: a + end type + type, extends(a_t) :: b_t + integer :: b + end type +contains + subroutine foo(a) + class(a_t) :: a + end subroutine foo +end module fails_mod + +module fails_test + implicit none +contains + subroutine bar + use fails_mod + type(b_t) :: b + call foo(b) + end subroutine bar +end module fails_test + +end diff --git a/Fortran/gfortran/regression/class_dummy_3.f03 b/Fortran/gfortran/regression/class_dummy_3.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_dummy_3.f03 @@ -0,0 +1,30 @@ +! { dg-do compile } +! +! PR 46161: [OOP] Invalid: Passing non-polymorphic to allocatable polymorphic dummy +! +! Contributed by Janus Weil + + implicit none + + type :: base + end type + + type, extends(base) :: ext + end type + + type(base), allocatable :: a + class(base), pointer :: b + class(ext), allocatable :: c + + call test(a) ! { dg-error "must be polymorphic" } + call test(b) ! { dg-error "must be ALLOCATABLE" } + call test(c) ! { dg-error "must have the same declared type" } + +contains + + subroutine test(arg) + implicit none + class(base), allocatable :: arg + end subroutine + +end diff --git a/Fortran/gfortran/regression/class_dummy_4.f03 b/Fortran/gfortran/regression/class_dummy_4.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_dummy_4.f03 @@ -0,0 +1,42 @@ +! { dg-do compile } +! +! PR 55037: [4.8 Regression] [OOP] ICE with local allocatable variable of abstract type +! +! Contributed by + +module m1 + implicit none + type, abstract :: c_stv + contains + procedure, pass(x) :: source + end type c_stv +contains + subroutine source(y,x) + class(c_stv), intent(in) :: x + class(c_stv), allocatable, intent(out) :: y + end subroutine source +end module m1 + +module m2 + use m1, only : c_stv + implicit none +contains + subroutine sub(u0) + class(c_stv), intent(inout) :: u0 + class(c_stv), allocatable :: tmp + call u0%source(tmp) + end subroutine sub +end module m2 + + +program p + implicit none + type :: c_stv + end type + class(c_stv), allocatable :: tmp + call source(tmp) +contains + subroutine source(y) + type(c_stv), allocatable, intent(out) :: y + end subroutine +end diff --git a/Fortran/gfortran/regression/class_dummy_5.f90 b/Fortran/gfortran/regression/class_dummy_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_dummy_5.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR 54756: [OOP] [F08] Should reject CLASS, intent(out) in PURE procedures +! +! Contributed by Tobias Burnus + +module m + type t + contains + final :: fnl ! impure finalizer + end type t +contains + impure subroutine fnl(x) + type(t) :: x + print *,"finalized!" + end subroutine +end + +program test + use m + type(t) :: x + call foo(x) +contains + pure subroutine foo(x) ! { dg-error "may not be polymorphic" } + ! pure subroutine would call impure finalizer + class(t), intent(out) :: x + end subroutine +end diff --git a/Fortran/gfortran/regression/class_dummy_6.f90 b/Fortran/gfortran/regression/class_dummy_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_dummy_6.f90 @@ -0,0 +1,65 @@ +! { dg-do run } +! +! Test the fix for PR99819 - explicit shape class arrays in different +! procedures caused an ICE. +! +! Contributed by Gerhard Steinmetz +! +program p + type t + integer :: i + end type + class(t), allocatable :: dum1(:), dum2(:), dum3(:,:) + + allocate (t :: dum1(3), dum2(10), dum3(2,5)) + dum2%i = [1,2,3,4,5,6,7,8,9,10] + dum3%i = reshape ([1,2,3,4,5,6,7,8,9,10],[2,5]) + +! Somewhat elaborated versions of the PR procedures. + if (f (dum1, dum2, dum3) .ne. 10) stop 1 + if (g (dum1) .ne. 3) stop 2 + +! Test the original versions of the procedures. + if (f_original (dum1, dum2) .ne. 3) stop 3 + if (g_original (dum2) .ne. 10) stop 4 + +contains + integer function f(x, y, z) + class(t) :: x(:) + class(t) :: y(size( x)) + class(t) :: z(2,*) + if (size (y) .ne. 3) stop 5 + if (size (z) .ne. 0) stop 6 + select type (y) + type is (t) + f = 1 + if (any (y%i .ne. [1,2,3])) stop 7 + class default + f = 0 + end select + select type (z) + type is (t) + f = f*10 + if (any (z(1,1:4)%i .ne. [1,3,5,7])) stop 8 + class default + f = 0 + end select + end + integer function g(z) + class(t) :: z(:) + type(t) :: u(size(z)) + g = size (u) + end + + integer function f_original(x, y) + class(t) :: x(:) + class(*) :: y(size (x)) + f_original = size (y) + end + + integer function g_original(z) + class(*) :: z(:) + type(t) :: u(size(z)) + g_original = size (u) + end +end diff --git a/Fortran/gfortran/regression/class_dummy_7.f90 b/Fortran/gfortran/regression/class_dummy_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_dummy_7.f90 @@ -0,0 +1,60 @@ +! { dg-do run } +! +! Test the fix for PR46991 - enable class assumed size arrays +! +! Reported by Tobias Burnus +! from http://j3-fortran.org/pipermail/j3/2010-December/004084.html +! submitted by Robert Corbett. +! + MODULE TYPES + PRIVATE + PUBLIC REC, REC2 + + TYPE REC + INTEGER A + END TYPE + + TYPE, EXTENDS(REC) :: REC2 + INTEGER B + END TYPE + END + + SUBROUTINE SUB1(A, N) + USE TYPES + CLASS(REC), INTENT(IN) :: A(*) + INTERFACE + SUBROUTINE SUB2(A, N, IARRAY) + USE TYPES + TYPE(REC) A(*) + INTEGER :: N, IARRAY(N) + END + END INTERFACE + + CALL SUB2(A, N,[1,2,2,3,3,4,4,5,5,6]) + select type (B => A(1:N)) + type is (REC2) + call SUB2(B%REC,N,[1,2,3,4,5,6,7,8,9,10]) + end select + + END + + SUBROUTINE SUB2(A, N, IARRAY) + USE TYPES + TYPE(REC) A(*) + INTEGER :: N, IARRAY(N) + if (any (A(:N)%A .ne. IARRAY(:N))) stop 1 + END + + PROGRAM MAIN + USE TYPES + CLASS(REC), ALLOCATABLE :: A(:) + INTERFACE + SUBROUTINE SUB1(A, N) + USE TYPES + CLASS(REC), INTENT(IN) :: A(*) + END SUBROUTINE + END INTERFACE + + A = [ (REC2(I, I+1), I = 1, 10) ] + CALL SUB1(A, 10) + END diff --git a/Fortran/gfortran/regression/class_dummy_8.f90 b/Fortran/gfortran/regression/class_dummy_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_dummy_8.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! +! PR fortran/105379 +! Type comparison of class containers used to trigger an ICE when one of the +! class containers had a non-constant array spec. +! +! Contributed by Gerhard Steinmetz . + +program p + type t + end type +contains + subroutine s1(x) + class(t) :: x(3) + end + subroutine s2(n, x) + integer :: n + class(t) :: x(n) + end +end diff --git a/Fortran/gfortran/regression/class_dummy_9.f90 b/Fortran/gfortran/regression/class_dummy_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_dummy_9.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! +! PR fortran/105379 +! Type comparison of class containers used to trigger an ICE when one of the +! class containers had a non-constant array spec. +! +! Contributed by Gerhard Steinmetz . + +program p + type t + end type + integer :: m = 3 +contains + subroutine s1(x) + class(t) :: x(3) + end + subroutine s3(x) + class(t) :: x(m) + end +end diff --git a/Fortran/gfortran/regression/class_is_1.f90 b/Fortran/gfortran/regression/class_is_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_is_1.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! PR fortran/66245 +! Original testcase by Gerhard Steinmetz +! +program p + type t; end type + class(t), allocatable :: x + call s + contains + subroutine s + select type ( x ) + class is ( ) ! { dg-error "error in CLASS IS" } + end select + end subroutine s +end program p diff --git a/Fortran/gfortran/regression/class_nameclash.f90 b/Fortran/gfortran/regression/class_nameclash.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_nameclash.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! +! try to provoke class name clashes in gfc_build_class_symbol +! +module test_module + + implicit none + + type, public :: test_p + private + class (test_p), pointer :: next => null() + end type test_p + + type, public :: test +! Error in "call do_it (x)" below: +! Type mismatch in argument 'x' at (1); passed CLASS(test_p) to CLASS(test) + class (test), pointer :: next => null() + end type test + +contains + + subroutine do_it (x) + class (test_p), target :: x + + x%next => x + return + end subroutine do_it + +end module test_module + +use test_module + + implicit none + class (test_p), pointer :: x + + allocate (x) + call do_it (x) + deallocate (x) +end diff --git a/Fortran/gfortran/regression/class_optional_1.f90 b/Fortran/gfortran/regression/class_optional_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_optional_1.f90 @@ -0,0 +1,175 @@ +! { dg-do run } +! { dg-options "-fcoarray=single" } +! +! PR fortran/50981 +! PR fortran/54618 +! + + implicit none + type t + integer, allocatable :: i + end type t + type, extends (t):: t2 + integer, allocatable :: j + end type t2 + + class(t), allocatable :: xa, xa2(:), xac[:], xa2c(:)[:] + class(t), pointer :: xp, xp2(:) + + xp => null() + xp2 => null() + + call suba(alloc=.false., prsnt=.false.) + call suba(xa, alloc=.false., prsnt=.true.) + if (.not. allocated (xa)) STOP 1 + if (.not. allocated (xa%i)) STOP 2 + if (xa%i /= 5) STOP 3 + xa%i = -3 + call suba(xa, alloc=.true., prsnt=.true.) + if (allocated (xa)) STOP 4 + + call suba2(alloc=.false., prsnt=.false.) + call suba2(xa2, alloc=.false., prsnt=.true.) + if (.not. allocated (xa2)) STOP 5 + if (size (xa2) /= 1) STOP 6 + if (.not. allocated (xa2(1)%i)) STOP 7 + if (xa2(1)%i /= 5) STOP 8 + xa2(1)%i = -3 + call suba2(xa2, alloc=.true., prsnt=.true.) + if (allocated (xa2)) STOP 9 + + call subp(alloc=.false., prsnt=.false.) + call subp(xp, alloc=.false., prsnt=.true.) + if (.not. associated (xp)) STOP 10 + if (.not. allocated (xp%i)) STOP 11 + if (xp%i /= 5) STOP 12 + xp%i = -3 + call subp(xp, alloc=.true., prsnt=.true.) + if (associated (xp)) STOP 13 + + call subp2(alloc=.false., prsnt=.false.) + call subp2(xp2, alloc=.false., prsnt=.true.) + if (.not. associated (xp2)) STOP 14 + if (size (xp2) /= 1) STOP 15 + if (.not. allocated (xp2(1)%i)) STOP 16 + if (xp2(1)%i /= 5) STOP 17 + xp2(1)%i = -3 + call subp2(xp2, alloc=.true., prsnt=.true.) + if (associated (xp2)) STOP 18 + + call subac(alloc=.false., prsnt=.false.) + call subac(xac, alloc=.false., prsnt=.true.) + if (.not. allocated (xac)) STOP 19 + if (.not. allocated (xac%i)) STOP 20 + if (xac%i /= 5) STOP 21 + xac%i = -3 + call subac(xac, alloc=.true., prsnt=.true.) + if (allocated (xac)) STOP 22 + + call suba2c(alloc=.false., prsnt=.false.) + call suba2c(xa2c, alloc=.false., prsnt=.true.) + if (.not. allocated (xa2c)) STOP 23 + if (size (xa2c) /= 1) STOP 24 + if (.not. allocated (xa2c(1)%i)) STOP 25 + if (xa2c(1)%i /= 5) STOP 26 + xa2c(1)%i = -3 + call suba2c(xa2c, alloc=.true., prsnt=.true.) + if (allocated (xa2c)) STOP 27 + +contains + subroutine suba2c(x, prsnt, alloc) + class(t), optional, allocatable :: x(:)[:] + logical prsnt, alloc + if (present (x) .neqv. prsnt) STOP 28 + if (prsnt) then + if (alloc .neqv. allocated(x)) STOP 29 + if (.not. allocated (x)) then + allocate (x(1)[*]) + x(1)%i = 5 + else + if (x(1)%i /= -3) STOP 30 + deallocate (x) + end if + end if + end subroutine suba2c + + subroutine subac(x, prsnt, alloc) + class(t), optional, allocatable :: x[:] + logical prsnt, alloc + if (present (x) .neqv. prsnt) STOP 31 + if (present (x)) then + if (alloc .neqv. allocated(x)) STOP 32 + if (.not. allocated (x)) then + allocate (x[*]) + x%i = 5 + else + if (x%i /= -3) STOP 33 + deallocate (x) + end if + end if + end subroutine subac + + subroutine suba2(x, prsnt, alloc) + class(t), optional, allocatable :: x(:) + logical prsnt, alloc + if (present (x) .neqv. prsnt) STOP 34 + if (prsnt) then + if (alloc .neqv. allocated(x)) STOP 35 + if (.not. allocated (x)) then + allocate (x(1)) + x(1)%i = 5 + else + if (x(1)%i /= -3) STOP 36 + deallocate (x) + end if + end if + end subroutine suba2 + + subroutine suba(x, prsnt, alloc) + class(t), optional, allocatable :: x + logical prsnt, alloc + if (present (x) .neqv. prsnt) STOP 37 + if (present (x)) then + if (alloc .neqv. allocated(x)) STOP 38 + if (.not. allocated (x)) then + allocate (x) + x%i = 5 + else + if (x%i /= -3) STOP 39 + deallocate (x) + end if + end if + end subroutine suba + + subroutine subp2(x, prsnt, alloc) + class(t), optional, pointer :: x(:) + logical prsnt, alloc + if (present (x) .neqv. prsnt) STOP 40 + if (present (x)) then + if (alloc .neqv. associated(x)) STOP 41 + if (.not. associated (x)) then + allocate (x(1)) + x(1)%i = 5 + else + if (x(1)%i /= -3) STOP 42 + deallocate (x) + end if + end if + end subroutine subp2 + + subroutine subp(x, prsnt, alloc) + class(t), optional, pointer :: x + logical prsnt, alloc + if (present (x) .neqv. prsnt) STOP 43 + if (present (x)) then + if (alloc .neqv. associated(x)) STOP 44 + if (.not. associated (x)) then + allocate (x) + x%i = 5 + else + if (x%i /= -3) STOP 45 + deallocate (x) + end if + end if + end subroutine subp +end diff --git a/Fortran/gfortran/regression/class_optional_2.f90 b/Fortran/gfortran/regression/class_optional_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_optional_2.f90 @@ -0,0 +1,800 @@ +! { dg-do run } +! { dg-options "-fcoarray=single" } +! +! PR fortran/50981 +! PR fortran/54618 +! PR fortran/55978 + + implicit none + type t + integer, allocatable :: i + end type t + type, extends (t):: t2 + integer, allocatable :: j + end type t2 + + call s1a1() + call s1a() + call s1ac1() + call s1ac() + call s2() + call s2p(psnt=.false.) + call s2caf() + call s2elem() + call s2elem_t() + call s2elem_t2() + call s2t() + call s2tp(psnt=.false.) + call s2t2() + call s2t2p(psnt=.false.) + + call a1a1() + call a1a() + call a1ac1() + call a1ac() + call a2() + call a2p(psnt=.false.) + call a2caf() + + call a3a1() + call a3a() + call a3ac1() + call a3ac() + call a4() + call a4p(psnt=.false.) + call a4caf() + + call ar1a1() + call ar1a() + call ar1ac1() + call ar1ac() + call ar() + call art() + call arp(psnt=.false.) + call artp(psnt=.false.) + +contains + + subroutine s1a1(z, z2, z3, z4, z5) + type(t), optional :: z, z4[*] + type(t), pointer, optional :: z2 + type(t), allocatable, optional :: z3, z5[:] + type(t), allocatable :: x + type(t), pointer :: y + y => null() + call s2(x) + call s2(y) + call s2(z) + call s2(z2) + call s2(z3) + call s2(z4) + call s2(z5) + call s2p(y,psnt=.true.) + call s2p(z2,psnt=.false.) + call s2elem(x) + call s2elem(y) + call s2elem(z) + call s2elem(z2) + call s2elem(z3) + call s2elem(z4) + call s2elem(z5) + call s2elem_t(x) + call s2elem_t(y) + call s2elem_t(z) +! call s2elem_t(z2) ! FIXME: Segfault +! call s2elem_t(z3) ! FIXME: Segfault +! call s2elem_t(z4) ! FIXME: Segfault +! call s2elem_t(z5) ! FIXME: Segfault + call s2caf(z4) + call s2caf(z5) + call ar(x) + call ar(y) + call ar(z) + call ar(z2) + call ar(z3) + call ar(z4) + call ar(z5) + call arp(y,psnt=.true.) + call arp(z2,psnt=.false.) + call s2t(x) + call s2t(y) + call s2t(z) +! call s2t(z2) ! FIXME: Segfault +! call s2t(z3) ! FIXME: Segfault +! call s2t(z4) ! FIXME: Segfault +! call s2t(z5) ! FIXME: Segfault + call s2tp(y,psnt=.true.) + call s2tp(z2,psnt=.false.) + end subroutine s1a1 + subroutine s1a(z, z2, z3, z4, z5) + type(t2), optional :: z, z4[*] + type(t2), optional, pointer :: z2 + type(t2), optional, allocatable :: z3, z5[:] + type(t2), allocatable :: x + type(t2), pointer :: y + y => null() + call s2(x) + call s2(y) + call s2(z) + call s2(z2) + call s2(z3) + call s2(z4) + call s2(z5) + call s2p(y,psnt=.true.) + call s2p(z2,psnt=.false.) + call s2elem(x) + call s2elem(y) + call s2elem(z) + call s2elem(z2) + call s2elem(z3) + call s2elem(z4) + call s2elem(z5) + call s2elem_t2(x) + call s2elem_t2(y) + call s2elem_t2(z) +! call s2elem_t2(z2) ! FIXME: Segfault +! call s2elem_t2(z3) ! FIXME: Segfault +! call s2elem_t2(z4) ! FIXME: Segfault +! call s2elem_t2(z5) ! FIXME: Segfault + call s2caf(z4) + call s2caf(z5) + call ar(x) + call ar(y) + call ar(z) + call ar(z2) + call ar(z3) + call ar(z4) + call ar(z5) + call arp(y,psnt=.true.) + call arp(z2,psnt=.false.) + call s2t2(x) + call s2t2(y) + call s2t2(z) +! call s2t2(z2) ! FIXME: Segfault +! call s2t2(z3) ! FIXME: Segfault + call s2t2(z4) +! call s2t2(z5) ! FIXME: Segfault + call s2t2p(y,psnt=.true.) + call s2t2p(z2,psnt=.false.) + end subroutine s1a + subroutine s1ac1(z, z2, z3, z4, z5) + class(t), optional :: z, z4[*] + class(t), optional, pointer :: z2 + class(t), optional, allocatable :: z3, z5[:] + class(t), allocatable :: x + class(t), pointer :: y + y => null() + call s2(x) + call s2(y) + call s2(z) + call s2(z2) + call s2(z3) + call s2(z4) + call s2(z5) + call s2p(y,psnt=.true.) + call s2p(z2,psnt=.false.) + call s2elem(x) + call s2elem(y) + call s2elem(z) + call s2elem(z2) + call s2elem(z3) + call s2elem(z4) + call s2elem(z5) + call s2elem_t(x) + call s2elem_t(y) +! call s2elem_t(z) ! FIXME: Segfault +! call s2elem_t(z2) ! FIXME: Segfault +! call s2elem_t(z3) ! FIXME: Segfault +! call s2elem_t(z4) ! FIXME: Segfault +! call s2elem_t(z5) ! FIXME: Segfault + call s2caf(z4) + call s2caf(z5) + call ar(x) + call ar(y) + call ar(z) + call ar(z2) + call ar(z3) + call ar(z4) + call ar(z5) + call arp(y,psnt=.true.) + call arp(z2,psnt=.false.) + call s2t(x) + call s2t(y) +! call s2t(z) ! FIXME: Segfault +! call s2t(z2) ! FIXME: Segfault +! call s2t(z3) ! FIXME: Segfault +! call s2t(z4) ! FIXME: Segfault +! call s2t(z5) ! FIXME: Segfault + call s2tp(y,psnt=.true.) + call s2tp(z2,psnt=.false.) + end subroutine s1ac1 + subroutine s1ac(z, z2, z3, z4, z5) + class(t2), optional :: z, z4[*] + class(t2), optional, pointer :: z2 + class(t2), optional, allocatable :: z3, z5[:] + class(t2), allocatable :: x + class(t2), pointer :: y + y => null() + call s2(x) + call s2(y) + call s2(z) + call s2(z2) + call s2(z3) + call s2(z4) + call s2(z5) + call s2p(y,psnt=.true.) + call s2p(z2,psnt=.false.) + call s2elem(x) + call s2elem(y) + call s2elem(z) + call s2elem(z2) + call s2elem(z3) + call s2elem(z4) + call s2elem(z5) + call s2elem_t2(x) +! call s2elem_t2(y) ! FIXME: Segfault +! call s2elem_t2(z) ! FIXME: Segfault +! call s2elem_t2(z2) ! FIXME: Segfault +! call s2elem_t2(z3) ! FIXME: Segfault +! call s2elem_t2(z4) ! FIXME: Segfault +! call s2elem_t2(z5) ! FIXME: Segfault + call s2caf(z4) + call s2caf(z5) + call ar(x) + call ar(y) + call ar(z) + call ar(z2) + call ar(z3) + call ar(z4) + call ar(z5) + call arp(y,psnt=.true.) + call arp(z2,psnt=.false.) + call s2t2(x) + call s2t2(y) +! call s2t2(z) ! FIXME: Segfault +! call s2t2(z2) ! FIXME: Segfault +! call s2t2(z3) ! FIXME: Segfault +! call s2t2(z4) ! FIXME: Segfault +! call s2t2(z5) ! FIXME: Segfault + call s2t2p(y,psnt=.true.) + call s2t2p(z2,psnt=.false.) + end subroutine s1ac + + subroutine s2(x) + class(t), intent(in), optional :: x + if (present (x)) STOP 1 + !print *, present(x) + end subroutine s2 + subroutine s2p(x,psnt) + class(t), intent(in), pointer, optional :: x + logical psnt + if (present (x).neqv. psnt) STOP 2 + !print *, present(x) + end subroutine s2p + subroutine s2caf(x) + class(t), intent(in), optional :: x[*] + if (present (x)) STOP 3 + !print *, present(x) + end subroutine s2caf + subroutine s2t(x) + type(t), intent(in), optional :: x + if (present (x)) STOP 4 + !print *, present(x) + end subroutine s2t + subroutine s2t2(x) + type(t2), intent(in), optional :: x + if (present (x)) STOP 5 + !print *, present(x) + end subroutine s2t2 + subroutine s2tp(x, psnt) + type(t), pointer, intent(in), optional :: x + logical psnt + if (present (x).neqv. psnt) STOP 6 + !print *, present(x) + end subroutine s2tp + subroutine s2t2p(x, psnt) + type(t2), pointer, intent(in), optional :: x + logical psnt + if (present (x).neqv. psnt) STOP 7 + !print *, present(x) + end subroutine s2t2p + impure elemental subroutine s2elem(x) + class(t), intent(in), optional :: x + if (present (x)) STOP 8 + !print *, present(x) + end subroutine s2elem + impure elemental subroutine s2elem_t(x) + type(t), intent(in), optional :: x + if (present (x)) STOP 9 + !print *, present(x) + end subroutine s2elem_t + impure elemental subroutine s2elem_t2(x) + type(t2), intent(in), optional :: x + if (present (x)) STOP 10 + !print *, present(x) + end subroutine s2elem_t2 + + + subroutine a1a1(z, z2, z3, z4, z5) + type(t), optional :: z(:), z4(:)[*] + type(t), optional, pointer :: z2(:) + type(t), optional, allocatable :: z3(:), z5(:)[:] + type(t), allocatable :: x(:) + type(t), pointer :: y(:) + y => null() + call a2(x) + call a2(y) + call a2(z) + call a2(z2) + call a2(z3) + call a2(z4) + call a2(z5) + call a2p(y,psnt=.true.) + call a2p(z2,psnt=.false.) + call a2caf(z4) + call a2caf(z5) + call ar(x) + call ar(y) + call ar(z) + call ar(z2) + call ar(z3) + call ar(z4) + call ar(z5) + call arp(y,psnt=.true.) + call arp(z2,psnt=.false.) +! call s2elem(x) ! FIXME: Segfault +! call s2elem(y) ! FIXME: Segfault +! call s2elem(z) ! FIXME: Segfault +! call s2elem(z2) ! FIXME: Segfault +! call s2elem(z3) ! FIXME: Segfault +! call s2elem(z4) ! FIXME: Segfault +! call s2elem(z5) ! FIXME: Segfault +! call s2elem_t(x) ! FIXME: Conditional jump or move depends on uninitialised value +! call s2elem_t(y) ! FIXME: Conditional jump or move depends on uninitialised value +! call s2elem_t(z) ! FIXME: Conditional jump or move depends on uninitialised value +! call s2elem_t(z2) ! FIXME: Segfault +! call s2elem_t(z3) ! FIXME: Segfault +! call s2elem_t(z4) ! FIXME: Segfault +! call s2elem_t(z5) ! FIXME: Segfault + end subroutine a1a1 + subroutine a1a(z, z2, z3, z4, z5) + type(t2), optional :: z(:), z4(:)[*] + type(t2), optional, pointer :: z2(:) + type(t2), optional, allocatable :: z3(:), z5(:)[:] + type(t2), allocatable :: x(:) + type(t2), pointer :: y(:) + y => null() + call a2(x) + call a2(y) + call a2(z) + call a2(z2) + call a2(z3) + call a2(z4) + call a2(z5) + call a2p(y,psnt=.true.) + call a2p(z2,psnt=.false.) + call a2caf(z4) + call a2caf(z5) + call ar(x) + call ar(y) + call ar(z) + call ar(z2) + call ar(z3) + call ar(z4) + call ar(z5) + call arp(y,psnt=.true.) + call arp(z2,psnt=.false.) +! call s2elem(x) ! FIXME: Segfault +! call s2elem(y) ! FIXME: Segfault +! call s2elem(z) ! FIXME: Segfault +! call s2elem(z2) ! FIXME: Segfault +! call s2elem(z3) ! FIXME: Segfault +! call s2elem(z4) ! FIXME: Segfault +! call s2elem(z5) ! FIXME: Segfault +! call s2elem_t2(x) ! FIXME: Conditional jump or move depends on uninitialised value +! call s2elem_t2(y) ! FIXME: Conditional jump or move depends on uninitialised value +! call s2elem_t2(z) ! FIXME: Conditional jump or move depends on uninitialised value +! call s2elem_t2(z2) ! FIXME: Segfault +! call s2elem_t2(z3) ! FIXME: Segfault +! call s2elem_t2(z4) ! FIXME: Segfault +! call s2elem_t2(z5) ! FIXME: Segfault + end subroutine a1a + subroutine a1ac1(z, z2, z3, z4, z5) + class(t), optional :: z(:), z4(:)[*] + class(t), optional, pointer :: z2(:) + class(t), optional, allocatable :: z3(:), z5(:)[:] + class(t), allocatable :: x(:) + class(t), pointer :: y(:) + y => null() + call a2(x) + call a2(y) + call a2(z) + call a2(z2) + call a2(z3) + call a2(z4) + call a2(z5) + call a2p(y,psnt=.true.) + call a2p(z2,psnt=.false.) + call a2caf(z4) + call a2caf(z5) + call ar(x) + call ar(y) + call ar(z) + call ar(z2) + call ar(z3) + call ar(z4) + call ar(z5) + call arp(y,psnt=.true.) + call arp(z2,psnt=.false.) +! call s2elem(x) ! FIXME: Segfault +! call s2elem(y) ! FIXME: Segfault +! call s2elem(z) ! FIXME: Segfault +! call s2elem(z2) ! FIXME: Segfault +! call s2elem(z3) ! FIXME: Segfault +! call s2elem(z4) ! FIXME: Segfault +! call s2elem(z5) ! FIXME: Segfault +! call s2elem_t(x) ! FIXME: Segfault +! call s2elem_t(y) ! FIXME: Segfault +! call s2elem_t(z) ! FIXME: Segfault +! call s2elem_t(z2) ! FIXME: Segfault +! call s2elem_t(z3) ! FIXME: Segfault +! call s2elem_t(z4) ! FIXME: Segfault +! call s2elem_t(z5) ! FIXME: Segfault + end subroutine a1ac1 + subroutine a1ac(z, z2, z3, z4, z5) + class(t2), optional :: z(:), z4(:)[*] + class(t2), optional, pointer :: z2(:) + class(t2), optional, allocatable :: z3(:), z5(:)[:] + class(t2), allocatable :: x(:) + class(t2), pointer :: y(:) + y => null() + call a2(x) + call a2(y) + call a2(z) + call a2(z2) + call a2(z3) + call a2(z4) + call a2(z5) + call a2p(y,psnt=.true.) + call a2p(z2,psnt=.false.) + call a2caf(z4) + call a2caf(z5) + call ar(x) + call ar(y) + call ar(z) + call ar(z2) + call ar(z3) + call ar(z4) + call ar(z5) + call arp(y,psnt=.true.) + call arp(z2,psnt=.false.) +! call s2elem(x) ! FIXME: Segfault +! call s2elem(y) ! FIXME: Segfault +! call s2elem(z) ! FIXME: Segfault +! call s2elem(z2) ! FIXME: Segfault +! call s2elem(z3) ! FIXME: Segfault +! call s2elem(z4) ! FIXME: Segfault +! call s2elem(z5) ! FIXME: Segfault +! call s2elem_t2(x) ! FIXME: Segfault +! call s2elem_t2(y) ! FIXME: Segfault +! call s2elem_t2(z) ! FIXME: Segfault +! call s2elem_t2(z2) ! FIXME: Segfault +! call s2elem_t2(z3) ! FIXME: Segfault +! call s2elem_t2(z4) ! FIXME: Segfault +! call s2elem_t2(z5) ! FIXME: Segfault + end subroutine a1ac + + subroutine a2(x) + class(t), intent(in), optional :: x(:) + if (present (x)) STOP 11 + ! print *, present(x) + end subroutine a2 + subroutine a2p(x, psnt) + class(t), pointer, intent(in), optional :: x(:) + logical psnt + if (present (x).neqv. psnt) STOP 12 + ! print *, present(x) + end subroutine a2p + subroutine a2caf(x) + class(t), intent(in), optional :: x(:)[*] + if (present (x)) STOP 13 + ! print *, present(x) + end subroutine a2caf + + + subroutine a3a1(z, z2, z3, z4, z5) + type(t), optional :: z(4), z4(4)[*] + type(t), optional, pointer :: z2(:) + type(t), optional, allocatable :: z3(:), z5(:)[:] + type(t), allocatable :: x(:) + type(t), pointer :: y(:) + y => null() + call a4(x) + call a4(y) + call a4(z) + call a4(z2) + call a4(z3) + call a4(z4) + call a4(z5) + call a4p(y,psnt=.true.) + call a4p(z2,psnt=.false.) + call a4t(x) + call a4t(y) + call a4t(z) +! call a4t(z2) ! FIXME: Segfault +! call a4t(z3) ! FIXME: Segfault +! call a4t(z4) ! FIXME: Segfault +! call a4t(z5) ! FIXME: Segfault + call a4tp(y,psnt=.true.) + call a4tp(z2,psnt=.false.) + call a4caf(z4) + call a4caf(z5) + call ar(x) + call ar(y) + call ar(z) + call ar(z2) + call ar(z3) + call ar(z4) + call ar(z5) + call arp(y,psnt=.true.) + call arp(z2,psnt=.false.) +! call s2elem(x) ! FIXME: Segfault +! call s2elem(y) ! FIXME: Segfault +! call s2elem(z) ! FIXME: Segfault +! call s2elem(z2) ! FIXME: Segfault +! call s2elem(z3) ! FIXME: Segfault +! call s2elem(z4) ! FIXME: Segfault +! call s2elem(z5) ! FIXME: Segfault +! call s2elem_t(x) ! FIXME: Conditional jump or move depends on uninitialised value +! call s2elem_t(y) ! FIXME: Conditional jump or move depends on uninitialised value + call s2elem_t(z) +! call s2elem_t(z2) ! FIXME: Segfault +! call s2elem_t(z3) ! FIXME: Segfault +! call s2elem_t(z4) ! FIXME: Segfault +! call s2elem_t(z5) ! FIXME: Segfault + end subroutine a3a1 + subroutine a3a(z, z2, z3) + type(t2), optional :: z(4) + type(t2), optional, pointer :: z2(:) + type(t2), optional, allocatable :: z3(:) + type(t2), allocatable :: x(:) + type(t2), pointer :: y(:) + y => null() + call a4(x) + call a4(y) + call a4(z) + call a4(z2) + call a4(z3) + call a4p(y,psnt=.true.) + call a4p(z2,psnt=.false.) + call a4t2(x) + call a4t2(y) + call a4t2(z) +! call a4t2(z2) ! FIXME: Segfault +! call a4t2(z3) ! FIXME: Segfault + call a4t2p(y,psnt=.true.) + call a4t2p(z2,psnt=.false.) + call ar(x) + call ar(y) + call ar(z) + call ar(z2) + call ar(z3) + call arp(y,psnt=.true.) + call arp(z2,psnt=.false.) +! call s2elem(x) ! FIXME: Segfault +! call s2elem(y) ! FIXME: Segfault +! call s2elem(z) ! FIXME: Segfault +! call s2elem(z2) ! FIXME: Segfault +! call s2elem(z3) ! FIXME: Segfault +! call s2elem(z4) ! FIXME: Segfault +! call s2elem(z5) ! FIXME: Segfault +! call s2elem_t2(x) ! FIXME: Conditional jump or move depends on uninitialised value +! call s2elem_t2(y) ! FIXME: Conditional jump or move depends on uninitialised value + call s2elem_t2(z) +! call s2elem_t2(z2) ! FIXME: Segfault +! call s2elem_t2(z3) ! FIXME: Segfault +! call s2elem_t2(z4) ! FIXME: Segfault +! call s2elem_t2(z5) ! FIXME: Segfault + end subroutine a3a + subroutine a3ac1(z, z2, z3, z4, z5) + class(t), optional :: z(4), z4(4)[*] + class(t), optional, pointer :: z2(:) + class(t), optional, allocatable :: z3(:), z5(:)[:] + class(t), allocatable :: x(:) + class(t), pointer :: y(:) + y => null() + call a4(x) + call a4(y) + call a4(z) + call a4(z2) + call a4(z3) + call a4(z4) + call a4(z5) + call a4p(y,psnt=.true.) + call a4p(z2,psnt=.false.) +! call a4t(x) ! FIXME: Segfault +! call a4t(y) ! FIXME: Segfault +! call a4t(z) ! FIXME: Segfault +! call a4t(z2) ! FIXME: Segfault +! call a4t(z3) ! FIXME: Segfault +! call a4t(z4) ! FIXME: Segfault +! call a4t(z5) ! FIXME: Segfault +! call a4tp(y,psnt=.true.) ! FIXME: Segfault +! call a4tp(z2,psnt=.false.) ! FIXME: Segfault + call a4caf(z4) + call a4caf(z5) + call ar(x) + call ar(y) + call ar(z) + call ar(z2) + call ar(z3) + call ar(z4) + call ar(z5) + call arp(y,psnt=.true.) + call arp(z2,psnt=.false.) +! call s2elem(x) ! FIXME: Conditional jump or move depends on uninitialised value +! call s2elem(y) ! FIXME: Conditional jump or move depends on uninitialised value +! call s2elem(z) ! FIXME: Segfault +! call s2elem(z2) ! FIXME: Segfault +! call s2elem(z3) ! FIXME: Segfault +! call s2elem(z4) ! FIXME: Segfault +! call s2elem(z5) ! FIXME: Segfault +! call s2elem_t(x) ! FIXME: Conditional jump or move depends on uninitialised value +! call s2elem_t(y) ! FIXME: Conditional jump or move depends on uninitialised value +! call s2elem_t(z) ! FIXME: Segfault +! call s2elem_t(z2) ! FIXME: Segfault +! call s2elem_t(z3) ! FIXME: Segfault +! call s2elem_t(z4) ! FIXME: Segfault +! call s2elem_t(z5) ! FIXME: Segfault + end subroutine a3ac1 + subroutine a3ac(z, z2, z3, z4, z5) + class(t2), optional :: z(4), z4(4)[*] + class(t2), optional, pointer :: z2(:) + class(t2), optional, allocatable :: z3(:), z5(:)[:] + class(t2), allocatable :: x(:) + class(t2), pointer :: y(:) + y => null() + call a4(x) + call a4(y) + call a4(z) + call a4(z2) + call a4(z3) + call a4(z4) + call a4(z5) + call a4p(y,psnt=.true.) + call a4p(z2,psnt=.false.) +! call a4t2(x) ! FIXME: Segfault +! call a4t2(y) ! FIXME: Segfault +! call a4t2(z) ! FIXME: Segfault +! call a4t2(z2) ! FIXME: Segfault +! call a4t2(z3) ! FIXME: Segfault +! call a4t2(z4) ! FIXME: Segfault +! call a4t2(z5) ! FIXME: Segfault +! call a4t2p(y,psnt=.true.) ! FIXME: Segfault +! call a4t2p(z2,psnt=.false.) ! FIXME: Segfault + call a4caf(z4) + call a4caf(z5) + call ar(x) + call ar(y) + call ar(z) + call ar(z2) + call ar(z3) + call ar(z4) + call ar(z5) + call arp(y,psnt=.true.) + call arp(z2,psnt=.false.) + end subroutine a3ac + + subroutine a4(x) + class(t), intent(in), optional :: x(4) + if (present (x)) STOP 14 + !print *, present(x) + end subroutine a4 + subroutine a4p(x, psnt) + class(t), pointer, intent(in), optional :: x(:) + logical psnt + if (present (x).neqv. psnt) STOP 15 + !print *, present(x) + end subroutine a4p + subroutine a4caf(x) + class(t), intent(in), optional :: x(4)[*] + if (present (x)) STOP 16 + !print *, present(x) + end subroutine a4caf + subroutine a4t(x) + type(t), intent(in), optional :: x(4) + if (present (x)) STOP 17 + !print *, present(x) + end subroutine a4t + subroutine a4t2(x) + type(t2), intent(in), optional :: x(4) + if (present (x)) STOP 18 + !print *, present(x) + end subroutine a4t2 + subroutine a4tp(x, psnt) + type(t), pointer, intent(in), optional :: x(:) + logical psnt + if (present (x).neqv. psnt) STOP 19 + !print *, present(x) + end subroutine a4tp + subroutine a4t2p(x, psnt) + type(t2), pointer, intent(in), optional :: x(:) + logical psnt + if (present (x).neqv. psnt) STOP 20 + !print *, present(x) + end subroutine a4t2p + + + subroutine ar(x) + class(t), intent(in), optional :: x(..) + if (present (x)) STOP 21 + !print *, present(x) + end subroutine ar + + subroutine art(x) + type(t), intent(in), optional :: x(..) + if (present (x)) STOP 22 + !print *, present(x) + end subroutine art + + subroutine arp(x, psnt) + class(t), pointer, intent(in), optional :: x(..) + logical psnt + if (present (x).neqv. psnt) STOP 23 + !print *, present(x) + end subroutine arp + + subroutine artp(x, psnt) + type(t), intent(in), pointer, optional :: x(..) + logical psnt + if (present (x).neqv. psnt) STOP 24 + !print *, present(x) + end subroutine artp + + + + subroutine ar1a1(z, z2, z3) + type(t), optional :: z(..) + type(t), pointer, optional :: z2(..) + type(t), allocatable, optional :: z3(..) + call ar(z) + call ar(z2) + call ar(z3) + call art(z) + call art(z2) + call art(z3) + call arp(z2, .false.) + call artp(z2, .false.) + end subroutine ar1a1 + subroutine ar1a(z, z2, z3) + type(t2), optional :: z(..) + type(t2), optional, pointer :: z2(..) + type(t2), optional, allocatable :: z3(..) + call ar(z) + call ar(z2) + call ar(z3) + call arp(z2, .false.) + end subroutine ar1a + subroutine ar1ac1(z, z2, z3) + class(t), optional :: z(..) + class(t), optional, pointer :: z2(..) + class(t), optional, allocatable :: z3(..) + call ar(z) + call ar(z2) + call ar(z3) +! call art(z) ! FIXME: ICE - This requires packing support for assumed-rank +! call art(z2)! FIXME: ICE - This requires packing support for assumed-rank +! call art(z3)! FIXME: ICE - This requires packing support for assumed-rank + call arp(z2, .false.) +! call artp(z2, .false.) ! FIXME: ICE + end subroutine ar1ac1 + subroutine ar1ac(z, z2, z3) + class(t2), optional :: z(..) + class(t2), optional, pointer :: z2(..) + class(t2), optional, allocatable :: z3(..) + call ar(z) + call ar(z2) + call ar(z3) + call arp(z2, .false.) + end subroutine ar1ac +end diff --git a/Fortran/gfortran/regression/class_result_1.f03 b/Fortran/gfortran/regression/class_result_1.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_result_1.f03 @@ -0,0 +1,60 @@ +! { dg-do run } +! { dg-options "-fcheck=all" } +! +! PR 50225: [OOP] The allocation status for polymorphic allocatable function results is not set properly +! +! Contributed by Arjen Markus + +module points2d + + implicit none + + type point2d + real :: x, y + end type + +contains + + subroutine print( point ) + class(point2d) :: point + write(*,'(2f10.4)') point%x, point%y + end subroutine + + subroutine random_vector( point ) + class(point2d) :: point + call random_number( point%x ) + call random_number( point%y ) + point%x = 2.0 * (point%x - 0.5) + point%y = 2.0 * (point%y - 0.5) + end subroutine + + function add_vector( point, vector ) + class(point2d), intent(in) :: point, vector + class(point2d), allocatable :: add_vector + allocate( add_vector ) + add_vector%x = point%x + vector%x + add_vector%y = point%y + vector%y + end function + +end module points2d + + +program random_walk + + use points2d + implicit none + + type(point2d), target :: point_2d, vector_2d + class(point2d), pointer :: point, vector + integer :: i + + point => point_2d + vector => vector_2d + + do i=1,2 + call random_vector(point) + call random_vector(vector) + call print(add_vector(point, vector)) + end do + +end program random_walk diff --git a/Fortran/gfortran/regression/class_result_10.f90 b/Fortran/gfortran/regression/class_result_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_result_10.f90 @@ -0,0 +1,52 @@ +! { dg-do run} + + +! PR fortran/99585 + +module m2 + type t + class(*), pointer :: bar(:) + end type + type t2 + class(t), allocatable :: my(:) + end type t2 +contains + function f (x, y) result(z) + class(t) :: x(:) + class(t) :: y(size(x(1)%bar)) + type(t) :: z(size(x(1)%bar)) + end + function g (x) result(z) + class(t) :: x(:) + type(t) :: z(size(x(1)%bar)) + end + subroutine s () + class(t2), allocatable :: a(:), b(:), c(:), d(:) + class(t2), pointer :: p(:) + c(1)%my = f (a(1)%my, b(1)%my) + d(1)%my = g (p(1)%my) + end +end + +! Contributed by G. Steinmetz: +! PR fortran/104430 + +module m + type t + integer :: a + end type +contains + function f(x) result(z) + class(t) :: x(:) + type(t) :: z(size(x%a)) + z%a = 42 + end +end +program p + use m + class(t), allocatable :: y(:), z(:) + allocate (y(32)) + z = f(y) + if (size(z) /= 32) stop 1 + if (any (z%a /= 42)) stop 2 +end diff --git a/Fortran/gfortran/regression/class_result_2.f90 b/Fortran/gfortran/regression/class_result_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_result_2.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! +! PR 59414: [OOP] Class array pointers: compile error on valid code (Different ranks in pointer assignment) +! +! Contributed by Antony Lewis + + implicit none + + Type TObjectList + end Type + + Class(TObjectList), pointer :: Arr(:) + Arr => ArrayItem() + + contains + + function ArrayItem() result(P) + Class(TObjectList), pointer :: P(:) + end function + +end diff --git a/Fortran/gfortran/regression/class_result_3.f90 b/Fortran/gfortran/regression/class_result_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_result_3.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +! PR 78300: [OOP] Failure to compile a F03 code with an optional dummy procedure argument +! +! Contributed by DIL + + implicit none + + type gfc_cont_elem_t + end type + + contains + + function gfc_copy_i() result(clone) + class(gfc_cont_elem_t), pointer:: clone + end + + subroutine ContElemConstruct(copy_constr_func) + procedure(gfc_copy_i) :: copy_constr_func + end + +end diff --git a/Fortran/gfortran/regression/class_result_4.f90 b/Fortran/gfortran/regression/class_result_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_result_4.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR fortran/78500 +class(t) function f() ! { dg-error "is not accessible" } + f = 1 ! { dg-error "variable must not be polymorphic" } +end + diff --git a/Fortran/gfortran/regression/class_result_5.f90 b/Fortran/gfortran/regression/class_result_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_result_5.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! +! Test the fix for PR79072. The original problem was that an ICE +! would occur in the select type construct. On fixing that, it was +! found that the string length was not being transferred in the +! pointer assignment in the main program. +! +! Contributed by Neil Carlson +! +function foo(string) + class(*), pointer :: foo + character(3), target :: string + foo => string + select type (foo) + type is (character(*)) + if (foo .ne. 'foo') STOP 1 + foo = 'bar' + end select +end function + + interface + function foo(string) + class(*), pointer :: foo + character(3), target :: string + end function + end interface + + class(*), pointer :: res + character(3), target :: string = 'foo' + + res => foo (string) + + select type (res) + type is (character(*)) + if (res .ne. 'bar') STOP 2 + end select + if (string .ne. 'bar') STOP 3 +end diff --git a/Fortran/gfortran/regression/class_result_6.f90 b/Fortran/gfortran/regression/class_result_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_result_6.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! +! Test the fix for PR79072 comment #12. A description of the problem +! is to be found in class_result_5.f90. +! +! Contributed by Neil Carlson +! + character(3), target :: a = 'foo' + class(*), pointer :: b + b => ptr() + select type (b) + type is (character(*)) + if (a .ne. "bar") STOP 1 + end select +contains + function ptr() + class(*), pointer :: ptr + ptr => a + select type (ptr) + type is (character(*)) + ptr = "bar" + end select + end function +end diff --git a/Fortran/gfortran/regression/class_result_7.f90 b/Fortran/gfortran/regression/class_result_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_result_7.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Test the fix for PR80477 +! +! Contributed by Stefano Zaghi +! +module a_type_m + implicit none + type :: a_type_t + real :: x + endtype +contains + subroutine assign_a_type(lhs, rhs) + type(a_type_t), intent(inout) :: lhs + type(a_type_t), intent(in) :: rhs + lhs%x = rhs%x + end subroutine + + function add_a_type(lhs, rhs) result( res ) + type(a_type_t), intent(in) :: lhs + type(a_type_t), intent(in) :: rhs + class(a_type_t), allocatable :: res + allocate (a_type_t :: res) + res%x = lhs%x + rhs%x + end function +end module + +program polymorphic_operators_memory_leaks + use a_type_m + implicit none + type(a_type_t) :: a = a_type_t(1) , b = a_type_t(2) + call assign_a_type (a, add_a_type(a,b)) ! generated a memory leak +end +! { dg-final { scan-tree-dump-times "builtin_free" 1 "original" } } +! { dg-final { scan-tree-dump-times "builtin_malloc" 1 "original" } } diff --git a/Fortran/gfortran/regression/class_result_8.f90 b/Fortran/gfortran/regression/class_result_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_result_8.f90 @@ -0,0 +1,41 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Test the fix for the array version of PR80477 +! +! Contributed by Stefano Zaghi +! +module a_type_m + implicit none + type :: a_type_t + real :: x + real, allocatable :: y(:) + endtype +contains + subroutine assign_a_type(lhs, rhs) + type(a_type_t), intent(inout) :: lhs + type(a_type_t), intent(in) :: rhs(:) + lhs%x = rhs(1)%x + rhs(2)%x + end subroutine + + function add_a_type(lhs, rhs) result( res ) + type(a_type_t), intent(in) :: lhs + type(a_type_t), intent(in) :: rhs + class(a_type_t), allocatable :: res(:) + allocate (a_type_t :: res(2)) + allocate (res(1)%y(1)) + allocate (res(2)%y(1)) + res(1)%x = lhs%x + res(2)%x = rhs%x + end function +end module + +program polymorphic_operators_memory_leaks + use a_type_m + implicit none + type(a_type_t) :: a = a_type_t(1) , b = a_type_t(2) + call assign_a_type (a, add_a_type(a,b)) + print *, a%x +end +! { dg-final { scan-tree-dump-times "builtin_free" 6 "original" } } +! { dg-final { scan-tree-dump-times "builtin_malloc" 7 "original" } } diff --git a/Fortran/gfortran/regression/class_result_9.f90 b/Fortran/gfortran/regression/class_result_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_result_9.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! +! Test the fix for an additional bug found while fixing PR80477 +! +! Contributed by Paul Thomas +! +module a_type_m + implicit none + type :: a_type_t + real :: x + real, allocatable :: y(:) + endtype +contains + subroutine assign_a_type(lhs, rhs) + type(a_type_t), intent(inout) :: lhs + type(a_type_t), intent(in) :: rhs(:) + lhs%x = rhs(1)%x + rhs(2)%x + lhs%y = rhs(1)%y + rhs(2)%y + end subroutine + + function add_a_type(lhs, rhs) result( res ) + type(a_type_t), intent(in) :: lhs + type(a_type_t), intent(in) :: rhs + class(a_type_t), allocatable :: res(:) + allocate (a_type_t :: res(2)) + allocate (res(1)%y(1), source = [10.0]) + allocate (res(2)%y(1), source = [20.0]) + res(1)%x = lhs%x + rhs%x + res(2)%x = rhs%x + rhs%x + end function +end module + +program polymorphic_operators_memory_leaks + use a_type_m + implicit none + type(a_type_t) :: a = a_type_t(1) , b = a_type_t(2) + class(a_type_t), allocatable :: res(:) + + res = add_a_type(a,b) ! Remarkably, this ICEd - found while debugging the PR. + call assign_a_type (a, res) + if (int (res(1)%x + res(2)%x) .ne. int (a%x)) stop 1 + if (int (sum (res(1)%y + res(2)%y)) .ne. int (sum (a%y))) stop 1 + deallocate (a%y) + deallocate (res) +end diff --git a/Fortran/gfortran/regression/class_to_type_1.f03 b/Fortran/gfortran/regression/class_to_type_1.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_to_type_1.f03 @@ -0,0 +1,97 @@ +! { dg-do run } +! +! Passing CLASS to TYPE +! +implicit none +type t + integer :: A + real, allocatable :: B(:) +end type t + +type, extends(t) :: t2 + complex :: z = cmplx(3.3, 4.4) +end type t2 +integer :: i +class(t), allocatable :: x(:) + +allocate(t2 :: x(10)) +select type(x) + type is(t2) + if (size (x) /= 10) STOP 1 + x = [(t2(a=-i, B=[1*i,2*i,3*i,4*i]), i = 1, 10)] + do i = 1, 10 + if (x(i)%a /= -i .or. size (x(i)%b) /= 4 & + .or. any (x(i)%b /= [1*i,2*i,3*i,4*i])) then + STOP 2 + end if + if (x(i)%z /= cmplx(3.3, 4.4)) STOP 3 + end do + class default + STOP 4 +end select + +call base(x) +call baseExplicit(x, size(x)) +call class(x) +call classExplicit(x, size(x)) +contains + subroutine base(y) + type(t) :: y(:) + if (size (y) /= 10) STOP 5 + do i = 1, 10 + if (y(i)%a /= -i .or. size (y(i)%b) /= 4 & + .or. any (y(i)%b /= [1*i,2*i,3*i,4*i])) then + STOP 6 + end if + end do + end subroutine base + subroutine baseExplicit(v, n) + integer, intent(in) :: n + type(t) :: v(n) + if (size (v) /= 10) STOP 7 + do i = 1, 10 + if (v(i)%a /= -i .or. size (v(i)%b) /= 4 & + .or. any (v(i)%b /= [1*i,2*i,3*i,4*i])) then + STOP 8 + end if + end do + end subroutine baseExplicit + subroutine class(z) + class(t), intent(in) :: z(:) + select type(z) + type is(t2) + if (size (z) /= 10) STOP 9 + do i = 1, 10 + if (z(i)%a /= -i .or. size (z(i)%b) /= 4 & + .or. any (z(i)%b /= [1*i,2*i,3*i,4*i])) then + STOP 10 + end if + if (z(i)%z /= cmplx(3.3, 4.4)) STOP 11 + end do + class default + STOP 12 + end select + call base(z) + call baseExplicit(z, size(z)) + end subroutine class + subroutine classExplicit(u, n) + integer, intent(in) :: n + class(t), intent(in) :: u(n) + select type(u) + type is(t2) + if (size (u) /= 10) STOP 13 + do i = 1, 10 + if (u(i)%a /= -i .or. size (u(i)%b) /= 4 & + .or. any (u(i)%b /= [1*i,2*i,3*i,4*i])) then + STOP 14 + end if + if (u(i)%z /= cmplx(3.3, 4.4)) STOP 15 + end do + class default + STOP 16 + end select + call base(u) + call baseExplicit(u, n) + end subroutine classExplicit +end + diff --git a/Fortran/gfortran/regression/class_to_type_2.f90 b/Fortran/gfortran/regression/class_to_type_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_to_type_2.f90 @@ -0,0 +1,95 @@ +! { dg-do run } +! +! PR fortran/51514 +! +! Check that passing a CLASS to a TYPE works +! +! Based on a test case of Reinhold Bader. +! + +module mod_subpr + implicit none + + type :: foo + integer :: i = 2 + end type + + type, extends(foo) :: foo_1 + real :: r(2) + end type + +contains + + subroutine subpr (x) + type(foo) :: x + x%i = 3 + end subroutine + + elemental subroutine subpr_elem (x) + type(foo), intent(inout):: x + x%i = 3 + end subroutine + + subroutine subpr_array (x) + type(foo), intent(inout):: x(:) + x(:)%i = 3 + end subroutine + + subroutine subpr2 (x) + type(foo) :: x + if (x%i /= 55) STOP 1 + end subroutine + + subroutine subpr2_array (x) + type(foo) :: x(:) + if (any(x(:)%i /= 55)) STOP 2 + end subroutine + + function f () + class(foo), allocatable :: f + allocate (f) + f%i = 55 + end function f + + function g () result(res) + class(foo), allocatable :: res(:) + allocate (res(3)) + res(:)%i = 55 + end function g +end module + +program prog + use mod_subpr + implicit none + class(foo), allocatable :: xx, yy(:) + + allocate (foo_1 :: xx) + xx%i = 33 + call subpr (xx) + if (xx%i /= 3) STOP 3 + + xx%i = 33 + call subpr_elem (xx) + if (xx%i /= 3) STOP 4 + + call subpr (f ()) + + allocate (foo_1 :: yy(2)) + yy(:)%i = 33 + call subpr_elem (yy) + if (any (yy%i /= 3)) STOP 5 + + yy(:)%i = 33 + call subpr_elem (yy(1)) + if (yy(1)%i /= 3) STOP 6 + + yy(:)%i = 33 + call subpr_array (yy) + if (any (yy%i /= 3)) STOP 7 + + yy(:)%i = 33 + call subpr_array (yy(1:2)) + if (any (yy(1:2)%i /= 3)) STOP 8 + + call subpr2_array (g ()) +end program diff --git a/Fortran/gfortran/regression/class_to_type_3.f03 b/Fortran/gfortran/regression/class_to_type_3.f03 --- /dev/null +++ b/Fortran/gfortran/regression/class_to_type_3.f03 @@ -0,0 +1,41 @@ +! { dg-do run } +! Tests the fix for pr63553 in which the class container was being +! assigned to derived types, rather than the data. +! +! Contributed by +! +program toto + implicit none + type mother + integer :: i + end type mother + type,extends(mother) :: child + end type child + + call comment1 + call comment2 + +contains + subroutine comment1 + type(mother) :: tm + class(mother),allocatable :: cm + + allocate (cm) + cm%i = 77 + tm = cm + if (tm%i .ne. cm%i) STOP 1 + end subroutine + + subroutine comment2 + class(mother),allocatable :: cm,cm2 + + allocate(cm) + allocate(child::cm2) + cm%i=10 + select type (cm2) + type is (child) + cm2%mother=cm + end select + if (cm2%i .ne. cm%i) STOP 2 + end subroutine +end program diff --git a/Fortran/gfortran/regression/class_to_type_4.f90 b/Fortran/gfortran/regression/class_to_type_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/class_to_type_4.f90 @@ -0,0 +1,119 @@ +! { dg-do run } +! +! PR fortran/63205 +! +! Check that passing a CLASS function result to a derived TYPE works +! +! Reported by Tobias Burnus +! + +program test + implicit none + type t + integer :: ii + end type t + type, extends(t) :: u + real :: rr + end type u + type, extends(t) :: v + real, allocatable :: rr(:) + end type v + type, extends(v) :: w + real, allocatable :: rrr(:) + end type w + + type(t) :: x, y(3) + type(v) :: a, b(3) + + x = func1() ! scalar to scalar - no alloc comps + if (x%ii .ne. 77) STOP 1 + + y = func2() ! array to array - no alloc comps + if (any (y%ii .ne. [1,2,3])) STOP 2 + + y = func1() ! scalar to array - no alloc comps + if (any (y%ii .ne. 77)) STOP 3 + + x = func3() ! scalar daughter type to scalar - no alloc comps + if (x%ii .ne. 99) STOP 4 + + y = func4() ! array daughter type to array - no alloc comps + if (any (y%ii .ne. [3,4,5])) STOP 5 + + y = func3() ! scalar daughter type to array - no alloc comps + if (any (y%ii .ne. [99,99,99])) STOP 6 + + a = func5() ! scalar to scalar - alloc comps in parent type + if (any (a%rr .ne. [10.0,20.0])) STOP 7 + + b = func6() ! array to array - alloc comps in parent type + if (any (b(3)%rr .ne. [3.0,4.0])) STOP 8 + + a = func7() ! scalar daughter type to scalar - alloc comps in parent type + if (any (a%rr .ne. [10.0,20.0])) STOP 9 + + b = func8() ! array daughter type to array - alloc comps in parent type + if (any (b(3)%rr .ne. [3.0,4.0])) STOP 10 + + b = func7() ! scalar daughter type to array - alloc comps in parent type + if (any (b(2)%rr .ne. [10.0,20.0])) STOP 11 + +! This is an extension of class_to_type_2.f90's test using a daughter type +! instead of the declared type. + if (subpr2_array (g ()) .ne. 99 ) STOP 12 +contains + + function func1() result(res) + class(t), allocatable :: res + allocate (res, source = t(77)) + end function func1 + + function func2() result(res) + class(t), allocatable :: res(:) + allocate (res(3), source = [u(1,1.0),u(2,2.0),u(3,3.0)]) + end function func2 + + function func3() result(res) + class(t), allocatable :: res + allocate (res, source = v(99,[99.0,99.0,99.0])) + end function func3 + + function func4() result(res) + class(t), allocatable :: res(:) + allocate (res(3), source = [v(3,[1.0,2.0]),v(4,[2.0,3.0]),v(5,[3.0,4.0])]) + end function func4 + + function func5() result(res) + class(v), allocatable :: res + allocate (res, source = v(3,[10.0,20.0])) + end function func5 + + function func6() result(res) + class(v), allocatable :: res(:) + allocate (res(3), source = [v(3,[1.0,2.0]),v(4,[2.0,3.0]),v(5,[3.0,4.0])]) + end function func6 + + function func7() result(res) + class(v), allocatable :: res + allocate (res, source = w(3,[10.0,20.0],[100,200])) + end function func7 + + function func8() result(res) + class(v), allocatable :: res(:) + allocate (res(3), source = [w(3,[1.0,2.0],[0.0]),w(4,[2.0,3.0],[0.0]),w(5,[3.0,4.0],[0.0])]) + end function func8 + + + integer function subpr2_array (x) + type(t) :: x(:) + if (any(x(:)%ii /= 55)) STOP 13 + subpr2_array = 99 + end function + + function g () result(res) + integer i + class(t), allocatable :: res(:) + allocate (res(3), source = [(v (1, [1.0,2.0]), i = 1, 3)]) + res(:)%ii = 55 + end function g +end program test diff --git a/Fortran/gfortran/regression/cmplx_intrinsic_1.f90 b/Fortran/gfortran/regression/cmplx_intrinsic_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/cmplx_intrinsic_1.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } + +CONTAINS +SUBROUTINE send_forward () + + INTEGER, DIMENSION(3) :: lz, ub, uz + REAL, ALLOCATABLE, DIMENSION(:, :, :) :: buffer + COMPLEX, DIMENSION ( :, :, : ), POINTER :: cc3d + + cc3d ( lz(1):uz(1), lz(2):uz(2), lz(3):uz(3) ) = & + CMPLX ( buffer ( lz(1):uz(1), lz(2):uz(2), lz(3):uz(3) ), & + KIND = SELECTED_REAL_KIND ( 14, 200 ) ) + +END SUBROUTINE send_forward +END + diff --git a/Fortran/gfortran/regression/co_reduce_1.f90 b/Fortran/gfortran/regression/co_reduce_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/co_reduce_1.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original -fcoarray=lib" } +! +! Check that we don't take twice the address of procedure simple_reduction +! in the generated code. +! +! Contributed by Alessandro Fanfarillo + +program simple_reduce + implicit none + + integer :: me + + me = this_image() + + sync all + + call co_reduce(me,simple_reduction) + + write(*,*) this_image(),me + +contains + + pure function simple_reduction(a,b) + integer,intent(in) :: a,b + integer :: simple_reduction + + simple_reduction = a * b + end function simple_reduction + +end program simple_reduce + +! { dg-final { scan-tree-dump "_gfortran_caf_co_reduce \\(&desc\\.\\d+,\\s*simple_reduction," "original" } } diff --git a/Fortran/gfortran/regression/co_reduce_2.f90 b/Fortran/gfortran/regression/co_reduce_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/co_reduce_2.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! PR 103054 - wrong keyword name. +! Original test case by Damian Rouson. +program main + implicit none + logical :: co_all= .true. + call co_reduce(co_all, operator=both) ! { dg-error "Cannot find keyword" } + call co_reduce(co_all, operation=both) +contains + logical pure function both(lhs,rhs) + logical, intent(in) :: lhs, rhs + both = lhs .and. rhs + end function +end diff --git a/Fortran/gfortran/regression/coarray_1.f90 b/Fortran/gfortran/regression/coarray_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_1.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! Coarray support +! PR fortran/18918 +! +implicit none +integer :: n +critical ! { dg-error "Fortran 2008:" } + sync all() ! { dg-error "Fortran 2008:" } +end critical ! { dg-error "Expecting END PROGRAM" } +sync memory ! { dg-error "Fortran 2008:" } +sync images(*) ! { dg-error "Fortran 2008:" } + +! num_images is implicitly defined: +n = num_images() ! { dg-error "has no IMPLICIT type" } +error stop 'stop' ! { dg-error "Fortran 2008:" } +end diff --git a/Fortran/gfortran/regression/coarray_10.f90 b/Fortran/gfortran/regression/coarray_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_10.f90 @@ -0,0 +1,52 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/18918 +! +! Coarray intrinsics +! + +subroutine image_idx_test1() + INTEGER,save :: array[2,-1:4,8,*] + WRITE (*,*) IMAGE_INDEX (array, [2,0,3,1]) + WRITE (*,*) IMAGE_INDEX (array, [0,0,3,1]) ! { dg-error "for dimension 1, SUB has 0 and COARRAY lower bound is 1" } + WRITE (*,*) IMAGE_INDEX (array, [1,2,9,0]) ! { dg-error "for dimension 3, SUB has 9 and COARRAY upper bound is 8" } + WRITE (*,*) IMAGE_INDEX (array, [2,0,3]) ! { dg-error "array elements of the SUB argument to IMAGE_INDEX at .1. shall be 4" } + WRITE (*,*) IMAGE_INDEX (array, [2,0,3,1,1])! { dg-error "array elements of the SUB argument to IMAGE_INDEX at .1. shall be 4" } +end subroutine + +subroutine this_image_check() + integer,save :: a(1,2,3,5)[0:3,*] + integer :: j + integer,save :: z(4)[*], i + + j = this_image(a,dim=3) ! { dg-error "not a valid codimension index" } + j = this_image(dim=3) ! { dg-error "DIM argument without COARRAY argument" } + i = image_index(i, [ 1 ]) ! { dg-error "Expected coarray variable" } + i = image_index(z, 2) ! { dg-error "must be a rank one array" } +end subroutine this_image_check + + +subroutine rank_mismatch() + implicit none + integer,allocatable :: A(:)[:,:,:,:] + allocate(A(1)[1,1,1:*]) ! { dg-error "Too few codimensions" } + allocate(A(1)[1,1,1,1,1,*]) ! { dg-error "Invalid codimension 5" } + allocate(A(1)[1,1,1,*]) + allocate(A(1)[1,1]) ! { dg-error "Too few codimensions" } + allocate(A(1)[1,*]) ! { dg-error "Too few codimensions" } + allocate(A(1)[1,1:*]) ! { dg-error "Too few codimensions" } + + A(1)[1,1,1] = 1 ! { dg-error "Too few codimensions" } + A(1)[1,1,1,1,1,1] = 1 ! { dg-error "Invalid codimension 5" } + A(1)[1,1,1,1] = 1 + A(1)[1,1] = 1 ! { dg-error "Too few codimensions" } + A(1)[1,1] = 1 ! { dg-error "Too few codimensions" } + A(1)[1,1:1] = 1 ! { dg-error "Too few codimensions" } +end subroutine rank_mismatch + +subroutine rank_mismatch2() + implicit none + integer, allocatable:: A(:)[:,:,:] + allocate(A(1)[7:8,4:*]) ! { dg-error "Too few codimensions" } +end subroutine rank_mismatch2 diff --git a/Fortran/gfortran/regression/coarray_11.f90 b/Fortran/gfortran/regression/coarray_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_11.f90 @@ -0,0 +1,63 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single -fdump-tree-original" } +! +! PR fortran/18918 +! PR fortran/43919 for boundsTest() +! +! Coarray intrinsics +! + +subroutine image_idx_test1() + INTEGER,save :: array[2,-1:4,8,*] + WRITE (*,*) IMAGE_INDEX (array, [2,0,3,1]) + if (IMAGE_INDEX (array, [1,-1,1,1]) /= 1) call not_existing() + if (IMAGE_INDEX (array, [2,-1,1,1]) /= 0) call not_existing() + if (IMAGE_INDEX (array, [1,-1,1,2]) /= 0) call not_existing() +end subroutine + +subroutine this_image_check() + integer,save :: a(1,2,3,5)[0:3,*] + integer :: j + if (this_image() /= 1) call not_existing() + if (this_image(a,dim=1) /= 0) call not_existing() + if (this_image(a,dim=2) /= 1) call not_existing() +end subroutine this_image_check + +subroutine othercheck() +real,save :: a(5)[2,*] +complex,save :: c[4:5,6,9:*] +integer,save :: i, j[*] +dimension :: b(3) +codimension :: b[5:*] +dimension :: h(9:10) +codimension :: h[8:*] +save :: b,h +if (this_image() /= 1) call not_existing() +if (num_images() /= 1) call not_existing() +if(any(this_image(coarray=a) /= [ 1, 1 ])) call not_existing() +if(any(this_image(c) /= [4,1,9])) call not_existing() +if(this_image(c, dim=3) /= 9) call not_existing() +if(ubound(b,dim=1) /= 3 .or. this_image(coarray=b,dim=1) /= 5) call not_existing() +if(ubound(h,dim=1) /= 10 .or. this_image(h,dim=1) /= 8) call not_existing() +end subroutine othercheck + +subroutine andanother() +integer,save :: a(1)[2:9,4,-3:5,0:*] +print *, lcobound(a) +print *, lcobound(a,dim=3,kind=8) +print *, ucobound(a) +print *, ucobound(a,dim=1,kind=2) +if (any(lcobound(a) /= [2, 1, -3, 0])) call not_existing() +if (any(ucobound(a) /= [9, 4, 5, 0])) call not_existing() +if (lcobound(a,dim=3,kind=8) /= -3_8) call not_existing() +if (ucobound(a,dim=1,kind=2) /= 9_2) call not_existing() +end subroutine andanother + +subroutine boundsTest() + implicit none + integer :: a[*] = 7 + if (any (lcobound(a) /= [1])) call not_existing() + if (any (ucobound(a) /= [1])) call not_existing() +end subroutine boundsTest + +! { dg-final { scan-tree-dump-times "not_existing" 0 "original" } } diff --git a/Fortran/gfortran/regression/coarray_12.f90 b/Fortran/gfortran/regression/coarray_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_12.f90 @@ -0,0 +1,76 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single -fdump-tree-original" } +! +! Coarray support -- allocatable array coarrays +! PR fortran/18918 +! +integer,allocatable :: a(:)[:,:] +nn = 5 +mm = 7 +allocate(a(nn)[mm,*]) +end + +subroutine testAlloc3 + implicit none + integer, allocatable :: ab(:,:,:)[:,:] + integer, allocatable, dimension(:),codimension[:] :: b(:,:,:)[:,:] + integer, allocatable, dimension(:,:),codimension[:,:,:] :: c + integer, allocatable, dimension(:,:),codimension[:,:,:] :: d[:,:] + integer, allocatable, dimension(:,:,:),codimension[:,:,:] :: e(:,:) + integer, allocatable, dimension(:,:,:),codimension[:,:,:] :: f(:,:)[:,:] + + allocate(ab(1,2,3)[4,*]) + allocate(b(1,2,3)[4,*]) + allocate(c(1,2)[3,4,*]) + allocate(d(1,2)[3,*]) + allocate(e(1,2)[3,4,*]) + allocate(f(1,2)[3,*]) +end subroutine testAlloc3 + +subroutine testAlloc4() + implicit none + integer, allocatable :: xxx(:)[:,:,:,:] + integer :: mmm + mmm=88 + allocate(xxx(1)[7,-5:8,mmm:2,*]) +end subroutine testAlloc4 + +subroutine testAlloc5() + implicit none + integer, allocatable :: yyy(:)[:,:,:,:] + integer :: ooo, ppp + ooo=88 + ppp=42 + allocate(yyy(1)[7,-5:ppp,1,ooo:*]) +end subroutine testAlloc5 + + +! { dg-final { scan-tree-dump-times "a.dim.0..lbound = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "a.dim.0..ubound = .*nn;" 1 "original" } } +! { dg-final { scan-tree-dump-times "a.dim.1..lbound = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "a.dim.1..ubound = .*mm;" 1 "original" } } +! { dg-final { scan-tree-dump-times "a.dim.2..lbound = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "a.dim.2..ubound" 0 "original" } } + +! { dg-final { scan-tree-dump-times "xxx.dim.0..lbound = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "xxx.dim.0..ubound = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "xxx.dim.1..lbound = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "xxx.dim.1..ubound = 7;" 1 "original" } } +! { dg-final { scan-tree-dump-times "xxx.dim.2..lbound = -5;" 1 "original" } } +! { dg-final { scan-tree-dump-times "xxx.dim.2..ubound = 8;" 1 "original" } } +! { dg-final { scan-tree-dump-times "xxx.dim.3..lbound = .*mmm;" 1 "original" } } +! { dg-final { scan-tree-dump-times "xxx.dim.3..ubound = 2;" 1 "original" } } +! { dg-final { scan-tree-dump-times "xxx.dim.4..lbound = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "xxx.dim.4..ubound" 0 "original" } } + +! { dg-final { scan-tree-dump-times "yyy.dim.0..lbound = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "yyy.dim.0..ubound = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "yyy.dim.1..lbound = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "yyy.dim.1..ubound = 7;" 1 "original" } } +! { dg-final { scan-tree-dump-times "yyy.dim.2..lbound = -5;" 1 "original" } } +! { dg-final { scan-tree-dump-times "yyy.dim.2..ubound = .*ppp;" 1 "original" } } +! { dg-final { scan-tree-dump-times "yyy.dim.3..lbound = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "yyy.dim.3..ubound = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "yyy.dim.4..lbound = .*ooo;" 1 "original" } } +! { dg-final { scan-tree-dump-times "yyy.dim.4..ubound" 0 "original" } } + diff --git a/Fortran/gfortran/regression/coarray_13.f90 b/Fortran/gfortran/regression/coarray_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_13.f90 @@ -0,0 +1,149 @@ +! { dg-do run } +! { dg-options "-fcoarray=single -fcheck=bounds" } +! +! Coarray support -- allocatable array coarrays +! -- intrinsic procedures +! PR fortran/18918 +! PR fortran/43931 +! +program test + implicit none + integer,allocatable :: B(:)[:] + + call one() + call two() + allocate(B(3)[-4:*]) + call three(3,B,1) + call three_a(3,B) + call three_b(3,B) + call four(B) + call five() +contains + subroutine one() + integer, allocatable :: a(:)[:,:,:] + allocate(a(1)[-4:9,8,4:*]) + + if (this_image(a,dim=1) /= -4_8) STOP 1 + if (lcobound (a,dim=1) /= -4_8) STOP 2 + if (ucobound (a,dim=1) /= 9_8) STOP 3 + + if (this_image(a,dim=2) /= 1_8) STOP 4 + if (lcobound (a,dim=2) /= 1_8) STOP 5 + if (ucobound (a,dim=2) /= 8_8) STOP 6 + + if (this_image(a,dim=3) /= 4_8) STOP 7 + if (lcobound (a,dim=3) /= 4_8) STOP 8 + if (ucobound (a,dim=3) /= 4_8) STOP 9 + + if (any(this_image(a) /= [-4_8, 1_8, 4_8])) STOP 10 + if (any(lcobound (a) /= [-4_8, 1_8, 4_8])) STOP 11 + if (any(ucobound (a) /= [9_8, 8_8, 4_8])) STOP 12 + end subroutine one + + subroutine two() + integer, allocatable :: a(:)[:,:,:] + allocate(a(1)[-4:9,8,4:*]) + + if (this_image(a,dim=1) /= -4) STOP 13 + if (lcobound (a,dim=1) /= -4) STOP 14 + if (ucobound (a,dim=1) /= 9) STOP 15 + + if (this_image(a,dim=2) /= 1) STOP 16 + if (lcobound (a,dim=2) /= 1) STOP 17 + if (ucobound (a,dim=2) /= 8) STOP 18 + + if (this_image(a,dim=3) /= 4) STOP 19 + if (lcobound (a,dim=3) /= 4) STOP 20 + if (ucobound (a,dim=3) /= 4) STOP 21 + + if (any(this_image(a) /= [-4, 1, 4])) STOP 22 + if (any(lcobound (a) /= [-4, 1, 4])) STOP 23 + if (any(ucobound (a) /= [9, 8, 4])) STOP 24 + end subroutine two + + subroutine three(n,A, n2) + integer :: n, n2 + integer :: A(3)[n:*] + + A(1) = 42 + if (A(1) /= 42) STOP 25 + A(1)[n2] = -42 + if (A(1)[n2] /= -42) STOP 26 + + if (this_image(A,dim=1) /= n) STOP 27 + if (lcobound (A,dim=1) /= n) STOP 28 + if (ucobound (A,dim=1) /= n) STOP 29 + + if (any(this_image(A) /= n)) STOP 30 + if (any(lcobound (A) /= n)) STOP 31 + if (any(ucobound (A) /= n)) STOP 32 + end subroutine three + + subroutine three_a(n,A) + integer :: n + integer :: A(3)[n+2:n+5,n-1:*] + + A(1) = 42 + if (A(1) /= 42) STOP 33 + A(1)[4,n] = -42 + if (A(1)[4,n] /= -42) STOP 34 + + if (this_image(A,dim=1) /= n+2) STOP 35 + if (lcobound (A,dim=1) /= n+2) STOP 36 + if (ucobound (A,dim=1) /= n+5) STOP 37 + + if (this_image(A,dim=2) /= n-1) STOP 38 + if (lcobound (A,dim=2) /= n-1) STOP 39 + if (ucobound (A,dim=2) /= n-1) STOP 40 + + if (any(this_image(A) /= [n+2,n-1])) STOP 41 + if (any(lcobound (A) /= [n+2,n-1])) STOP 42 + if (any(ucobound (A) /= [n+5,n-1])) STOP 43 + end subroutine three_a + + subroutine three_b(n,A) + integer :: n + integer :: A(-1:3,0:4,-2:5,-4:7)[n+2:n+5,n-1:*] + + A(-1,0,-2,-4) = 42 + if (A(-1,0,-2,-4) /= 42) STOP 44 + A(1,0,-2,-4) = 99 + if (A(1,0,-2,-4) /= 99) STOP 45 + + if (this_image(A,dim=1) /= n+2) STOP 46 + if (lcobound (A,dim=1) /= n+2) STOP 47 + if (ucobound (A,dim=1) /= n+5) STOP 48 + + if (this_image(A,dim=2) /= n-1) STOP 49 + if (lcobound (A,dim=2) /= n-1) STOP 50 + if (ucobound (A,dim=2) /= n-1) STOP 51 + + if (any(this_image(A) /= [n+2,n-1])) STOP 52 + if (any(lcobound (A) /= [n+2,n-1])) STOP 53 + if (any(ucobound (A) /= [n+5,n-1])) STOP 54 + end subroutine three_b + + subroutine four(A) + integer, allocatable :: A(:)[:] + if (this_image(A,dim=1) /= -4_8) STOP 55 + if (lcobound (A,dim=1) /= -4_8) STOP 56 + if (ucobound (A,dim=1) /= -4_8) STOP 57 + end subroutine four + + subroutine five() + integer, save :: foo(2)[5:7,4:*] + integer :: i + + i = 1 + foo(1)[5,4] = 42 + if (foo(1)[5,4] /= 42) STOP 58 + if (this_image(foo,dim=i) /= 5) STOP 59 + if (lcobound(foo,dim=i) /= 5) STOP 60 + if (ucobound(foo,dim=i) /= 7) STOP 61 + + i = 2 + if (this_image(foo,dim=i) /= 4) STOP 62 + if (lcobound(foo,dim=i) /= 4) STOP 63 + if (ucobound(foo,dim=i) /= 4) STOP 64 + end subroutine five +end program test diff --git a/Fortran/gfortran/regression/coarray_14.f90 b/Fortran/gfortran/regression/coarray_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_14.f90 @@ -0,0 +1,53 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/46370 +! +! Coarray checks +! + +! Check for C1229: "A data-ref shall not be a polymorphic subobject of a +! coindexed object." which applies to function and subroutine calls. +module m + implicit none + type t + contains + procedure, nopass :: sub=>sub + procedure, nopass :: func=>func + end type t + type t3 + type(t) :: nopoly + end type t3 + type t2 + class(t), allocatable :: poly + class(t3), allocatable :: poly2 + end type t2 +contains + subroutine sub() + end subroutine sub + function func() + integer :: func + end function func +end module m + +subroutine test(x) + use m + type(t2) :: x[*] + integer :: i + call x[1]%poly2%nopoly%sub() ! OK + i = x[1]%poly2%nopoly%func() ! OK + call x[1]%poly%sub() ! { dg-error "Polymorphic subobject of coindexed object" } + i = x[1]%poly%func() ! { dg-error "Polymorphic subobject of coindexed object" } +end subroutine test + + +! Check for C617: "... a data-ref shall not be a polymorphic subobject of a +! coindexed object or ..." +! Before, the second allocate statment was failing - though it is no subobject. +program myTest +type t +end type t +class(t), allocatable :: a[:] + allocate (t :: a) ! { dg-error "Coarray specification required in ALLOCATE statement" } +allocate (t :: a[*]) ! OK +end program myTest diff --git a/Fortran/gfortran/regression/coarray_15.f90 b/Fortran/gfortran/regression/coarray_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_15.f90 @@ -0,0 +1,112 @@ +! { dg-do run } +! { dg-options "-fcoarray=single -Wzerotrip" } +! +! PR fortran/18918 +! +! Contributed by John Reid. +! +program ex2 + implicit none + real, allocatable :: z(:)[:] + integer :: image + character(len=128) :: str + + allocate(z(3)[*]) + write(*,*) 'z allocated on image',this_image() + sync all + if (this_image()==1) then + z = 1.2 + do image = 2, num_images() ! { dg-warning "will be executed zero times" } + write(*,*) 'Assigning z(:) on image',image + z(:)[image] = z + end do + end if + sync all + + str = repeat('X', len(str)) + write(str,*) 'z=',z(:),' on image',this_image() + if (str /= " z= 1.20000005 1.20000005 1.20000005 on image 1") & + STOP 1 + + str = repeat('X', len(str)) + write(str,*) 'z=',z,' on image',this_image() + if (str /= " z= 1.20000005 1.20000005 1.20000005 on image 1") & + STOP 2 + + str = repeat('X', len(str)) + write(str,*) 'z=',z(1:3)[this_image()],' on image',this_image() + if (str /= " z= 1.20000005 1.20000005 1.20000005 on image 1") & + STOP 3 + + call ex2a() + call ex5() +end + +subroutine ex2a() + implicit none + real, allocatable :: z(:,:)[:,:] + integer :: image + character(len=128) :: str + + allocate(z(2,2)[1,*]) + write(*,*) 'z allocated on image',this_image() + sync all + if (this_image()==1) then + z = 1.2 + do image = 2, num_images() ! { dg-warning "will be executed zero times" } + write(*,*) 'Assigning z(:) on image',image + z(:,:)[1,image] = z + end do + end if + sync all + + str = repeat('X', len(str)) + write(str,*) 'z=',z(:,:),' on image',this_image() + if (str /= " z= 1.20000005 1.20000005 1.20000005 1.20000005 on image 1") & + STOP 4 + + str = repeat('X', len(str)) + write(str,*) 'z=',z,' on image',this_image() + if (str /= " z= 1.20000005 1.20000005 1.20000005 1.20000005 on image 1") & + STOP 5 +end subroutine ex2a + +subroutine ex5 + implicit none + integer :: me + real, save :: w(4)[*] + character(len=128) :: str + + me = this_image() + w = me + + str = repeat('X', len(str)) + write(str,*) 'In main on image',this_image(), 'w= ',w + if (str /= " In main on image 1 w= 1.00000000 1.00000000 1.00000000 1.00000000") & + STOP 6 + + str = repeat('X', len(str)) + write(str,*) 'In main on image',this_image(), 'w= ',w(1:4) + if (str /= " In main on image 1 w= 1.00000000 1.00000000 1.00000000 1.00000000") & + STOP 7 + + str = repeat('X', len(str)) + write(str,*) 'In main on image',this_image(), 'w= ',w(:)[1] + if (str /= " In main on image 1 w= 1.00000000 1.00000000 1.00000000 1.00000000") & + STOP 8 + + sync all + call ex5_sub(me,w) +end subroutine ex5 + +subroutine ex5_sub(n,w) + implicit none + integer :: n + real :: w(n) + character(len=75) :: str + + str = repeat('X', len(str)) + write(str,*) 'In sub on image',this_image(), 'w= ',w + if (str /= " In sub on image 1 w= 1.00000000") & + STOP 9 +end subroutine ex5_sub diff --git a/Fortran/gfortran/regression/coarray_16.f90 b/Fortran/gfortran/regression/coarray_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_16.f90 @@ -0,0 +1,100 @@ +! { dg-do run } +! { dg-options "-fcoarray=single" } +! +! Run-time test for IMAGE_INDEX with cobounds only known at +! the compile time, suitable for any number of NUM_IMAGES() +! For compile-time cobounds, the -fcoarray=lib version still +! needs to run-time evalulation if image_index returns > 1 +! as image_index is 0 if the index would exceed num_images(). +! +! Please set num_images() to >= 13, if possible. +! +! PR fortran/18918 +! + +program test_image_index +implicit none +integer :: index1, index2, index3 +logical :: one + +integer, allocatable :: a(:)[:,:,:], b(:)[:,:], c(:,:)[:] +integer, save :: d(2)[-1:3, *] +integer, save :: e(2)[-1:-1, 3:*] + +one = num_images() == 1 + +allocate(a(1)[3:3, -4:-3, 88:*]) +allocate(b(2)[-1:0,0:*]) +allocate(c(3,3)[*]) + +index1 = image_index(a, [3, -4, 88] ) +index2 = image_index(b, [-1, 0] ) +index3 = image_index(c, [1] ) +if (index1 /= 1 .or. index2 /= 1 .or. index3 /= 1) STOP 1 + + +index1 = image_index(a, [3, -3, 88] ) +index2 = image_index(b, [0, 0] ) +index3 = image_index(c, [2] ) + +if (one .and. (index1 /= 0 .or. index2 /= 0 .or. index3 /= 0)) & + STOP 2 +if (.not. one .and. (index1 /= 2 .or. index2 /= 2 .or. index3 /= 2)) & + STOP 3 + + +index1 = image_index(d, [-1, 1] ) +index2 = image_index(d, [0, 1] ) + +if (one .and. (index1 /= 1 .or. index2 /= 0)) & + STOP 4 +if (.not. one .and. (index1 /= 1 .or. index2 /= 2)) & + STOP 5 + +index1 = image_index(e, [-1, 3] ) +index2 = image_index(e, [-1, 4] ) + +if (one .and. (index1 /= 1 .or. index2 /= 0)) & + STOP 6 +if (.not. one .and. (index1 /= 1 .or. index2 /= 2)) & + STOP 7 + +call test(1, a,b,c) + +! The following test is in honour of the F2008 standard: +deallocate(a) +allocate(a (10) [10, 0:9, 0:*]) + +index1 = image_index(a, [1, 0, 0] ) +index2 = image_index(a, [3, 1, 2] ) ! = 213, yeah! +index3 = image_index(a, [3, 1, 0] ) ! = 13 + +if (num_images() < 13 .and. (index1 /= 1 .or. index2 /= 0 .or. index3 /= 0)) & + STOP 8 +if (num_images() >= 213 .and. (index1 /= 1 .or. index2 /= 213 .or. index3 /= 13)) & + STOP 9 +if (num_images() >= 13 .and. (index1 /= 1 .or. index2 /= 0 .or. index3 /= 13)) & + STOP 10 + + +contains +subroutine test(n, a, b, c) + integer :: n + integer :: a(1)[3*n:3*n, -4*n:-3*n, 88*n:*], b(2)[-1*n:0*n,0*n:*], c(3*n,3*n)[*] + + index1 = image_index(a, [3, -4, 88] ) + index2 = image_index(b, [-1, 0] ) + index3 = image_index(c, [1] ) + if (index1 /= 1 .or. index2 /= 1 .or. index3 /= 1) STOP 11 + + + index1 = image_index(a, [3, -3, 88] ) + index2 = image_index(b, [0, 0] ) + index3 = image_index(c, [2] ) + + if (one .and. (index1 /= 0 .or. index2 /= 0 .or. index3 /= 0)) & + STOP 12 + if (.not. one .and. (index1 /= 2 .or. index2 /= 2 .or. index3 /= 2)) & + STOP 13 +end subroutine test +end program test_image_index diff --git a/Fortran/gfortran/regression/coarray_17.f90 b/Fortran/gfortran/regression/coarray_17.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_17.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! Two simple diagnostics, which were initially not thought of +! +! General coarray PR: PR fortran/18918 +! + +subroutine one + integer, allocatable :: a(:)[:,:] ! corank = 2 + integer :: index,nn1,nn2,nn3,mm0 + + allocate(a(mm0)[nn1:nn2,nn3,*]) ! { dg-error "Too many codimensions at .1., expected 2 not 3" } +end subroutine one + +subroutine two + integer, allocatable :: a(:)[:,:,:], b(:)[:,:], c(:)[:] + index1 = image_index(a, [2, 1, 1] ) !OK + index2 = image_index(b, [2, 1, 1] ) ! { dg-error "array elements of the SUB argument to IMAGE_INDEX at .1. shall be 2 .corank. not 3" } + index3 = image_index(c, [1] ) !OK +end subroutine two diff --git a/Fortran/gfortran/regression/coarray_18.f90 b/Fortran/gfortran/regression/coarray_18.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_18.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! Prevent ICE when exceeding the maximal number of allowed +! dimensions (normal + codimensions). +! +! Fortran 2008 allows (co)arrays with 15 ranks +! Previously gfortran only supported 7, cf. PR 37577 +! +! See also general coarray PR 18918 +! +! Test case taken from Leibniz-Rechenzentrum (LRZ)'s +! fortran_tests with thanks to Reinhold Bader. +! + +program ar + implicit none + integer :: ic(2)[*] + integer :: id(2,2)[2,*] + integer :: ie(2,2,2)[2,2,*] +! Previously, these would give errors. + integer :: ig(2,2,2,2)[2,2,2,*] + integer :: ih(2,2,2,2,2)[2,2,2,2,*] + integer :: ij(2,2,2,2,2,2)[2,2,2,2,2,*] + integer :: ik(2,2,2,2,2,2,2)[2,2,2,2,2,2,*] + integer :: il[2,2,2,2,2,2,2,*] + integer :: im[2,2,2,2,2,2,2,2,*] + integer :: in[2,2,2,2,2,2,2,2,2,*] + integer :: io[2,2,2,2,2,2,2,2,2,2,*] +! Now with max dimensions 15..... + integer :: ip(2,2,2,2,2,2,2,2)[2,2,2,2,2,2,2,*] ! { dg-error "has more than 15 dimensions" } + integer :: iq[2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,*] ! { dg-error "has more than 15 dimensions" } +! Check a non-coarray + integer :: ir(2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2) ! { dg-error "has more than 15 dimensions" } + real :: x2(2,2,4)[2,*] + complex :: c2(4,2)[2,*] + double precision :: d2(1,5,9)[2,*] + character(len=1) :: ch2(2)[2,*] + character(len=2) :: ch22(-5:4)[2,*] + logical :: l2(17)[2,*] + if (this_image() == 1) then + write(*,*) 'OK' + end if +end program diff --git a/Fortran/gfortran/regression/coarray_19.f90 b/Fortran/gfortran/regression/coarray_19.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_19.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/18918 +! + +! Was failing before as the "x%a()[]" was +! regarded as coindexed +subroutine test2() + type t + integer, allocatable :: a(:)[:] + end type t + type(t), SAVE :: x + allocate(x%a(1)[*]) +end subroutine test2 + + +module m + integer, allocatable :: a(:)[:] +end module m + +! Was failing as "a" was allocatable but +! as->cotype was not AS_DEFERERED. +use m +end diff --git a/Fortran/gfortran/regression/coarray_2.f90 b/Fortran/gfortran/regression/coarray_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_2.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! { dg-options "-fcoarray=single" } +! { dg-shouldfail "error stop" } +! +! Coarray support +! PR fortran/18918 + +implicit none +integer :: n +character(len=30) :: str +critical +end critical +myCr: critical +end critical myCr + sync all + sync all ( ) + n = 5 + sync all (stat=n) + if (n /= 0) STOP 1 + n = 5 + sync all (stat=n,errmsg=str) + if (n /= 0) STOP 2 + sync all (errmsg=str) + + sync memory + sync memory ( ) + n = 5 + sync memory (stat=n) + if (n /= 0) STOP 3 + n = 5 + sync memory (errmsg=str,stat=n) + if (n /= 0) STOP 4 + sync memory (errmsg=str) + +sync images (*, stat=n) +sync images (1, errmsg=str) +sync images ([1],errmsg=str,stat=n) + +sync images (*) +sync images (1) +sync images ([1]) + +if (num_images() /= 1) STOP 5 +error stop 'stop' +end + +! { dg-output "ERROR STOP stop" } diff --git a/Fortran/gfortran/regression/coarray_20.f90 b/Fortran/gfortran/regression/coarray_20.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_20.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! Before a bogus error (argument not simply contiguous) +! was printed instead of the rank mismatch +! +! PR fortran/18918 +! +integer :: A[*] +call bar(A) ! { dg-error "Rank mismatch in argument" } +contains + subroutine bar(x) + integer :: x(1)[*] + end subroutine bar +end diff --git a/Fortran/gfortran/regression/coarray_21.f90 b/Fortran/gfortran/regression/coarray_21.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_21.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/18918 +! +! Before scalar coarrays weren't regarded as scalar in the ME. +! +module mod_reduction + real :: g[*] +contains + subroutine caf_reduce(x) + real, intent(in) :: x + g = x ! << used to ICE + end +end module + +program test + integer, parameter :: size = 4000 + type :: pct + integer, allocatable :: data(:,:) + end type + type(pct) :: picture[*] + allocate(picture%data(size, size)) +end program test diff --git a/Fortran/gfortran/regression/coarray_22.f90 b/Fortran/gfortran/regression/coarray_22.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_22.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! Constraint checks for invalid access of remote pointers +! (Accessing the value is ok, checking/changing association +! status is invalid) +! +! PR fortran/18918 +! +type t + integer, pointer :: ptr => null() +end type t +type(t) :: x[*], y[*] + +if (associated(x%ptr)) stop 0 +if (associated(x%ptr,y%ptr)) stop 0 + +if (associated(x[1]%ptr)) stop 0 ! { dg-error "shall not be coindexed" } +if (associated(x%ptr,y[1]%ptr)) stop 0 ! { dg-error "shall not be coindexed" } + +nullify (x%ptr) +nullify (x[1]%ptr) ! { dg-error "shall not be coindexed" } + +x%ptr => null(x%ptr) +x%ptr => null(x[1]%ptr) ! { dg-error "shall not be coindexed" } +x[1]%ptr => null(x%ptr) ! { dg-error "shall not have a coindex" } + +allocate(x%ptr) +deallocate(x%ptr) + +allocate(x[1]%ptr) ! { dg-error "Coindexed allocatable object" } +deallocate(x[1]%ptr) ! { dg-error "Coindexed allocatable object" } +end diff --git a/Fortran/gfortran/regression/coarray_23.f90 b/Fortran/gfortran/regression/coarray_23.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_23.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/18918 +! +! The example was ICEing before as the tree-decl +! of the type was wrong. +! + + subroutine test + complex, save :: z[*] + if (z /= cmplx (0.0, 0.0)) STOP 1 + end subroutine test diff --git a/Fortran/gfortran/regression/coarray_24.f90 b/Fortran/gfortran/regression/coarray_24.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_24.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single -Wall" } +! +! This program is perfectly valid; however, passing an (allocatable) coarray +! as actual argument to a non-coarray allocatable dummy is doubtful as +! reallocation is not allowed. Thus, an intent(out) dummy should be always +! wrong. +! + +integer, allocatable :: myCaf(:)[:] + +allocate(myCaf(1)[*]) + +call doubtful_valid(myCaf) ! { dg-warning "to allocatable, noncoarray dummy" } +call invalid(myCaf) ! { dg-error "to allocatable, noncoarray, INTENT.OUT. dummy" } +contains + subroutine doubtful_valid(x) + integer, allocatable :: x(:) + ! Valid as x's allocation status is not touched. + x(1) = 7 + end subroutine doubtful_valid + subroutine invalid(y) + integer, allocatable, intent(out) :: y(:) + allocate (y(1)) + end subroutine invalid +end diff --git a/Fortran/gfortran/regression/coarray_25.f90 b/Fortran/gfortran/regression/coarray_25.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_25.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! Used to be rejected with: +! Error: Variable 'x' at (1) is a coarray or has a coarray +! component and is not ALLOCATABLE, SAVE nor a dummy argument +! +! Is valid as "a" is allocatable, cf. C526 +! and http://j3-fortran.org/pipermail/j3/2011-June/004403.html +! + + subroutine test2() + type t + integer, allocatable :: a(:)[:] + end type t + type(t) :: x + allocate(x%a(1)[*]) + end subroutine test2 diff --git a/Fortran/gfortran/regression/coarray_26.f90 b/Fortran/gfortran/regression/coarray_26.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_26.f90 @@ -0,0 +1,53 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! Coarray declaration constraint checks +! + +function foo3a() result(res) + implicit none + integer :: res + codimension :: res[*] ! { dg-error "CODIMENSION attribute conflicts with RESULT" } +end + +function foo2a() result(res) + integer :: res[*] ! { dg-error "CODIMENSION attribute conflicts with RESULT" } +end + +function fooa() result(res) ! { dg-error "shall not be a coarray or have a coarray component" } + implicit none + type t + integer, allocatable :: A[:] + end type t + type(t):: res +end + +function foo3() ! { dg-error "shall not be a coarray or have a coarray component" } + implicit none + integer :: foo3 + codimension :: foo3[*] +end + +function foo2() ! { dg-error "shall not be a coarray or have a coarray component" } + implicit none + integer :: foo2[*] +end + +function foo() ! { dg-error "shall not be a coarray or have a coarray component" } + type t + integer, allocatable :: A[:] + end type t + type(t):: foo +end + +subroutine test() + use iso_c_binding + implicit none + type(c_ptr), save :: caf[*] ! { dg-error "shall not be a coarray" } +end subroutine test + +subroutine test2() + use iso_c_binding + implicit none + type(c_funptr), save :: caf[*] ! { dg-error "shall not be a coarray" } +end subroutine test2 diff --git a/Fortran/gfortran/regression/coarray_27.f90 b/Fortran/gfortran/regression/coarray_27.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_27.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! Coarray/coindex checks for MOVE_ALLOC +! +integer, allocatable :: a(:), b(:)[:,:], c(:)[:,:] + +type t + integer, allocatable :: d(:) +end type t +type(t) :: x[*] +class(t), allocatable :: y[:], z[:], u + + +call move_alloc (A, b) ! { dg-error "must have the same corank" } +call move_alloc (c, A) ! { dg-error "must have the same corank" } +call move_alloc (b, c) ! OK - same corank + +call move_alloc (u, y) ! { dg-error "must have the same corank" } +call move_alloc (z, u) ! { dg-error "must have the same corank" } +call move_alloc (y, z) ! OK - same corank + + +call move_alloc (x%d, a) ! OK +call move_alloc (a, x%d) ! OK +call move_alloc (x[1]%d, a) ! { dg-error "The FROM argument to MOVE_ALLOC at .1. shall not be coindexed" } +call move_alloc (a, x[1]%d) ! { dg-error "The TO argument to MOVE_ALLOC at .1. shall not be coindexed" } + +call move_alloc (y%d, a) ! OK +call move_alloc (a, y%d) ! OK +call move_alloc (y[1]%d, a) ! { dg-error "The FROM argument to MOVE_ALLOC at .1. shall not be coindexed" } +call move_alloc (a, y[1]%d) ! { dg-error "The TO argument to MOVE_ALLOC at .1. shall not be coindexed" } + +end diff --git a/Fortran/gfortran/regression/coarray_28.f90 b/Fortran/gfortran/regression/coarray_28.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_28.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/54225 +! + +integer, allocatable :: a[:,:] + +allocate (a[*,4]) ! { dg-error "Unexpected '.' for codimension 1 of 2" } +end diff --git a/Fortran/gfortran/regression/coarray_29_1.f90 b/Fortran/gfortran/regression/coarray_29_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_29_1.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } + +! To be used by coarray_29_2.f90 +! PR fortran/55272 + +module co_sum_module + implicit none +contains + subroutine co_sum(scalar) + integer scalar[*] + end subroutine +end module diff --git a/Fortran/gfortran/regression/coarray_29_2.f90 b/Fortran/gfortran/regression/coarray_29_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_29_2.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! { dg-compile-aux-modules "coarray_29_1.f90" } + +! PR fortran/55272 +! +! Contributed by Damian Rouson + +program main + use co_sum_module + implicit none + integer score[*] + call co_sum(score) +end program + +! { dg-final { cleanup-modules "co_sum_module" } } diff --git a/Fortran/gfortran/regression/coarray_3.f90 b/Fortran/gfortran/regression/coarray_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_3.f90 @@ -0,0 +1,100 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! Coarray support +! PR fortran/18918 + +implicit none +integer :: n, m(1), k +character(len=30) :: str(2) + +critical fkl ! { dg-error "Syntax error in CRITICAL" } +end critical fkl ! { dg-error "Expecting END PROGRAM" } + +sync all (stat=1) ! { dg-error "Non-variable expression" } +sync all ( stat = n,stat=k) ! { dg-error "Redundant STAT" } +sync memory (errmsg=str) ! { dg-error "must be a scalar CHARACTER variable" } +sync memory (errmsg=n) ! { dg-error "must be a scalar CHARACTER variable" } +sync images (*, stat=1.0) ! { dg-error "must be a scalar INTEGER variable" } +sync images (-1) ! { dg-error "must between 1 and num_images" } +sync images (1) +sync images ( [ 1 ]) +sync images ( m(1:0) ) +sync images ( reshape([1],[1,1])) ! { dg-error "must be a scalar or rank-1" } +end + +subroutine foo +critical + stop 'error' ! { dg-error "Image control statement STOP" } + sync all ! { dg-error "Image control statement SYNC" } + return 1 ! { dg-error "Image control statement RETURN" } + critical ! { dg-error "Nested CRITICAL block" } + end critical +end critical ! { dg-error "Expecting END SUBROUTINE" } +end + +subroutine bar() +do + critical + cycle ! { dg-error "leaves CRITICAL construct" } + end critical +end do + +outer: do + critical + do + exit + exit outer ! { dg-error "leaves CRITICAL construct" } + end do + end critical +end do outer +end subroutine bar + + +subroutine sub() +333 continue ! { dg-error "leaves CRITICAL construct" } +do + critical + if (.false.) then + goto 333 ! { dg-error "leaves CRITICAL construct" } + goto 777 +777 end if + end critical +end do + +if (.true.) then +outer: do + critical + do + goto 444 + goto 555 ! { dg-error "leaves CRITICAL construct" } + end do +444 continue + end critical + end do outer +555 end if ! { dg-error "leaves CRITICAL construct" } +end subroutine sub + +pure subroutine pureSub() + critical ! { dg-error "Image control statement CRITICAL" } + end critical ! { dg-error "Expecting END SUBROUTINE statement" } + sync all ! { dg-error "Image control statement SYNC" } + error stop +end subroutine pureSub + + +SUBROUTINE TEST + goto 10 ! { dg-warning "is not in the same block" } + CRITICAL + goto 5 ! OK +5 continue ! { dg-warning "is not in the same block" } + goto 10 ! OK + goto 20 ! { dg-error "leaves CRITICAL construct" } + goto 30 ! { dg-error "leaves CRITICAL construct" } +10 END CRITICAL ! { dg-warning "is not in the same block" } + goto 5 ! { dg-warning "is not in the same block" } +20 continue ! { dg-error "leaves CRITICAL construct" } + BLOCK +30 continue ! { dg-error "leaves CRITICAL construct" } + END BLOCK +end SUBROUTINE TEST diff --git a/Fortran/gfortran/regression/coarray_30.f90 b/Fortran/gfortran/regression/coarray_30.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_30.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single -fdump-tree-original" } +! +! PR fortran/57093 +! +! Contributed by Damian Rouson +! +program main + character(len=25), allocatable :: greeting[:] + allocate(greeting[*]) + write(greeting,"(a)") "z" +end + +! { dg-final { scan-tree-dump-times "greeting.data = \\(void . restrict\\) __builtin_malloc \\(25\\);" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_31.f90 b/Fortran/gfortran/regression/coarray_31.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_31.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -fcoarray=single" } +! +! PR fortran/57906 +! PR fortran/52052 +! +type t + integer, allocatable :: x(:)[:] + class(*), allocatable :: z(:)[:] + class(*), allocatable :: d[:] +end type t +type t2 + type(t) :: y +end type t2 +type(t2) :: a, b +a = b +end + +! { dg-final { scan-tree-dump "a.y.x.data = D.\[0-9\]+.y.x.data;" "original" } } +! { dg-final { scan-tree-dump "a.y.z._data.data = D.\[0-9\]+.y.z._data.data;" "original" } } +! { dg-final { scan-tree-dump "a.y.d._data.data = D.\[0-9\]+.y.d._data.data;" "original" } } diff --git a/Fortran/gfortran/regression/coarray_32.f90 b/Fortran/gfortran/regression/coarray_32.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_32.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -fcoarray=lib" } +! + real, allocatable :: values(:)[:] + allocate(values(1024)[*]) + call laplacian(values) +contains + subroutine laplacian(rhs) + real, allocatable :: rhs(:)[:] + real :: local_laplacian(size(rhs)) + local_laplacian=0. + end subroutine +end + +! { dg-final { scan-tree-dump-times "ubound.. = " 1 "original" } } +! { dg-final { scan-tree-dump-times "size.. = " 2 "original" } } + diff --git a/Fortran/gfortran/regression/coarray_33.f90 b/Fortran/gfortran/regression/coarray_33.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_33.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } +type t + integer :: x +end type t + +class(t), allocatable :: a[:] +allocate(t :: a[*]) +a%x = this_image() + +call foo(a[i]) ! { dg-error "Coindexed polymorphic actual argument at .1. is passed polymorphic dummy argument" } +contains +subroutine foo(y) + class(t) :: y + print *, y%x +end subroutine foo +end diff --git a/Fortran/gfortran/regression/coarray_34.f90 b/Fortran/gfortran/regression/coarray_34.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_34.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +use iso_fortran_env +implicit none + +type t + integer, pointer :: caf2[:] ! { dg-error "must be allocatable with deferred shape" } +end type t + +integer, pointer :: caf[*] ! { dg-error "POINTER attribute conflicts with CODIMENSION attribute" } + +type t2 + type(lock_type), pointer :: lock_it ! { dg-error "Component lock_it at .1. of type LOCK_TYPE must have a codimension or be a subcomponent of a coarray, which is not possible as the component has the pointer attribute" } +end type t2 +type(t2) :: caf3[*] + +type t3 + type(lock_type) :: x +end type t3 + +type t4 + type(t3), pointer :: y ! { dg-error "Pointer component y at .1. has a noncoarray subcomponent of type LOCK_TYPE, which must have a codimension or be a subcomponent of a coarray" } +end type t4 + +end diff --git a/Fortran/gfortran/regression/coarray_35.f90 b/Fortran/gfortran/regression/coarray_35.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_35.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } +! +! To be used with coarray_35a.f90 +! Check that the coarray declared in the module is accessible +! by checking the assembler name +! +! Contributed by Alessandro Fanfarillo. +! +module global_coarrays + implicit none + integer,parameter :: n=10 + integer :: b(10)[*] +end module global_coarrays + +! Check for the symbol of the coarray token (w/o system-dependend prefix) +! { dg-final { scan-assembler "caf_token__global_coarrays_MOD_b" } } diff --git a/Fortran/gfortran/regression/coarray_35a.f90 b/Fortran/gfortran/regression/coarray_35a.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_35a.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } +! { dg-compile-aux-modules "coarray_35.f90" } +! +! Check that the coarray declared in the module is accessible +! by checking the assembler name +! +! Contributed by Alessandro Fanfarillo. +! +program testmod + use global_coarrays + implicit none + + integer :: me + + me = this_image() + + b = me + + if(me==1) then + b(:) = b(:)[2] + write(*,*) b + end if + +end program testmod + +! Check for the symbol of the coarray token (w/o system-dependend prefix) +! { dg-final { scan-assembler "caf_token__global_coarrays_MOD_b" } } +! { dg-final { cleanup-modules "global_coarrays" } } diff --git a/Fortran/gfortran/regression/coarray_36.f b/Fortran/gfortran/regression/coarray_36.f --- /dev/null +++ b/Fortran/gfortran/regression/coarray_36.f @@ -0,0 +1,347 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } +! +! PR fortran/64771 +! +! Contributed by Alessandro Fanfarill +! +! Reduced version of the full NAS CG benchmark +! + +!-------------------------------------------------------------------------! +! ! +! N A S P A R A L L E L B E N C H M A R K S 3.3 ! +! ! +! C G ! +! ! +!-------------------------------------------------------------------------! +! ! +! This benchmark is part of the NAS Parallel Benchmark 3.3 suite. ! +! It is described in NAS Technical Reports 95-020 and 02-007 ! +! ! +! Permission to use, copy, distribute and modify this software ! +! for any purpose with or without fee is hereby granted. We ! +! request, however, that all derived work reference the NAS ! +! Parallel Benchmarks 3.3. This software is provided "as is" ! +! without express or implied warranty. ! +! ! +! Information on NPB 3.3, including the technical report, the ! +! original specifications, source code, results and information ! +! on how to submit new results, is available at: ! +! ! +! http://www.nas.nasa.gov/Software/NPB/ ! +! ! +! Send comments or suggestions to npb@nas.nasa.gov ! +! ! +! NAS Parallel Benchmarks Group ! +! NASA Ames Research Center ! +! Mail Stop: T27A-1 ! +! Moffett Field, CA 94035-1000 ! +! ! +! E-mail: npb@nas.nasa.gov ! +! Fax: (650) 604-3957 ! +! ! +!-------------------------------------------------------------------------! + + +c--------------------------------------------------------------------- +c +c Authors: M. Yarrow +c C. Kuszmaul +c R. F. Van der Wijngaart +c H. Jin +c +c--------------------------------------------------------------------- + + +c--------------------------------------------------------------------- +c--------------------------------------------------------------------- + program cg +c--------------------------------------------------------------------- +c--------------------------------------------------------------------- + implicit none + + integer na, nonzer, niter + double precision shift, rcond + parameter( na=75000, + > nonzer=13, + > niter=75, + > shift=60., + > rcond=1.0d-1 ) + + + + integer num_proc_rows, num_proc_cols + parameter( num_proc_rows = 2, num_proc_cols = 2) + integer num_procs + parameter( num_procs = num_proc_cols * num_proc_rows ) + + integer nz + parameter( nz = na*(nonzer+1)/num_procs*(nonzer+1)+nonzer + > + na*(nonzer+2+num_procs/256)/num_proc_cols ) + + common / partit_size / naa, nzz, + > npcols, nprows, + > proc_col, proc_row, + > firstrow, + > lastrow, + > firstcol, + > lastcol, + > exch_proc, + > exch_recv_length, + > send_start, + > send_len + integer naa, nzz, + > npcols, nprows, + > proc_col, proc_row, + > firstrow, + > lastrow, + > firstcol, + > lastcol, + > exch_proc, + > exch_recv_length, + > send_start, + > send_len + + + common / main_int_mem / colidx, rowstr, + > iv, arow, acol + integer colidx(nz), rowstr(na+1), + > iv(2*na+1), arow(nz), acol(nz) + + +c--------------------------------- +c Coarray Decalarations +c--------------------------------- + double precision v(na+1)[0:*], aelt(nz)[0:*], a(nz)[0:*], + > x(na/num_proc_rows+2)[0:*], + > z(na/num_proc_rows+2)[0:*], + > p(na/num_proc_rows+2)[0:*], + > q(na/num_proc_rows+2)[0:*], + > r(na/num_proc_rows+2)[0:*], + > w(na/num_proc_rows+2)[0:*] + + + common /urando/ amult, tran + double precision amult, tran + + + + integer l2npcols + integer reduce_exch_proc(num_proc_cols) + integer reduce_send_starts(num_proc_cols) + integer reduce_send_lengths(num_proc_cols) + integer reduce_recv_lengths(num_proc_cols) + integer reduce_rrecv_starts(num_proc_cols) +c--------------------------------- +c Coarray Decalarations +c--------------------------------- + integer reduce_recv_starts(num_proc_cols)[0:*] + + integer i, j, k, it, me, nprocs, root + + double precision zeta, randlc + external randlc + double precision rnorm +c--------------------------------- +c Coarray Decalarations +c--------------------------------- + double precision norm_temp1(2)[0:*], norm_temp2(2)[0:*] + + double precision t, tmax, mflops + double precision u(1), umax(1) + external timer_read + double precision timer_read + character class + logical verified + double precision zeta_verify_value, epsilon, err + +c--------------------------------------------------------------------- +c Explicit interface for conj_grad, due to coarray args +c--------------------------------------------------------------------- + interface + + subroutine conj_grad ( colidx, + > rowstr, + > x, + > z, + > a, + > p, + > q, + > r, + > w, + > rnorm, + > l2npcols, + > reduce_exch_proc, + > reduce_send_starts, + > reduce_send_lengths, + > reduce_recv_starts, + > reduce_recv_lengths, + > reduce_rrecv_starts ) + + common / partit_size / naa, nzz, + > npcols, nprows, + > proc_col, proc_row, + > firstrow, + > lastrow, + > firstcol, + > lastcol, + > exch_proc, + > exch_recv_length, + > send_start, + > send_len + + integer naa, nzz, + > npcols, nprows, + > proc_col, proc_row, + > firstrow, + > lastrow, + > firstcol, + > lastcol, + > exch_proc, + > exch_recv_length, + > send_start, + > send_len + + double precision x(*), + > z(*), + > a(nzz) + integer colidx(nzz), rowstr(naa+1) + + double precision p(*), + > q(*)[0:*], + > r(*)[0:*], + > w(*)[0:*] ! used as work temporary + + integer l2npcols + integer reduce_exch_proc(l2npcols) + integer reduce_send_starts(l2npcols) + integer reduce_send_lengths(l2npcols) + integer reduce_recv_starts(l2npcols)[0:*] + integer reduce_recv_lengths(l2npcols) + integer reduce_rrecv_starts(l2npcols) + + double precision rnorm + + end subroutine + + end interface + +c--------------------------------------------------------------------- +c The call to the conjugate gradient routine: +c--------------------------------------------------------------------- + call conj_grad ( colidx, + > rowstr, + > x, + > z, + > a, + > p, + > q, + > r, + > w, + > rnorm, + > l2npcols, + > reduce_exch_proc, + > reduce_send_starts, + > reduce_send_lengths, + > reduce_recv_starts, + > reduce_recv_lengths, + > reduce_rrecv_starts ) + + + sync all + + end ! end main + +c--------------------------------------------------------------------- +c--------------------------------------------------------------------- + subroutine conj_grad ( colidx, + > rowstr, + > x, + > z, + > a, + > p, + > q, + > r, + > w, + > rnorm, + > l2npcols, + > reduce_exch_proc, + > reduce_send_starts, + > reduce_send_lengths, + > reduce_recv_starts, + > reduce_recv_lengths, + > reduce_rrecv_starts ) +c--------------------------------------------------------------------- +c--------------------------------------------------------------------- + +c--------------------------------------------------------------------- +c Floaging point arrays here are named as in NPB1 spec discussion of +c CG algorithm +c--------------------------------------------------------------------- + + implicit none + +c include 'cafnpb.h' + + common / partit_size / naa, nzz, + > npcols, nprows, + > proc_col, proc_row, + > firstrow, + > lastrow, + > firstcol, + > lastcol, + > exch_proc, + > exch_recv_length, + > send_start, + > send_len + integer naa, nzz, + > npcols, nprows, + > proc_col, proc_row, + > firstrow, + > lastrow, + > firstcol, + > lastcol, + > exch_proc, + > exch_recv_length, + > send_start, + > send_len + + + + double precision x(*), + > z(*), + > a(nzz) + integer colidx(nzz), rowstr(naa+1) + + double precision p(*), + > q(*)[0:*], + > r(*)[0:*], + > w(*)[0:*] ! used as work temporary + + integer l2npcols + integer reduce_exch_proc(l2npcols) + integer reduce_send_starts(l2npcols) + integer reduce_send_lengths(l2npcols) + integer reduce_recv_starts(l2npcols)[0:*] + integer reduce_recv_lengths(l2npcols) + integer reduce_rrecv_starts(l2npcols) + + integer recv_start_idx, recv_end_idx, send_start_idx, + > send_end_idx, recv_length + + integer i, j, k, ierr + integer cgit, cgitmax + + double precision, save :: d[0:*], rho[0:*] + double precision sum, rho0, alpha, beta, rnorm + + external timer_read + double precision timer_read + + data cgitmax / 25 / + + + return + end ! end of routine conj_grad + diff --git a/Fortran/gfortran/regression/coarray_37.f90 b/Fortran/gfortran/regression/coarray_37.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_37.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! + program cg + implicit none + integer reduce_recv_starts(2)[1,0:*] + interface + subroutine conj_grad (reduce_recv_starts) ! { dg-warning "Interface mismatch in global procedure 'conj_grad' at \\(1\\): Corank mismatch in argument 'reduce_recv_starts' \\(2/1\\)" } + integer reduce_recv_starts(2)[2, 2:*] + end subroutine + end interface + call conj_grad (reduce_recv_starts) ! Corank mismatch is okay + end + + subroutine conj_grad (reduce_recv_starts) + implicit none + integer reduce_recv_starts(2)[2:*] + end diff --git a/Fortran/gfortran/regression/coarray_38.f90 b/Fortran/gfortran/regression/coarray_38.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_38.f90 @@ -0,0 +1,132 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } +! +! Valid code - but currently not implemented for -fcoarray=lib; single okay +! +subroutine one +implicit none +type t + integer, allocatable :: a + integer :: b +end type t +type t2 + type(t), allocatable :: caf2[:] +end type t2 +type(t), save :: caf[*],x +type(t2) :: y + +x = caf[4] ! OK, now +x%a = caf[4]%a ! OK, now +x%b = caf[4]%b ! OK +x = y%caf2[5] ! OK, now +x%a = y%caf2[4]%a ! OK, now +x%b = y%caf2[4]%b ! OK +end subroutine one + +subroutine two +implicit none +type t + integer, pointer :: a + integer :: b +end type t +type t2 + type(t), allocatable :: caf2[:] +end type t2 +type(t), save :: caf[*],x +type(t2) :: y + +x = caf[4] ! OK +x%a = caf[4]%a ! OK, now +x%b = caf[4]%b ! OK +x = y%caf2[5] ! OK +x%a = y%caf2[4]%a ! OK, now +x%b = y%caf2[4]%b ! OK +end subroutine two + +subroutine three +implicit none +type t + integer :: b +end type t +type t2 + type(t), allocatable :: caf2(:)[:] +end type t2 +type(t), save :: caf(10)[*] +integer :: x(10) +type(t2) :: y + +x(1) = caf(2)[4]%b ! OK +x(:) = caf(:)[4]%b ! OK now + +x(1) = y%caf2(2)[4]%b ! OK +x(:) = y%caf2(:)[4]%b ! OK now +end subroutine three + +subroutine four +implicit none +type t + integer, allocatable :: a + integer :: b +end type t +type t2 + class(t), allocatable :: caf2[:] +end type t2 +class(t), allocatable :: caf[:] ! { dg-error "Sorry, allocatable/pointer components in polymorphic" } +type(t) :: x +type(t2) :: y + +!x = caf[4] ! Unsupported - and ICEs in resolve_ordinary_assign, cf. PR fortran/65397 +x%a = caf[4]%a ! OK, now +x%b = caf[4]%b ! OK +!x = y%caf2[5] ! Unsupported - and ICEs in resolve_ordinary_assign, cf. PR fortran/65397 +x%a = y%caf2[4]%a ! Ok, now +x%b = y%caf2[4]%b ! OK +end subroutine four + +subroutine five +implicit none +type t + integer, pointer :: a + integer :: b +end type t +type t2 + class(t), allocatable :: caf2[:] +end type t2 +class(t), save, allocatable :: caf[:] ! { dg-error "Sorry, allocatable/pointer components in polymorphic" } +type(t) :: x +type(t2) :: y + +!x = caf[4] ! OK - but ICEs in resolve_ordinary_assign, cf. PR fortran/65397 +x%a = caf[4]%a ! OK, now +x%b = caf[4]%b ! OK +!x = y%caf2[5] ! OK - but ICEs in resolve_ordinary_assign, cf. PR fortran/65397 +x%a = y%caf2[4]%a ! OK, now +x%b = y%caf2[4]%b ! OK +end subroutine five + +subroutine six +implicit none +type t + integer :: b +end type t +type t2 + class(t), allocatable :: caf2(:)[:] +end type t2 +class(t), save, allocatable :: caf(:)[:] +integer :: x(10) +type(t2) :: y + +x(1) = caf(2)[4]%b ! OK +x(:) = caf(:)[4]%b ! OK now + +x(1) = y%caf2(2)[4]%b ! OK +x(:) = y%caf2(:)[4]%b ! OK now +end subroutine six + +call one() +call two() +call three() +call four() +call five() +call six() +end diff --git a/Fortran/gfortran/regression/coarray_39.f90 b/Fortran/gfortran/regression/coarray_39.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_39.f90 @@ -0,0 +1,124 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! Valid code - but currently not implemented for -fcoarray=lib; single okay +! +subroutine one +implicit none +type t + integer, allocatable :: a + integer :: b +end type t +type t2 + type(t), allocatable :: caf2[:] +end type t2 +type(t), save :: caf[*],x +type(t2) :: y + +x = caf[4] +x%a = caf[4]%a +x%b = caf[4]%a +x = y%caf2[5] +x%a = y%caf2[4]%a +x%b = y%caf2[4]%b +end subroutine one + +subroutine two +implicit none +type t + integer, pointer :: a + integer :: b +end type t +type t2 + type(t), allocatable :: caf2[:] +end type t2 +type(t), save :: caf[*],x +type(t2) :: y + +x = caf[4] +x%a = caf[4]%a +x%b = caf[4]%b +x = y%caf2[5] +x%a = y%caf2[4]%a +x%b = y%caf2[4]%b +end subroutine two + +subroutine three +implicit none +type t + integer :: b +end type t +type t2 + type(t), allocatable :: caf2(:)[:] +end type t2 +type(t), save :: caf(10)[*] +integer :: x(10) +type(t2) :: y + +x(1) = caf(2)[4]%b +x(:) = caf(:)[4]%b + +x(1) = y%caf2(2)[4]%b +x(:) = y%caf2(:)[4]%b +end subroutine three + +subroutine four +implicit none +type t + integer, allocatable :: a + integer :: b +end type t +type t2 + class(t), allocatable :: caf2[:] +end type t2 +class(t), allocatable :: caf[:] +type(t) :: x +type(t2) :: y + +x = caf[4] +x%a = caf[4]%a +x%b = caf[4]%b +x = y%caf2[5] +x%a = y%caf2[4]%a +x%b = y%caf2[4]%b +end subroutine four + +subroutine five +implicit none +type t + integer, pointer :: a + integer :: b +end type t +type t2 + class(t), allocatable :: caf2[:] +end type t2 +class(t), save, allocatable :: caf[:] +type(t) :: x +type(t2) :: y + +x = caf[4] +x%a = caf[4]%a +x%b = caf[4]%b +x = y%caf2[5] +x%a = y%caf2[4]%a +x%b = y%caf2[4]%b +end subroutine five + +subroutine six +implicit none +type t + integer :: b +end type t +type t2 + class(t), allocatable :: caf2(:)[:] +end type t2 +class(t), save, allocatable :: caf(:)[:] +integer :: x(10) +type(t2) :: y + +x(1) = caf(2)[4]%b +x(:) = caf(:)[4]%b + +x(1) = y%caf2(2)[4]%b +x(:) = y%caf2(:)[4]%b +end subroutine six diff --git a/Fortran/gfortran/regression/coarray_4.f90 b/Fortran/gfortran/regression/coarray_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_4.f90 @@ -0,0 +1,88 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! Coarray support -- corank declarations +! PR fortran/18918 +! + +subroutine valid(n, c, f) + implicit none + integer :: n + integer, save :: a[*], b(4)[-1:4,*] + real :: c(*)[1,0:3,3:*] + real :: f(n)[0:n,-100:*] + integer, allocatable :: d[:], e(:)[:,:] + integer, save, codimension[1,*] :: g, h(7), i(6)[*], j[*] + integer :: k + codimension :: k[*] + save :: k + integer :: ii = 7 + block + integer :: j = 5 + integer, save :: kk[j, *] ! { dg-error "Variable .j. cannot appear in the expression" } + end block +end subroutine valid + +subroutine valid2() + type t + integer, allocatable :: a[:] + end type t + type, extends(t) :: tt + integer, allocatable :: b[:] + end type tt + type(tt), save :: foo + type(tt) :: bar +end subroutine valid2 + +subroutine invalid(n) + implicit none + integer :: n + integer :: k[*] ! { dg-error "not ALLOCATABLE, SAVE nor a dummy" } + integer :: h(3)[*] ! { dg-error "not ALLOCATABLE, SAVE nor a dummy" } + integer, save :: a[*] + codimension :: a[1,*] ! { dg-error "Duplicate CODIMENSION attribute" } + complex, save :: hh(n)[*] ! { dg-error "cannot have the SAVE attribute" } + integer :: j = 6 + + integer, save :: hf1[j,*] ! { dg-error "cannot appear in the expression" } + integer, save :: hf2[n,*] ! OK + integer, save :: hf3(4)[j,*] ! { dg-error "cannot appear in the expression|cannot have the SAVE attribute" } + integer, save :: hf4(5)[n,*] ! OK + + integer, allocatable :: a2[*] ! { dg-error "must have deferred shape" } + integer, allocatable :: a3(:)[*] ! { dg-error "must have deferred shape" } + integer, allocatable :: a4[*] ! { dg-error "must have deferred shape" } +end subroutine invalid + +subroutine invalid2 + use iso_c_binding + implicit none + type t0 + integer, allocatable :: a[:,:,:] + end type t0 + type t + end type t + type, extends(t) :: tt ! { dg-error "has a coarray component, parent type" } + integer, allocatable :: a[:] + end type tt + type ttt + integer, pointer :: a[:] ! { dg-error "must be allocatable" } + end type ttt + type t4 + integer, allocatable :: b[4,*] ! { dg-error "with deferred shape" } + end type t4 + type t5 + type(c_ptr), allocatable :: p[:] ! { dg-error "shall not be a coarray" } + end type t5 + type(t0), save :: t0_1[*] ! { dg-error "shall be a nonpointer, nonallocatable scalar" } + type(t0), allocatable :: t0_2[:] ! { dg-error "shall be a nonpointer, nonallocatable scalar" } + type(c_ptr), save :: pp[*] ! { dg-error "shall not be a coarray" } +end subroutine invalid2 + +elemental subroutine elem(a) ! { dg-error "Coarray dummy argument" } + integer, intent(in) :: a[*] +end subroutine + +function func() result(res) + integer :: res[*] ! { dg-error "CODIMENSION attribute conflicts with RESULT" } +end function func diff --git a/Fortran/gfortran/regression/coarray_40.f90 b/Fortran/gfortran/regression/coarray_40.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_40.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -lcaf_single" } +! { dg-additional-options "-latomic" { target libatomic_available } } +! +! Run-time test for memory consistency +! +! Contributed by Deepak Eachempati + +program cp_bug + implicit none + integer :: v1, v2, u[*] + integer :: me + + me = this_image() + + u = 0 + v1 = 10 + + v1 = u[me] + + ! v2 should get value in u (0) + v2 = v1 + + if(v2 /= u) STOP 1 + +end program diff --git a/Fortran/gfortran/regression/coarray_41.f90 b/Fortran/gfortran/regression/coarray_41.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_41.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -lcaf_single" } +! { dg-additional-options "-latomic" { target libatomic_available } } + +program coarray_41 + + integer, allocatable :: vec(:)[:,:] + + allocate(vec(10)[2,*], source= 37) + + if (.not. allocated(vec)) error stop + + call foo(vec) + + if (any(vec /= 42)) error stop + + deallocate(vec) +contains + + subroutine foo(gv) + + integer, allocatable, intent(inout) :: gv(:)[:,:] + integer, allocatable :: gvin(:) + + allocate(gvin, mold=gv) + gvin = 5 + gv = gv + gvin + end subroutine foo + +end program coarray_41 diff --git a/Fortran/gfortran/regression/coarray_42.f90 b/Fortran/gfortran/regression/coarray_42.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_42.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original -fcoarray=lib -lcaf_single" } +! { dg-additional-options "-latomic" { target libatomic_available } } + +program Jac + type Domain + integer :: n=64 + integer,allocatable :: endsi(:) + end type + type(Domain),allocatable :: D[:,:,:] + + allocate(D[2,2,*]) + allocate(D%endsi(2), source = 0) + ! Lhs may be reallocate, so caf_send_by_ref needs to be used. + D%endsi = D%n + if (any(D%endsi /= [ 64, 64])) error stop + deallocate(D) +end program + +! { dg-final { scan-tree-dump-times "caf_send_by_ref" 1 "original" } } + diff --git a/Fortran/gfortran/regression/coarray_43.f90 b/Fortran/gfortran/regression/coarray_43.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_43.f90 @@ -0,0 +1,14 @@ +! { dg-do link } +! { dg-options "-fcoarray=lib -lcaf_single" } +! { dg-additional-options "-latomic" { target libatomic_available } } + +program coarray_43 + implicit none + integer, parameter :: STR_LEN = 50 + character(len=STR_LEN) :: str[*] + integer :: pos + write(str,"(2(a,i2))") "Greetings from image ",this_image()," of ",num_images() + block + pos = scan(str[5], set="123456789") + end block +end program diff --git a/Fortran/gfortran/regression/coarray_44.f90 b/Fortran/gfortran/regression/coarray_44.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_44.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/70071 +! Based on testcases by Gerhard Steinmetz + +program pr70071 + implicit none + integer, allocatable :: z(:)[:,:] + allocate (z(2)[1::2,*]) ! { dg-error "Bad array dimension" } + allocate (z(1::2)[2,*]) ! { dg-error "Bad array specification in ALLOCATE" } +end program pr70071 + +! { dg-prune-output "Bad coarray specification in ALLOCATE statement" } diff --git a/Fortran/gfortran/regression/coarray_45.f90 b/Fortran/gfortran/regression/coarray_45.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_45.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -lcaf_single " } +! +! Test the fix for PR83076 +! +module m + type t + integer, pointer :: z + end type + type(t) :: ptr +contains + function g(x) + type(t) :: x[*] + if (associated (x%z, ptr%z)) deallocate (x%z) ! This used to ICE with -fcoarray=lib + end +end module + + use m +contains + function f(x) + type(t) :: x[*] + if (associated (x%z, ptr%z)) deallocate (x%z) + end +end diff --git a/Fortran/gfortran/regression/coarray_46.f90 b/Fortran/gfortran/regression/coarray_46.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_46.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -lcaf_single" } +! +! Test the fix for PR83319 +! +module foo_module + implicit none + type foo + integer, allocatable :: i(:) + end type +end module + + use foo_module + implicit none + type(foo), save :: bar[*] + allocate(bar%i(1)) ! Used to ICE here. +end diff --git a/Fortran/gfortran/regression/coarray_47.f90 b/Fortran/gfortran/regression/coarray_47.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_47.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! Contributed by G Steinmetz +! +program p + type t + integer, allocatable :: t + end type + type(t) :: x + print *, transfer(1, x) ! { dg-error "cannot have ALLOCATABLE components" } +end diff --git a/Fortran/gfortran/regression/coarray_48.f90 b/Fortran/gfortran/regression/coarray_48.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_48.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } +! +! Fix for P99818 in which wrong code caused an ICE. +! +! Contributed by Gerhard Steinmetz +! +module m + type t + integer :: a + contains + procedure :: s + end type +contains + subroutine s(x) + class(t) :: x[*] + end +end +program p + use m + associate (y => t(1)) + call y%s ! { dg-error "must be a coarray" } + end associate +end diff --git a/Fortran/gfortran/regression/coarray_49.f90 b/Fortran/gfortran/regression/coarray_49.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_49.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } +! PR fortran/101565 - ICE in gfc_simplify_image_index +! Contributed by G. Steinmetz + +program p + integer :: x[*] + print *, image_index (x, [1.0]) ! { dg-error "shall be INTEGER" } +end diff --git a/Fortran/gfortran/regression/coarray_5.f90 b/Fortran/gfortran/regression/coarray_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_5.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! Coarray support -- corank declarations +! PR fortran/18918 +! + +integer :: a, b[*] ! { dg-error "Fortran 2008: Coarray declaration" } +codimension :: a[*] ! { dg-error "Fortran 2008: Coarray declaration" } +end diff --git a/Fortran/gfortran/regression/coarray_50.f90 b/Fortran/gfortran/regression/coarray_50.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_50.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/105526 - check TEAM arguments to coarray intrinsics + +subroutine p + use iso_fortran_env, only: team_type + implicit none + type(team_type) :: team + type t + integer :: i + end type t + type(t) :: z + form team (0, team) + form team (0, 0) ! { dg-error "scalar expression of type TEAM_TYPE" } + form team (0, [team]) ! { dg-error "scalar expression of type TEAM_TYPE" } + form team ([0], team) ! { dg-error "scalar INTEGER" } + form team (0., team) ! { dg-error "scalar INTEGER" } + change team (0) ! { dg-error "scalar expression of type TEAM_TYPE" } + end team + sync team (0) ! { dg-error "scalar expression of type TEAM_TYPE" } +end diff --git a/Fortran/gfortran/regression/coarray_6.f90 b/Fortran/gfortran/regression/coarray_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_6.f90 @@ -0,0 +1,83 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! Coarray support -- corank declarations +! PR fortran/18918 +! +module m2 + use iso_c_binding + integer(c_int), bind(C) :: a[*] ! { dg-error "BIND.C. attribute conflicts with CODIMENSION" } + + type, bind(C) :: t ! { dg-error "cannot have the ALLOCATABLE" } + integer(c_int), allocatable :: a[:] ! { dg-error "cannot have the ALLOCATABLE" } + integer(c_int) :: b[*] ! { dg-error "must be allocatable" } + end type t +end module m2 + +subroutine bind(a) bind(C) ! { dg-error "Coarray dummy variable" } + use iso_c_binding + integer(c_int) :: a[*] +end subroutine bind + +subroutine allo(x) ! { dg-error "can thus not be an allocatable coarray" } + integer, allocatable, intent(out) :: x[:] +end subroutine allo + +module m + integer :: modvar[*] ! OK, implicit save + type t + complex, allocatable :: b(:,:,:,:)[:,:,:] + end type t +end module m + +subroutine bar() + integer, parameter :: a[*] = 4 ! { dg-error "PARAMETER attribute conflicts with CODIMENSION" } + integer :: b[*] ! { dg-error "is not ALLOCATABLE, SAVE nor a dummy" } +end subroutine bar + +subroutine vol() + integer,save :: a[*] + block + volatile :: a ! { dg-error "Specifying VOLATILE for coarray" } + end block +contains + subroutine int() + volatile :: a ! { dg-error "Specifying VOLATILE for coarray" } + end subroutine int +end subroutine vol + + +function func() result(func2) ! { dg-error "shall not be a coarray or have a coarray component" } + use m + type(t) :: func2 +end function func + +subroutine invalid() + type t + integer, allocatable :: a[:] + end type t + type t2 + type(t), allocatable :: b ! { dg-error "nonpointer, nonallocatable scalar" } + end type t2 + type t3 + type(t), pointer :: c ! { dg-error "nonpointer, nonallocatable scalar" } + end type t3 + type t4 + type(t) :: d(4) ! { dg-error "nonpointer, nonallocatable scalar" } + end type t4 +end subroutine invalid + +subroutine valid(a) + integer :: a(:)[4,-1:6,4:*] + type t + integer, allocatable :: a[:] + end type t + type t2 + type(t) :: b + end type t2 + type(t2), save :: xt2[*] ! { dg-error "nonpointer, nonallocatable scalar, which is not a coarray" } +end subroutine valid + +program main + integer :: A[*] ! Valid, implicit SAVE attribute +end program main diff --git a/Fortran/gfortran/regression/coarray_7.f90 b/Fortran/gfortran/regression/coarray_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_7.f90 @@ -0,0 +1,175 @@ +! { dg-do compile } +! { dg-options "-fmax-errors=1000 -fcoarray=single" } +! +! PR fortran/18918 +! +! Coarray expressions. +! +program test + implicit none + type t3 + integer, allocatable :: a + end type t3 + type t4 + type(t3) :: xt3 + end type t4 + type t + integer, pointer :: ptr + integer, allocatable :: alloc(:) + end type t + type(t), target :: i[*] + type(t), allocatable :: ca[:] + type(t4), target :: tt4[*] + type(t4), allocatable :: ca2[:] + integer, volatile :: volat[*] + integer, asynchronous :: async[*] + integer :: caf1[1,*], caf2[*] + allocate(i%ptr) + call foo(i%ptr) + call foo(i[1]%ptr) ! { dg-error "Coindexed actual argument at .1. to pointer dummy" } + call bar(i%ptr) + call bar(i[1]%ptr) ! OK, value of ptr target + call bar(i[1]%alloc(1)) ! OK + call typeDummy(i) ! OK + call typeDummy(i[1]) ! { dg-error "with ultimate pointer component" } + call typeDummy2(ca) ! OK + call typeDummy2(ca[1]) ! { dg-error "with ultimate pointer component" } + call typeDummy3(tt4%xt3) ! OK + call typeDummy3(tt4[1]%xt3) ! { dg-error "requires either VALUE or INTENT.IN." } + call typeDummy4(ca2) ! OK + call typeDummy4(ca2[1]) ! { dg-error "requires INTENT.IN." } +! Note: Checking an VOLATILE dummy is not possible as volatile + intent(in) +! is not possible + + call asyn(volat) + call asyn(async) + call asyn(volat[1]) ! { dg-error "Coindexed ASYNCHRONOUS or VOLATILE actual argument" } + call asyn(async[1]) ! { dg-error "Coindexed ASYNCHRONOUS or VOLATILE actual argument" } + + call coarray(caf1) ! rank mismatch; OK, for non allocatable coarrays + call coarray(caf2) + call coarray(caf2[1]) ! { dg-error "must be a coarray" } + call ups(i) + call ups1(i[1]) ! { dg-error "with ultimate pointer component" } + call ups2(i%ptr) + call ups3(i[1]%ptr) ! OK - passes target not pointer +contains + subroutine asyn(a) + integer, intent(in), asynchronous :: a + end subroutine asyn + subroutine bar(a) + integer :: a + end subroutine bar + subroutine foo(a) + integer, pointer :: a + end subroutine foo + subroutine coarray(a) + integer :: a[*] + end subroutine coarray + subroutine typeDummy(a) + type(t) :: a + end subroutine typeDummy + subroutine typeDummy2(a) + type(t),allocatable :: a + end subroutine typeDummy2 + subroutine typeDummy3(a) + type(t3) :: a + end subroutine typeDummy3 + subroutine typeDummy4(a) + type(t4), allocatable :: a + end subroutine typeDummy4 +end program test + + +subroutine alloc() +type t + integer, allocatable :: a(:) +end type t +type(t), save :: a[*] +type(t), allocatable :: b(:)[:], C[:] + +allocate(b(1)) ! { dg-error "Coarray specification" } +allocate(a[3]%a(5)) ! { dg-error "Coindexed allocatable" } +allocate(c[*]) ! OK +allocate(a%a(5)) ! OK +end subroutine alloc + + +subroutine dataPtr() + integer, save, target :: a[*] + data a/5/ ! OK + data a[1]/5/ ! { dg-error "cannot have a coindex" } + type t + integer, pointer :: p + end type t + type(t), save :: x[*] + + type t2 + integer :: a(1) + end type t2 + type(t2) y + data y%a/4/ + + + x[1]%p => a ! { dg-error "shall not have a coindex" } + x%p => a[1] ! { dg-error "shall not have a coindex" } +end subroutine dataPtr + + +subroutine test3() +implicit none +type t + integer :: a(1) +end type t +type(t), save :: x[*] +data x%a/4/ + + integer, save :: y(1)[*] !(1) + call sub(x(1:1)[1]) ! { dg-error "Rank mismatch" } +contains + subroutine sub(a) ! { dg-error "shall not have codimensions with deferred shape" } + integer :: a(:)[:] + end subroutine sub +end subroutine test3 + + +subroutine test4() + integer, save :: i[*] + integer :: j + call foo(i) + call foo(j) ! { dg-error "must be a coarray" } +contains + subroutine foo(a) + integer :: a[*] + end subroutine foo +end subroutine test4 + + +subroutine allocateTest() + implicit none + real, allocatable, codimension[:,:] :: a,b,c + integer :: n, q + n = 1 + q = 1 + allocate(a[q,*]) ! OK + allocate(b[q,*]) ! OK + allocate(c[q,*]) ! OK +end subroutine allocateTest + + +subroutine testAlloc4() + implicit none + type co_double_3 + double precision, allocatable :: array(:) + end type co_double_3 + type(co_double_3),save, codimension[*] :: work + allocate(work%array(1)) + print *, size(work%array) +end subroutine testAlloc4 + +subroutine test5() + implicit none + integer, save :: i[*] + print *, i[*] ! { dg-error "Coindex of codimension 1 must be a scalar" } +end subroutine test5 + diff --git a/Fortran/gfortran/regression/coarray_8.f90 b/Fortran/gfortran/regression/coarray_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_8.f90 @@ -0,0 +1,189 @@ +! { dg-do compile } +! { dg-options "-fmax-errors=1000 -fcoarray=single" } +! +! PR fortran/18918 +! +! Coarray expressions. +! +module mod2 + implicit none + type t + procedure(sub), pointer :: ppc + contains + procedure :: tbp => sub + end type t + type t2 + class(t), allocatable :: poly + end type t2 +contains + subroutine sub(this) + class(t), intent(in) :: this + end subroutine sub +end module mod2 + +subroutine procTest(y,z) + use mod2 + implicit none + type(t), save :: x[*] + type(t) :: y[*] + type(t2) :: z[*] + + x%ppc => sub + call x%ppc() ! OK + call x%tbp() ! OK + call x[1]%tbp ! OK, not polymorphic + ! Invalid per C726 + call x[1]%ppc ! { dg-error "Coindexed procedure-pointer component" } + + y%ppc => sub + call y%ppc() ! OK + call y%tbp() ! OK + call y[1]%tbp ! OK, coindexed polymorphic object but not poly. subobj. + call y[1]%ppc ! { dg-error "Coindexed procedure-pointer component" } + + ! Invalid per C1229 + z%poly%ppc => sub + call z%poly%ppc() ! OK + call z%poly%tbp() ! OK + call z[1]%poly%tbp ! { dg-error "Polymorphic subobject of coindexed" } + call z[1]%poly%ppc ! { dg-error "Coindexed procedure-pointer component" } +end subroutine procTest + + +module m + type t1 + integer, pointer :: p + end type t1 + type t2 + integer :: i + end type t2 + type t + integer, allocatable :: a[:] + type(t1), allocatable :: b[:] + type(t2), allocatable :: c[:] + end type t +contains + pure subroutine p2(x) + integer, intent(inout) :: x + end subroutine p2 + pure subroutine p3(x) + integer, pointer :: x + end subroutine p3 + pure subroutine p1(x) + type(t), intent(inout) :: x + integer, target :: tgt1 + x%a = 5 + x%a[6] = 9 ! { dg-error "Assignment to coindexed variable" } + x%b%p => tgt1 + x%b[1]%p => tgt1 ! { dg-error "shall not have a coindex" } + x%b%p => x%b[1]%p ! { dg-error "shall not have a coindex" } + x%b = t1(x%b[1]%p) ! { dg-error "Coindexed expression to pointer component" } + x%b = x%b[1] ! { dg-error "derived type variable with a POINTER component in a PURE" } + call p2 (x%c[1]%i) ! { dg-error "Coindexed actual argument" } + call p3 (x%b[1]%p) ! { dg-error "to pointer dummy" } + end subroutine p1 + subroutine nonPtr() + type(t1), save :: a[*] + type(t2), save :: b[*] + integer, target :: tgt1 + a%p => tgt1 + a[1]%p => tgt1 ! { dg-error "shall not have a coindex" } + a%p => a[2]%p ! { dg-error "shall not have a coindex" } + a = t1(a[1]%p) ! { dg-error "Coindexed expression to pointer component" } + call p2 (b[1]%i) ! OK + call p2 (a[1]%p) ! OK - pointer target and not pointer + end subroutine nonPtr +end module m + + +module mmm3 + type t + integer, allocatable :: a(:) + end type t +contains + subroutine assign(x) + type(t) :: x[*] + allocate(x%a(3)) + x%a = [ 1, 2, 3] + x[1]%a = [ 1, 2, 3] ! OK - if shapes are the same, otherwise wrong + ! (no reallocate on assignment) + end subroutine assign + subroutine assign2(x,y) + type(t),allocatable :: x[:] + type(t) :: y + x = y + x[1] = y ! { dg-error "must not have an allocatable ultimate component" } + end subroutine assign2 +end module mmm3 + + +module mmm4 + implicit none +contains + subroutine t1(x) + integer :: x(1) + end subroutine t1 + subroutine t3(x) + character :: x(*) + end subroutine t3 + subroutine t2() + integer, save :: x[*] + integer, save :: y(1)[*] + character(len=20), save :: z[*] + + call t1(x) ! { dg-error "Rank mismatch" } + call t1(x[1]) ! { dg-error "Rank mismatch" } + + call t1(y(1)) ! OK + call t1(y(1)[1]) ! { dg-error "Rank mismatch" } + + call t3(z) ! OK + call t3(z[1]) ! { dg-error "Rank mismatch" } + end subroutine t2 +end module mmm4 + + +subroutine tfgh() + integer :: i(2) + DATA i/(i, i=1,2)/ ! { dg-error "Syntax error in DATA" } + do i = 1, 5 ! { dg-error "cannot be an array" } + end do ! { dg-error "Expecting END SUBROUTINE" } +end subroutine tfgh + +subroutine tfgh2() + integer, save :: x[*] + integer :: i(2) + DATA i/(x, x=1,2)/ ! { dg-error "Syntax error in DATA" } + do x = 1, 5 ! { dg-error "cannot be a coarray" } + end do ! { dg-error "Expecting END SUBROUTINE" } +end subroutine tfgh2 + + +subroutine f4f4() + type t + procedure(), pointer, nopass :: ppt => null() + end type t + external foo + type(t), save :: x[*] + x%ppt => foo + x[1]%ppt => foo ! { dg-error "shall not have a coindex" } +end subroutine f4f4 + + +subroutine corank() + integer, allocatable :: a[:,:] + call one(a) ! OK + call two(a) ! { dg-error "Corank mismatch in argument" } +contains + subroutine one(x) + integer :: x[*] + end subroutine one + subroutine two(x) + integer, allocatable :: x[:] + end subroutine two +end subroutine corank + +subroutine assign42() + integer, allocatable :: z(:)[:] + z(:)[1] = z +end subroutine assign42 diff --git a/Fortran/gfortran/regression/coarray_9.f90 b/Fortran/gfortran/regression/coarray_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_9.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! PR fortran/18918 +! +! Check for error if no -fcoarray= option has been given +! + +integer :: a +integer :: b[*] ! { dg-error "Coarrays disabled" } + +error stop "Error" +sync all ! "Coarrays disabled" (but error above is fatal) + +critical ! "Coarrays disabled" (but error above is fatal) + +end critical ! "Expecting END PROGRAM statement" (but error above is fatal) + +end +! { dg-prune-output "compilation terminated" } diff --git a/Fortran/gfortran/regression/coarray_alloc_comp_1.f08 b/Fortran/gfortran/regression/coarray_alloc_comp_1.f08 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_alloc_comp_1.f08 @@ -0,0 +1,96 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -lcaf_single" } +! { dg-additional-options "-latomic" { target libatomic_available } } + +! Contributed by Damian Rouson +! Check the new _caf_get_by_ref()-routine. + +program main + +implicit none + +type :: mytype + integer :: i + integer, allocatable :: indices(:) + real, dimension(2,5,3) :: volume + integer, allocatable :: scalar + integer :: j + integer, allocatable :: matrix(:,:) + real, allocatable :: dynvol(:,:,:) +end type + +type arrtype + type(mytype), allocatable :: vec(:) + type(mytype), allocatable :: mat(:,:) +end type arrtype + +type(mytype), save :: object[*] +type(arrtype), save :: bar[*] +integer :: i,j,me,neighbor +integer :: idx(5) +real, allocatable :: volume(:,:,:), vol2(:,:,:) +real :: vol_static(2,5,3) + +idx = (/ 1,2,1,7,5 /) + +me=this_image() +object%indices=[(i,i=1,5)] +allocate(object%scalar, object%matrix(10,7)) +object%i = 37 +object%scalar = 42 +vol_static = reshape([(i, i=1, 2*5*3)], [2, 5, 3]) +object%volume = vol_static +object%matrix = reshape([(i, i=1, 70)], [10, 7]) +object%dynvol = vol_static +sync all +neighbor = merge(1,neighbor,me==num_images()) +if (object[neighbor]%scalar /= 42) STOP 1 +if (object[neighbor]%indices(4) /= 4) STOP 2 +if (object[neighbor]%matrix(3,6) /= 53) STOP 3 +if (any( object[neighbor]%indices(:) /= [1,2,3,4,5] )) STOP 4 +if (any( object[neighbor]%matrix(:,:) /= reshape([(i, i=1, 70)], [10, 7]))) STOP 5 +if (any( object[neighbor]%matrix(3,:) /= [(i * 10 + 3, i=0, 6)])) STOP 6 +if (any( object[neighbor]%matrix(:,2) /= [(i + 10, i=1, 10)])) STOP 7 +if (any( object[neighbor]%matrix(idx,2) /= [11, 12, 11, 17, 15])) STOP 8 +if (any( object[neighbor]%matrix(3,idx) /= [3, 13, 3, 63, 43])) STOP 9 +if (any( object[neighbor]%matrix(2:8:4, 5:1:-1) /= reshape([42, 46, 32, 36, 22, 26, 12, 16, 2, 6], [2,5]))) STOP 10 +if (any( object[neighbor]%matrix(:8:4, 2::2) /= reshape([11, 15, 31, 35, 51, 55], [2,3]))) STOP 11 +if (any( object[neighbor]%volume /= vol_static)) STOP 12 +if (any( object[neighbor]%dynvol /= vol_static)) STOP 13 +if (any( object[neighbor]%volume(:, 2:4, :) /= vol_static(:, 2:4, :))) STOP 14 +if (any( object[neighbor]%dynvol(:, 2:4, :) /= vol_static(:, 2:4, :))) STOP 15 + +vol2 = vol_static(:, ::2, :) +if (any( object[neighbor]%volume(:, ::2, :) /= vol2)) STOP 16 +if (any( object[neighbor]%dynvol(:, ::2, :) /= vol2)) STOP 17 + +allocate(bar%vec(-2:2)) + +bar%vec(1)%volume = vol_static +if (any(bar[neighbor]%vec(1)%volume /= vol_static)) STOP 18 + +i = 15 +bar%vec(1)%scalar = i +if (.not. allocated(bar%vec(1)%scalar)) STOP 19 +if (bar[neighbor]%vec(1)%scalar /= 15) STOP 20 + +bar%vec(0)%scalar = 27 +if (.not. allocated(bar%vec(0)%scalar)) STOP 21 +if (bar[neighbor]%vec(0)%scalar /= 27) STOP 22 + +bar%vec(1)%indices = [ 3, 4, 15 ] +allocate(bar%vec(2)%indices(5)) +bar%vec(2)%indices = 89 + +if (.not. allocated(bar%vec(1)%indices)) STOP 23 +if (allocated(bar%vec(-2)%indices)) STOP 24 +if (allocated(bar%vec(-1)%indices)) STOP 25 +if (allocated(bar%vec( 0)%indices)) STOP 26 +if (.not. allocated(bar%vec( 2)%indices)) STOP 27 +if (any(bar[me]%vec(2)%indices /= 89)) STOP 28 + +if (any (bar[neighbor]%vec(1)%indices /= [ 3,4,15])) STOP 29 + +deallocate(bar%vec(2)%indices, object%scalar, object%matrix) +deallocate(bar%vec) +end program diff --git a/Fortran/gfortran/regression/coarray_alloc_comp_2.f08 b/Fortran/gfortran/regression/coarray_alloc_comp_2.f08 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_alloc_comp_2.f08 @@ -0,0 +1,85 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -lcaf_single" } +! { dg-additional-options "-latomic" { target libatomic_available } } + +! Contributed by Damian Rouson +! Check the new _caf_send_by_ref()-routine. + +program main + +implicit none + +type :: mytype + integer :: i + integer, allocatable :: indices(:) + real, dimension(2,5,3) :: volume + integer, allocatable :: scalar + integer :: j + integer, allocatable :: matrix(:,:) + real, allocatable :: dynvol(:,:,:) +end type + +type arrtype + type(mytype), allocatable :: vec(:) + type(mytype), allocatable :: mat(:,:) +end type arrtype + +type(mytype), save :: object[*] +type(arrtype), save :: bar[*] +integer :: i,j,me,neighbor +integer :: idx(5) +real, allocatable :: volume(:,:,:), vol2(:,:,:) +real :: vol_static(2,5,3) + +idx = (/ 1,2,1,7,5 /) + +me=this_image() +neighbor = merge(1,me+1,me==num_images()) +object[neighbor]%indices=[(i,i=1,5)] +object[neighbor]%i = 37 +object[neighbor]%scalar = 42 +vol_static = reshape([(i, i=1, 2*5*3)], [2, 5, 3]) +object[neighbor]%volume = vol_static +object[neighbor]%matrix = reshape([(i, i=1, 70)], [10, 7]) +object[neighbor]%dynvol = vol_static +sync all +if (object%scalar /= 42) STOP 1 +if (any( object%indices /= [1,2,3,4,5] )) STOP 2 +if (any( object%matrix /= reshape([(i, i=1, 70)], [10, 7]))) STOP 3 +if (any( object%volume /= vol_static)) STOP 4 +if (any( object%dynvol /= vol_static)) STOP 5 + +vol2 = vol_static +vol2(:, ::2, :) = 42 +object[neighbor]%volume(:, ::2, :) = 42 +object[neighbor]%dynvol(:, ::2, :) = 42 +if (any( object%volume /= vol2)) STOP 6 +if (any( object%dynvol /= vol2)) STOP 7 + +allocate(bar%vec(-2:2)) + +bar[neighbor]%vec(1)%volume = vol_static +if (any(bar%vec(1)%volume /= vol_static)) STOP 8 + +i = 15 +bar[neighbor]%vec(1)%scalar = i +if (.not. allocated(bar%vec(1)%scalar)) STOP 9 +if (bar%vec(1)%scalar /= 15) STOP 10 + +bar[neighbor]%vec(0)%scalar = 27 +if (.not. allocated(bar%vec(0)%scalar)) STOP 11 +if (bar%vec(0)%scalar /= 27) STOP 12 + +bar[neighbor]%vec(1)%indices = [ 3, 4, 15 ] +allocate(bar%vec(2)%indices(5)) +bar[neighbor]%vec(2)%indices = 89 + +if (.not. allocated(bar%vec(1)%indices)) STOP 13 +if (allocated(bar%vec(-2)%indices)) STOP 14 +if (allocated(bar%vec(-1)%indices)) STOP 15 +if (allocated(bar%vec( 0)%indices)) STOP 16 +if (.not. allocated(bar%vec( 2)%indices)) STOP 17 +if (any(bar%vec(2)%indices /= 89)) STOP 18 + +if (any (bar%vec(1)%indices /= [ 3,4,15])) STOP 19 +end program diff --git a/Fortran/gfortran/regression/coarray_alloc_comp_3.f08 b/Fortran/gfortran/regression/coarray_alloc_comp_3.f08 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_alloc_comp_3.f08 @@ -0,0 +1,52 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -lcaf_single" } +! { dg-additional-options "-latomic" { target libatomic_available } } +! +! Contributed by Andre Vehreschild +! Check that manually freeing components does not lead to a runtime crash, +! when the auto-deallocation is taking care. + +program coarray_alloc_comp_3 + implicit none + + type dt + integer, allocatable :: i + end type dt + + type linktype + type(dt), allocatable :: link + end type linktype + + type(linktype), allocatable :: obj[:] + + allocate(obj[*]) + allocate(obj%link) + + if (.not. allocated(obj)) error stop "Test failed. 'obj' not allocated." + if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' not allocated." + if (allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' already allocated." + + allocate(obj%link%i, source = 42) + + if (.not. allocated(obj)) error stop "Test failed. 'obj' not allocated." + if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' not allocated." + if (.not. allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' not allocated." + if (obj%link%i /= 42) error stop "Test failed. obj%link%i /= 42." + + deallocate(obj%link%i) + + if (allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' still allocated." + if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' no longer allocated." + if (.not. allocated(obj)) error stop "Test failed. 'obj' no longer allocated." + + ! Freeing this object, lead to crash with older gfortran... + deallocate(obj%link) + + if (allocated(obj%link)) error stop "Test failed. 'obj%link' still allocated." + if (.not. allocated(obj)) error stop "Test failed. 'obj' no longer allocated." + + ! ... when auto-deallocating the allocated components. + deallocate(obj) + + if (allocated(obj)) error stop "Test failed. 'obj' still allocated." +end program diff --git a/Fortran/gfortran/regression/coarray_alloc_comp_4.f08 b/Fortran/gfortran/regression/coarray_alloc_comp_4.f08 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_alloc_comp_4.f08 @@ -0,0 +1,45 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -fdump-tree-original" } +! { dg-additional-options "-latomic" { target libatomic_available } } +! +! Contributed by Andre Vehreschild +! Check that sub-components are caf_deregistered and not freed. + +program coarray_alloc_comp_3 + implicit none + + type dt + integer, allocatable :: i + end type dt + + type linktype + type(dt), allocatable :: link + end type linktype + + type(linktype) :: obj[*] + + allocate(obj%link) + + if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' not allocated." + if (allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' already allocated." + + allocate(obj%link%i, source = 42) + + if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' not allocated." + if (.not. allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' not allocated." + if (obj%link%i /= 42) error stop "Test failed. obj%link%i /= 42." + + deallocate(obj%link%i) + + if (allocated(obj%link%i)) error stop "Test failed. 'obj%link%i' still allocated." + if (.not. allocated(obj%link)) error stop "Test failed. 'obj%link' no longer allocated." + + ! Freeing this object, lead to crash with older gfortran... + deallocate(obj%link) + + if (allocated(obj%link)) error stop "Test failed. 'obj%link' still allocated." +end program +! Ensure, that three calls to deregister are present. +! { dg-final { scan-tree-dump-times "_caf_deregister" 3 "original" } } +! And ensure that no calls to builtin_free are made. +! { dg-final { scan-tree-dump-not "_builtin_free" "original" } } diff --git a/Fortran/gfortran/regression/coarray_alloc_comp_6.f08 b/Fortran/gfortran/regression/coarray_alloc_comp_6.f08 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_alloc_comp_6.f08 @@ -0,0 +1,55 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -lcaf_single" } +! { dg-additional-options "-latomic" { target libatomic_available } } + +! Check that type conversion during caf_get_by_ref is done for components. + +program main + + implicit none + + type :: mytype + integer :: i + integer :: i4 + integer(kind=1) :: i1 + real :: r8 + real(kind=4) :: r4 + integer :: arr_i4(4) + integer(kind=1) :: arr_i1(4) + real :: arr_r8(4) + real(kind=4) :: arr_r4(4) + end type + + type T + type(mytype), allocatable :: obj + end type T + + type(T), save :: bar[*] + integer :: i4, arr_i4(4) + integer(kind=1) :: i1, arr_i1(4) + real :: r8, arr_r8(4) + real(kind=4) :: r4, arr_r4(4) + + bar%obj = mytype(42, 4, INT(1, 1), 8.0, REAL(4.0, 4), (/ 1,2,3,4 /), & + & INT((/ 5,6,7,8 /), 1), (/ 1.2,3.4,5.6,7.8 /), REAL( & + & (/ 8.7,6.5,4.3,2.1 /), 4)) + + i1 = bar[1]%obj%r4 + if (i1 /= 4) stop 1 + i4 = bar[1]%obj%r8 + if (i4 /= 8) stop 2 + r4 = bar[1]%obj%i1 + if (abs(r4 - 1.0) > 1E-4) stop 3 + r8 = bar[1]%obj%i4 + if (abs(r8 - 4.0) > 1E-6) stop 4 + + arr_i1 = bar[1]%obj%arr_r4 + if (any(arr_i1 /= INT((/ 8,6,4,2 /), 1))) stop 5 + arr_i4 = bar[1]%obj%arr_r8 + if (any(arr_i4 /= (/ 1,3,5,7 /))) stop 6 + arr_r4 = bar[1]%obj%arr_i1 + if (any(abs(arr_r4 - REAL((/ 5,6,7,8 /), 4)) > 1E-4)) stop 7 + arr_r8 = bar[1]%obj%arr_i4 + if (any(abs(arr_r8 - (/ 1,2,3,4 /)) > 1E-6)) stop 8 +end program + diff --git a/Fortran/gfortran/regression/coarray_alloc_comp_7.f08 b/Fortran/gfortran/regression/coarray_alloc_comp_7.f08 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_alloc_comp_7.f08 @@ -0,0 +1,62 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -lcaf_single" } +! { dg-additional-options "-latomic" { target libatomic_available } } + +! Check that type conversion during caf_send_by_ref is done for components. + +program main + + implicit none + + type :: mytype + integer :: i + integer :: i4 + integer(kind=1) :: i1 + real :: r8 + real(kind=4) :: r4 + integer :: arr_i4(4) + integer(kind=1) :: arr_i1(4) + real :: arr_r8(4) + real(kind=4) :: arr_r4(4) + end type + + type T + type(mytype), allocatable :: obj + end type T + + type(T), save :: bar[*] + integer :: i4, arr_i4(4) + integer(kind=1) :: i1, arr_i1(4) + real :: r8, arr_r8(4) + real(kind=4) :: r4, arr_r4(4) + + allocate(bar%obj) + i1 = INT(1, 1) + i4 = 4 + r4 = REAL(4.0, 4) + r8 = 8.0 + arr_i1 = INT((/ 5,6,7,8 /), 1) + arr_i4 = (/ 1,2,3,4 /) + arr_r8 = (/ 1.2,3.4,5.6,7.8 /) + arr_r4 = REAL((/ 8.7,6.5,4.3,2.1 /), 4) + + bar[1]%obj%r4 = i1 + if (abs(bar%obj%r4 - 1.0) > 1E-4) stop 1 + bar[1]%obj%r8 = i4 + if (abs(bar%obj%r8 - 4.0) > 1E-6) stop 2 + bar[1]%obj%i1 = r4 + if (bar%obj%i1 /= 4) stop 3 + bar[1]%obj%i4 = r8 + if (bar%obj%i4 /= 8) stop 4 + + bar[1]%obj%arr_r4 = arr_i1 + print *, bar%obj%arr_r4 + if (any(abs(bar%obj%arr_r4 - REAL((/ 5,6,7,8 /), 4)) > 1E-4)) stop 5 + bar[1]%obj%arr_r8 = arr_i4 + if (any(abs(bar%obj%arr_r8 - (/ 1,2,3,4 /)) > 1E-6)) stop 6 + bar[1]%obj%arr_i1 = arr_r4 + if (any(bar%obj%arr_i1 /= INT((/ 8,6,4,2 /), 1))) stop 7 + bar[1]%obj%arr_i4 = arr_r8 + if (any(bar%obj%arr_i4 /= (/ 1,3,5,7 /))) stop 8 +end program + diff --git a/Fortran/gfortran/regression/coarray_alloc_comp_8.f08 b/Fortran/gfortran/regression/coarray_alloc_comp_8.f08 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_alloc_comp_8.f08 @@ -0,0 +1,59 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -lcaf_single" } +! { dg-additional-options "-latomic" { target libatomic_available } } + +! Check that type conversion during caf_sendget_by_ref is done for components. + +program main + + implicit none + + type :: mytype + integer :: i + integer :: i4 + integer(kind=1) :: i1 + real :: r8 + real(kind=4) :: r4 + integer :: arr_i4(4) + integer(kind=1) :: arr_i1(4) + real :: arr_r8(4) + real(kind=4) :: arr_r4(4) + end type + + type T + type(mytype), allocatable :: obj + end type T + + type(T), save :: bar[*] + integer :: i4, arr_i4(4) + integer(kind=1) :: i1, arr_i1(4) + real :: r8, arr_r8(4) + real(kind=4) :: r4, arr_r4(4) + + bar%obj = mytype(42, 4, INT(1, 1), 8.0, REAL(4.0, 4), (/ 1,2,3,4 /), & + & INT((/ 5,6,7,8 /), 1), (/ 1.2,3.4,5.6,7.8 /), REAL( & + & (/ 8.7,6.5,4.3,2.1 /), 4)) + + bar[1]%obj%i1 = bar[1]%obj%r4 + if (bar%obj%i1 /= 4) stop 1 + bar[1]%obj%i4 = bar[1]%obj%r8 + if (bar%obj%i4 /= 8) stop 2 + bar[1]%obj%arr_i1 = bar[1]%obj%arr_r4 + if (any(bar%obj%arr_i1 /= (/ 8,6,4,2 /))) stop 3 + bar[1]%obj%arr_i4 = bar[1]%obj%arr_r8 + if (any(bar%obj%arr_i4 /= (/ 1,3,5,7 /))) stop 4 + + bar%obj%i1 = INT(1, 1) + bar%obj%i4 = 4 + bar%obj%arr_i1 = INT((/ 5,6,7,8 /), 1) + bar%obj%arr_i4 = (/ 1,2,3,4 /) + bar[1]%obj%r4 = bar[1]%obj%i1 + if (abs(bar%obj%r4 - 1.0) > 1E-4) stop 5 + bar[1]%obj%r8 = bar[1]%obj%i4 + if (abs(bar%obj%r8 - 4.0) > 1E-6) stop 6 + bar[1]%obj%arr_r4 = bar[1]%obj%arr_i1 + if (any(abs(bar%obj%arr_r4 - REAL((/ 5,6,7,8 /), 4)) > 1E-4)) stop 7 + bar[1]%obj%arr_r8 = bar[1]%obj%arr_i4 + if (any(abs(bar%obj%arr_r8 - (/ 1,2,3,4 /)) > 1E-6)) stop 8 +end program + diff --git a/Fortran/gfortran/regression/coarray_alloc_with_implicit_sync_1.f90 b/Fortran/gfortran/regression/coarray_alloc_with_implicit_sync_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_alloc_with_implicit_sync_1.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -fcoarray=lib" } +! Check that allocating a coarray adds an implicit sync all. + + implicit none + integer, allocatable :: f(:)[:] + allocate( f(20)[*], source = 1 ) +end + +! { dg-final { scan-tree-dump-times "_gfortran_caf_sync_all \\(" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_alloc_with_implicit_sync_2.f90 b/Fortran/gfortran/regression/coarray_alloc_with_implicit_sync_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_alloc_with_implicit_sync_2.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -fdump-tree-original" } +! +! Test that the compiler generates sync_all statements only at the required +! locations. This program is not supposed to run (allocating already alloced). + +program test_alloc_sync + + type :: T + integer, allocatable :: i + end type T + type :: T2 + type(T), allocatable :: o[:] + end type T2 + + integer, allocatable :: caf[:] + type (T) :: obj[*] + type (T2) :: cafcomp + + allocate(caf[*]) ! implicit sync_all + allocate(obj%i) ! asynchronous + allocate(cafcomp%o[*]) ! sync + allocate(cafcomp%o%i) ! async + + allocate(obj%i, cafcomp%o%i) ! async + allocate(caf[*], obj%i, cafcomp%o%i) ! sync + +end program test_alloc_sync + +! { dg-final { scan-tree-dump-times "caf_sync_all" 3 "original" } } diff --git a/Fortran/gfortran/regression/coarray_allocate_1.f90 b/Fortran/gfortran/regression/coarray_allocate_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_allocate_1.f90 @@ -0,0 +1,95 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! PR 53824 - this used to ICE. +! Original test case by Vladimír Fuka +program Jac + implicit none + + integer,parameter:: KND=KIND(1.0) + + type Domain + real(KND),dimension(:,:,:),allocatable:: A,B + integer :: n=64,niter=20000,blockit=1000 + integer :: starti,endi + integer :: startj,endj + integer :: startk,endk + integer,dimension(:),allocatable :: startsi,startsj,startsk + integer,dimension(:),allocatable :: endsi,endsj,endsk + end type + + type(Domain),allocatable :: D[:,:,:] +! real(KND),codimension[*] :: sumA,sumB,diffAB + integer i,j,k,ncom + integer nims,nxims,nyims,nzims + integer im,iim,jim,kim + character(20):: ch + + nims = num_images() + nxims = nint(nims**(1./3.)) + nyims = nint(nims**(1./3.)) + nzims = nims / (nxims*nyims) + + im = this_image() + if (im==1) write(*,*) "n: [",nxims,nyims,nzims,"]" + + kim = (im-1) / (nxims*nyims) + 1 + jim = ((im-1) - (kim-1)*(nxims*nyims)) / nxims + 1 + iim = (im-1) - (kim-1)*(nxims*nyims) - (jim-1)*(nxims) + 1 + + write (*,*) im,"[",iim,jim,kim,"]" + + allocate(D[nxims,nyims,*]) + + ncom=command_argument_count() + if (command_argument_count() >=2) then + call get_command_argument(1,value=ch) + read (ch,*) D%n + call get_command_argument(2,value=ch) + read (ch,*) D%niter + call get_command_argument(3,value=ch) + read (ch,*) D%blockit + end if + + allocate(D%startsi(nxims)) + allocate(D%startsj(nyims)) + allocate(D%startsk(nzims)) + allocate(D%endsi(nxims)) + allocate(D%endsj(nyims)) + allocate(D%endsk(nzims)) + + D%startsi(1) = 1 + do i=2,nxims + D%startsi(i) = D%startsi(i-1) + D%n/nxims + end do + D%endsi(nxims) = D%n + D%endsi(1:nxims-1) = D%startsi(2:nxims) - 1 + + D%startsj(1) = 1 + do j=2,nyims + D%startsj(j) = D%startsj(j-1) + D%n/nyims + end do + D%endsj(nyims) = D%n + D%endsj(1:nyims-1) = D%startsj(2:nyims) - 1 + + D%startsk(1) = 1 + do k=2,nzims + D%startsk(k) = D%startsk(k-1) + D%n/nzims + end do + D%endsk(nzims) = D%n + D%endsk(1:nzims-1) = D%startsk(2:nzims) - 1 + + D%starti = D%startsi(iim) + D%endi = D%endsi(iim) + D%startj = D%startsj(jim) + D%endj = D%endsj(jim) + D%startk = D%startsk(kim) + D%endk = D%endsk(kim) + + write(*,*) D%startsi,D%endsi + write(*,*) D%startsj,D%endsj + write(*,*) D%startsk,D%endsk + + !$hmpp JacKernel allocate, args[A,B].size={0:D%n+1,0:D%n+1,0:D%n+1} + allocate(D%A(D%starti-1:D%endi+1,D%startj-1:D%endj+1,D%startk-1:D%endk+1),& + D%B(D%starti-1:D%endi+1,D%startj-1:D%endj+1,D%startk-1:D%endk+1)) +end program Jac diff --git a/Fortran/gfortran/regression/coarray_allocate_10.f08 b/Fortran/gfortran/regression/coarray_allocate_10.f08 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_allocate_10.f08 @@ -0,0 +1,40 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -lcaf_single" } +! { dg-additional-options "-latomic" { target libatomic_available } } + +program alloc_comp + implicit none + + type coords + integer,allocatable :: x(:) + end type + + type outerT + type(coords),allocatable :: coo[:] + end type + integer :: me,np,n,i + type(outerT) :: o + + ! with caf_single num_images is always == 1 + me = this_image(); np = num_images() + n = 100 + + allocate(o%coo[*]) + allocate(o%coo%x(n)) + + o%coo%x = me + + do i=1, n + o%coo%x(i) = o%coo%x(i) + i + end do + + sync all + + if(me == 1 .and. o%coo[np]%x(10) /= 11 ) STOP 1 + + ! Check the whole array is correct. + if (me == 1 .and. any( o%coo[np]%x /= [(i, i=2, 101)] ) ) STOP 2 + + deallocate(o%coo%x) + +end program diff --git a/Fortran/gfortran/regression/coarray_allocate_11.f90 b/Fortran/gfortran/regression/coarray_allocate_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_allocate_11.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-additional-options -fcoarray=single } +program p + integer, allocatable :: z[:,:] + integer :: i + allocate (z[1:,*]) ! { dg-error "Bad coarray specification in ALLOCATE statement" } + allocate (z[:2,*]) ! { dg-error "Bad coarray specification in ALLOCATE statement" } + allocate (z[2:1,*]) ! { dg-error "Upper cobound is less than lower cobound" } + allocate (z[:0,*]) ! { dg-error "Bad coarray specification in ALLOCATE statement" } + allocate (z[0,*]) ! { dg-error "Upper cobound is less than lower cobound" } + allocate (z[1,*]) ! This is OK + allocate (z[1:1,*]) ! This is OK + allocate (z[i:i,*]) ! This is OK + allocate (z[i:i-1,*]) ! { dg-error "Upper cobound is less than lower cobound" } +end diff --git a/Fortran/gfortran/regression/coarray_allocate_12.f90 b/Fortran/gfortran/regression/coarray_allocate_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_allocate_12.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/105184 +! Based on testcases by Gerhard Steinmetz + +program p + real, allocatable :: x[:,:] + integer :: n = 2 + allocate (x[ n, *]) + allocate (x[1:n, *]) + allocate (x[n:n, *]) + allocate (x[n, 5:*]) + allocate (x[ :n, *]) ! { dg-error "Bad coarray specification" } + allocate (x[::n, *]) ! { dg-error "Bad coarray specification" } + allocate (x[ :1:1, *]) ! { dg-error "Bad coarray specification" } + allocate (x[1:n:n, *]) ! { dg-error "Bad coarray specification" } + allocate (x[1, : *]) ! { dg-error "Missing lower bound" } +end diff --git a/Fortran/gfortran/regression/coarray_allocate_2.f08 b/Fortran/gfortran/regression/coarray_allocate_2.f08 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_allocate_2.f08 @@ -0,0 +1,26 @@ +! { dg-do run } +! { dg-options "-fcoarray=single" } +! +! Contributed by Ian Harvey +! Extended by Andre Vehreschild +! to test that coarray references in allocate work now +! PR fortran/67451 + + program main + implicit none + type foo + integer :: bar = 99 + end type + class(foo), allocatable :: foobar[:] + class(foo), allocatable :: some_local_object + allocate(foobar[*]) + + allocate(some_local_object, source=foobar) + + if (.not. allocated(foobar)) STOP 1 + if (.not. allocated(some_local_object)) STOP 2 + + deallocate(some_local_object) + deallocate(foobar) + end program + diff --git a/Fortran/gfortran/regression/coarray_allocate_3.f08 b/Fortran/gfortran/regression/coarray_allocate_3.f08 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_allocate_3.f08 @@ -0,0 +1,28 @@ +! { dg-do run } +! { dg-options "-fcoarray=single" } +! +! Contributed by Ian Harvey +! Extended by Andre Vehreschild +! to test that coarray references in allocate work now +! PR fortran/67451 + + program main + implicit none + type foo + integer :: bar = 99 + end type + class(foo), dimension(:), allocatable :: foobar[:] + class(foo), dimension(:), allocatable :: some_local_object + allocate(foobar(10)[*]) + + allocate(some_local_object, source=foobar) + + if (.not. allocated(foobar)) STOP 1 + if (lbound(foobar, 1) /= 1 .OR. ubound(foobar, 1) /= 10) STOP 2 + if (.not. allocated(some_local_object)) STOP 3 + if (any(some_local_object(:)%bar /= [99, 99, 99, 99, 99, 99, 99, 99, 99, 99])) STOP 4 + + deallocate(some_local_object) + deallocate(foobar) + end program + diff --git a/Fortran/gfortran/regression/coarray_allocate_4.f08 b/Fortran/gfortran/regression/coarray_allocate_4.f08 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_allocate_4.f08 @@ -0,0 +1,43 @@ +! { dg-do run } +! { dg-options "-fcoarray=single" } +! +! Contributed by Gerhard Steinmetz +! Andre Vehreschild +! Check that PR fortran/69451 is fixed. + +program main + +implicit none + +type foo +end type + +class(foo), allocatable :: p[:] +class(foo), pointer :: r +class(*), allocatable, target :: z + +allocate(p[*]) + +call s(p, z) +select type (z) + class is (foo) + r => z + class default + STOP 1 +end select + +if (.not. associated(r)) STOP 2 + +deallocate(r) +deallocate(p) + +contains + +subroutine s(x, z) + class(*) :: x[*] + class(*), allocatable:: z + allocate (z, source=x) +end + +end + diff --git a/Fortran/gfortran/regression/coarray_allocate_5.f08 b/Fortran/gfortran/regression/coarray_allocate_5.f08 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_allocate_5.f08 @@ -0,0 +1,33 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -lcaf_single -fdump-tree-original" } +! { dg-additional-options "-latomic" { target libatomic_available } } +! +! Contributed by Ian Harvey +! Extended by Andre Vehreschild +! to test that coarray references in allocate work now +! PR fortran/67451 + + program main + implicit none + type foo + integer :: bar = 99 + end type + class(foo), dimension(:), allocatable :: foobar[:] + class(foo), dimension(:), allocatable :: some_local_object + allocate(foobar(10)[*]) + + allocate(some_local_object, source=foobar) + + if (.not. allocated(foobar)) STOP 1 + if (lbound(foobar, 1) /= 1 .OR. ubound(foobar, 1) /= 10) STOP 2 + if (.not. allocated(some_local_object)) STOP 3 + if (any(some_local_object(:)%bar /= [99, 99, 99, 99, 99, 99, 99, 99, 99, 99])) STOP 4 + + deallocate(some_local_object) + deallocate(foobar) + end program + +! Check that some_local_object is treated as rank-1 array. +! This failed beforehand, because the coarray attribute of the source=expression +! was propagated to some_local_object in the allocate. +! { dg-final { scan-tree-dump-not "some_local_object\._data\.dim\[1\]\.lbound" "original" } } diff --git a/Fortran/gfortran/regression/coarray_allocate_6.f08 b/Fortran/gfortran/regression/coarray_allocate_6.f08 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_allocate_6.f08 @@ -0,0 +1,27 @@ +! { dg-do run } +! { dg-options "-fcoarray=single -fdump-tree-original" } + +! Contributed by Tobias Burnus +! Test fix for pr65795. + +implicit none + +type t2 + integer, allocatable :: x +end type t2 + +type t3 + type(t2), allocatable :: caf[:] +end type t3 + +!type(t3), save, target :: c, d +type(t3), target :: c, d +integer :: stat + +allocate(c%caf[*], stat=stat) +end + +! Besides checking that the executable does not crash anymore, check +! that the cause has been remove. +! { dg-final { scan-tree-dump-not "c.caf.x = 0B" "original" } } + diff --git a/Fortran/gfortran/regression/coarray_allocate_7.f08 b/Fortran/gfortran/regression/coarray_allocate_7.f08 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_allocate_7.f08 @@ -0,0 +1,29 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -lcaf_single -fdump-tree-original" } +! { dg-additional-options "-latomic" { target libatomic_available } } + +! Contributed by Damian Rouson +! Checking whether (de-)registering of coarrays works. + +program main + + implicit none + + type mytype + integer, allocatable :: indices(:) + end type + + type(mytype), save :: object[*] + integer :: i,me + + me=this_image() ! me is always 1 here + object%indices=[(i,i=1,me)] + if ( size(object%indices) /= 1 ) STOP 1 + ! therefore no array is present here and no array test needed. + if ( object%indices(1) /= 1 ) STOP 2 +end program + +! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(D.\[0-9\]+, 1, &\\(\\(struct mytype\\) \\*object\\).indices.token, &\\(\\(struct mytype\\) \\*object\\).indices, 0B, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(D.\[0-9\]+, 8, &\\(\\(struct mytype\\) \\*object\\).indices.token, &\\(\\(struct mytype\\) \\*object\\).indices, 0B, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister \\(&\\(\\(struct mytype\\) \\*object\\).indices.token, 1, 0B, 0B, 0\\);" 1 "original" } } + diff --git a/Fortran/gfortran/regression/coarray_allocate_8.f08 b/Fortran/gfortran/regression/coarray_allocate_8.f08 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_allocate_8.f08 @@ -0,0 +1,39 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -lcaf_single -fdump-tree-original" } +! { dg-additional-options "-latomic" { target libatomic_available } } + +program alloc_comp + implicit none + + type coords + real,allocatable :: x(:) + real,allocatable :: y(:) + real,allocatable :: z(:) + end type + + integer :: me,np,n,i + type(coords) :: coo[*] + + ! with caf_single num_images is always == 1 + me = this_image(); np = num_images() + n = 100 + + allocate(coo%x(n),coo%y(n),coo%z(n)) + + coo%y = me + + do i=1, n + coo%y(i) = coo%y(i) + i + end do + + sync all + + ! Check the caf_get()-offset is computed correctly. + if(me == 1 .and. coo[np]%y(10) /= 11 ) STOP 1 + + ! Check the whole array is correct. + if (me == 1 .and. any( coo[np]%y /= [(i, i=2, 101)] ) ) STOP 2 + + deallocate(coo%x) + +end program diff --git a/Fortran/gfortran/regression/coarray_allocate_9.f08 b/Fortran/gfortran/regression/coarray_allocate_9.f08 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_allocate_9.f08 @@ -0,0 +1,32 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -lcaf_single" } +! { dg-additional-options "-latomic" { target libatomic_available } } + +! Contributed by Damian Rouson + +program main + implicit none + + type particles + real x(2) + end type + + type vector + type(particles), allocatable :: v(:) + end type + + type(vector) :: outbox[*] + type(particles), allocatable :: object(:)[:] + + allocate(outbox%v(1), source=particles(this_image())) + + if (any( outbox[1]%v(1)%x(1:2) /= [ 1.0, 1.0] )) STOP 1 + if (any( outbox[1]%v(1)%x(:) /= [ 1.0, 1.0] )) STOP 2 + if (any( outbox[1]%v(1)%x /= [ 1.0, 1.0] )) STOP 3 + + allocate(object(1)[*], source=particles(this_image())) + + if (any( object(1)[1]%x(1:2) /= [ 1.0, 1.0] )) STOP 4 + if (any( object(1)[1]%x(:) /= [ 1.0, 1.0] )) STOP 5 + if (any( object(1)[1]%x /= [ 1.0, 1.0] )) STOP 6 +end program diff --git a/Fortran/gfortran/regression/coarray_args_1.f90 b/Fortran/gfortran/regression/coarray_args_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_args_1.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! Argument checking +! + implicit none + type t + integer :: i + integer,allocatable :: j + end type t + + type(t), save :: x[*] + + call sub1(x%i) + call sub1(x[1]%i) ! { dg-error "must be a coarray" } +contains + subroutine sub1(y) + integer :: y[*] + end subroutine sub1 +end diff --git a/Fortran/gfortran/regression/coarray_args_2.f90 b/Fortran/gfortran/regression/coarray_args_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_args_2.f90 @@ -0,0 +1,47 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! Check argument passing. +! Taken from Reinhold Bader's fortran_tests. +! + +module mod_rank_mismatch_02 + implicit none + integer, parameter :: ndim = 2 +contains + subroutine subr(n,w) + integer :: n + real :: w(n,*)[*] + + integer :: k, x + + if (this_image() == 0) then + x = 1.0 + do k = 1, num_images() + if (abs(w(2,1)[k] - x) > 1.0e-5) then + write(*, *) 'FAIL' + error stop + end if + x = x + 1.0 + end do + end if + + end subroutine +end module + +program rank_mismatch_02 + use mod_rank_mismatch_02 + implicit none + real :: a(ndim,2)[*] + + a = 0.0 + a(2,2) = 1.0 * this_image() + + sync all + + call subr(ndim, a(1:1,2)) ! OK + call subr(ndim, a(1,2)) ! See also F08/0048 and PR 45859 about the validity + if (this_image() == 1) then + write(*, *) 'OK' + end if +end program diff --git a/Fortran/gfortran/regression/coarray_atomic_1.f90 b/Fortran/gfortran/regression/coarray_atomic_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_atomic_1.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single -std=f2008" } +! +! PR fortran/18918 +! +! Diagnostic for atomic subroutines +! +use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind +implicit none +integer(atomic_int_kind) :: a(1)[*] +logical(1) :: c[*] +integer(atomic_int_kind) :: b +logical(atomic_logical_kind) :: d, e[*] + +call atomic_define(a, 7_2) ! { dg-error "must be a scalar" } +call atomic_ref(b, b) ! { dg-error "shall be a coarray" } + +call atomic_define(c, 7) ! { dg-error "an integer of ATOMIC_INT_KIND or a logical of ATOMIC_LOGICAL_KIND" } +call atomic_ref(d, a(1)) ! { dg-error "shall have the same type as 'atom'" } +call atomic_ref(.true., e) ! { dg-error "shall be definable" } +end diff --git a/Fortran/gfortran/regression/coarray_atomic_2.f90 b/Fortran/gfortran/regression/coarray_atomic_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_atomic_2.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single -std=f2008" } +! +use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind +implicit none + +intrinsic :: atomic_define +intrinsic :: atomic_ref +intrinsic :: atomic_cas ! { dg-error "not available in the current standard settings but new in Fortran 2018." } +intrinsic :: atomic_add ! { dg-error "not available in the current standard settings but new in Fortran 2018." } +intrinsic :: atomic_and ! { dg-error "not available in the current standard settings but new in Fortran 2018." } +intrinsic :: atomic_or ! { dg-error "not available in the current standard settings but new in Fortran 2018." } +intrinsic :: atomic_xor ! { dg-error "not available in the current standard settings but new in Fortran 2018." } +intrinsic :: atomic_fetch_add ! { dg-error "not available in the current standard settings but new in Fortran 2018." } +intrinsic :: atomic_fetch_and ! { dg-error "not available in the current standard settings but new in Fortran 2018." } +intrinsic :: atomic_fetch_or ! { dg-error "not available in the current standard settings but new in Fortran 2018." } +intrinsic :: atomic_fetch_xor ! { dg-error "not available in the current standard settings but new in Fortran 2018." } +integer(atomic_int_kind) :: caf[*], var +logical(atomic_logical_kind) :: caf_log[*], var2 +integer :: stat +integer(1) :: stat2 + +call atomic_define(caf, 5, stat=stat) ! { dg-error "STAT= argument to atomic_define" } +call atomic_define(caf_log, .true., stat=stat2) ! { dg-error "must be of kind 4" } +call atomic_ref(var, caf[1], stat=stat2) ! { dg-error "must be of kind 4" } +call atomic_ref(var2, caf_log[1], stat=stat) ! { dg-error "STAT= argument to atomic_ref" } +end diff --git a/Fortran/gfortran/regression/coarray_atomic_3.f90 b/Fortran/gfortran/regression/coarray_atomic_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_atomic_3.f90 @@ -0,0 +1,112 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single -std=f2008ts -fmax-errors=200" } +! +use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind +implicit none + +intrinsic :: atomic_define +intrinsic :: atomic_ref +intrinsic :: atomic_cas +intrinsic :: atomic_add +intrinsic :: atomic_and +intrinsic :: atomic_or +intrinsic :: atomic_xor +intrinsic :: atomic_fetch_add +intrinsic :: atomic_fetch_and +intrinsic :: atomic_fetch_or +intrinsic :: atomic_fetch_xor +integer(atomic_int_kind) :: caf[*], var +logical(atomic_logical_kind) :: caf_log[*], var2 +integer :: stat +integer(1) :: var3, caf0[*] +logical(1) :: var4, caf0_log[*] + +call atomic_define(caf[1], 2_2, stat=stat) +call atomic_define(atom=caf_log[1], value=.false._2) +call atomic_define(caf_log[1], 2) ! { dg-error "shall have the same type as 'atom'" } +call atomic_define(var, 2_2, stat=stat) ! { dg-error "shall be a coarray or coindexed" } +call atomic_define(caf0, 2_2, stat=stat) ! { dg-error "integer of ATOMIC_INT_KIND or a logical of ATOMIC_LOGICAL_KIND" } +call atomic_define(var2, 2_2, stat=stat) ! { dg-error "shall be a coarray or coindexed" } +call atomic_define(caf0_log, 2_2, stat=stat) ! { dg-error "integer of ATOMIC_INT_KIND or a logical of ATOMIC_LOGICAL_KIND" } + +call atomic_ref(var3, caf[1], stat=stat) +call atomic_ref(value=var4, atom=caf_log[1]) +call atomic_ref(var, caf_log[1]) ! { dg-error "shall have the same type as 'atom'" } +call atomic_ref(var, var) ! { dg-error "shall be a coarray or coindexed" } +call atomic_ref(var, caf0) ! { dg-error "integer of ATOMIC_INT_KIND or a logical of ATOMIC_LOGICAL_KIND" } +call atomic_ref(var, caf0_log) ! { dg-error "integer of ATOMIC_INT_KIND or a logical of ATOMIC_LOGICAL_KIND" } + +call atomic_cas(caf[1], var, 2_4, 1_1, stat=stat) +call atomic_cas(caf[1], var, 2_2, 1_1, stat=stat) ! { dg-error "'compare' argument of 'atomic_cas' intrinsic at .1. must be the same type and kind as 'atom'" } +call atomic_cas(caf[1], var3, 2_2, 1_1, stat=stat) ! { dg-error "'old' argument of 'atomic_cas' intrinsic at .1. must be the same type and kind as 'atom'" } +call atomic_cas(caf[1], var3, 2_4, .false._4, stat=stat) ! { dg-error "shall have the same type as 'atom'" } +call atomic_cas(caf0[1], var, 2_4, 1_1, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND or a logical of ATOMIC_LOGICAL_KIND" } +call atomic_cas(var, var, 2_4, 1_1, stat=stat) ! { dg-error "shall be a coarray or coindexed" } +call atomic_cas(caf_log[1], var2, .true._4, .false._1, stat=stat) +call atomic_cas(caf_log[1], var2, .true._2, .false._1, stat=stat) ! { dg-error "'compare' argument of 'atomic_cas' intrinsic at .1. must be the same type and kind as 'atom'" } +call atomic_cas(caf_log[1], var4, .true._4, .false._1, stat=stat) ! { dg-error "'old' argument of 'atomic_cas' intrinsic at .1. must be the same type and kind as 'atom'" } +call atomic_cas(caf_log[1], var4, .true._4, 4_4, stat=stat) ! { dg-error "shall have the same type as 'atom'" } +call atomic_cas(atom=caf0_log[1], old=var4, compare=.true._4, new=.false._4, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND or a logical of ATOMIC_LOGICAL_KIND" } +call atomic_cas(var2, var4, .true._4, .false._4, stat=stat) ! { dg-error "shall be a coarray or coindexed" } +call atomic_cas(caf[1], var, 2_4, 1_1, stat=var3) ! { dg-error "'stat' argument of 'atomic_cas' intrinsic at .1. must be of kind 4" } + +call atomic_add(atom=caf, value=2_4, stat=stat) +call atomic_add(caf, 2_2, stat=stat) +call atomic_add(caf, .false._2, stat=stat) ! { dg-error "shall have the same type as 'atom'" } +call atomic_add(caf_log, .false._2, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND" } +call atomic_add(var, 34._4) ! { dg-error "shall be a coarray or coindexed" } +call atomic_add(atom=caf, value=2_4, stat=var3) ! { dg-error "'stat' argument of 'atomic_add' intrinsic at .1. must be of kind 4" } + +call atomic_and(caf, 2_4, stat=stat) +call atomic_and(atom=caf, value=2_2, stat=stat) +call atomic_and(caf, .false._2, stat=stat) ! { dg-error "shall have the same type as 'atom'" } +call atomic_and(caf_log, .false._2, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND" } +call atomic_and(var, 34._4) ! { dg-error "shall be a coarray or coindexed" } +call atomic_and(caf, 2_4, stat=var3) ! { dg-error "'stat' argument of 'atomic_and' intrinsic at .1. must be of kind 4" } + +call atomic_or(caf, value=2_4, stat=stat) +call atomic_or(atom=caf, value=2_2, stat=stat) +call atomic_or(caf, .false._2, stat=stat) ! { dg-error "shall have the same type as 'atom'" } +call atomic_or(caf_log, .false._2, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND" } +call atomic_or(var, 34._4) ! { dg-error "shall be a coarray or coindexed" } +call atomic_or(caf, value=2_4, stat=var3) ! { dg-error "'stat' argument of 'atomic_or' intrinsic at .1. must be of kind 4" } + +call atomic_xor(caf, 2_4, stat=stat) +call atomic_xor(atom=caf, value=2_2, stat=stat) +call atomic_xor(caf, .false._2, stat=stat) ! { dg-error "shall have the same type as 'atom'" } +call atomic_xor(caf_log, .false._2, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND" } +call atomic_xor(var, 34._4) ! { dg-error "shall be a coarray or coindexed" } +call atomic_xor(caf, 2_4, stat=var3) ! { dg-error "'stat' argument of 'atomic_xor' intrinsic at .1. must be of kind 4" } + +call atomic_fetch_add(atom=caf, value=2_4, old=var, stat=stat) +call atomic_fetch_add(caf, 2_2, var) +call atomic_fetch_add(caf, .false._2, var, stat=stat) ! { dg-error "shall have the same type as 'atom'" } +call atomic_fetch_add(caf_log, .false._2, var2, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND" } +call atomic_fetch_add(var, 34._4, var) ! { dg-error "shall be a coarray or coindexed" } +call atomic_fetch_add(caf, 2_2, var3) ! { dg-error "must be the same type and kind as 'atom'" } +call atomic_fetch_add(atom=caf, value=2_4, old=var, stat=var3) ! { dg-error "'stat' argument of 'atomic_fetch_add' intrinsic at .1. must be of kind 4" } + +call atomic_fetch_and(atom=caf, value=2_4, old=var, stat=stat) +call atomic_fetch_and(caf, 2_2, var) +call atomic_fetch_and(caf, .false._2, var, stat=stat) ! { dg-error "shall have the same type as 'atom'" } +call atomic_fetch_and(caf_log, .false._2, var2, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND" } +call atomic_fetch_and(var, 34._4, var) ! { dg-error "shall be a coarray or coindexed" } +call atomic_fetch_and(caf, 2_2, var3) ! { dg-error "must be the same type and kind as 'atom'" } +call atomic_fetch_and(atom=caf, value=2_4, old=var, stat=var3) ! { dg-error "'stat' argument of 'atomic_fetch_and' intrinsic at .1. must be of kind 4" } + +call atomic_fetch_or(atom=caf, value=2_4, old=var, stat=stat) +call atomic_fetch_or(caf, 2_2, var) +call atomic_fetch_or(caf, .false._2, var, stat=stat) ! { dg-error "shall have the same type as 'atom'" } +call atomic_fetch_or(caf_log, .false._2, var2, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND" } +call atomic_fetch_or(var, 34._4, var) ! { dg-error "shall be a coarray or coindexed" } +call atomic_fetch_or(caf, 2_2, var3) ! { dg-error "must be the same type and kind as 'atom'" } +call atomic_fetch_or(atom=caf, value=2_4, old=var, stat=var3) ! { dg-error "'stat' argument of 'atomic_fetch_or' intrinsic at .1. must be of kind 4" } + +call atomic_fetch_xor(atom=caf, value=2_4, old=var, stat=stat) +call atomic_fetch_xor(caf, 2_2, var) +call atomic_fetch_xor(caf, .false._2, var, stat=stat) ! { dg-error "shall have the same type as 'atom'" } +call atomic_fetch_xor(caf_log, .false._2, var2, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND" } +call atomic_fetch_xor(var, 34._4, var) ! { dg-error "shall be a coarray or coindexed" } +call atomic_fetch_xor(caf, 2_2, var3) ! { dg-error "must be the same type and kind as 'atom'" } +call atomic_fetch_xor(atom=caf, value=2_4, old=var, stat=var3) ! { dg-error "'stat' argument of 'atomic_fetch_xor' intrinsic at .1. must be of kind 4" } +end diff --git a/Fortran/gfortran/regression/coarray_atomic_4.f90 b/Fortran/gfortran/regression/coarray_atomic_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_atomic_4.f90 @@ -0,0 +1,68 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single -fdump-tree-original" } +! +use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind +implicit none + +intrinsic :: atomic_define +intrinsic :: atomic_ref +intrinsic :: atomic_cas +intrinsic :: atomic_add +intrinsic :: atomic_and +intrinsic :: atomic_or +intrinsic :: atomic_xor +intrinsic :: atomic_fetch_add +intrinsic :: atomic_fetch_and +intrinsic :: atomic_fetch_or +intrinsic :: atomic_fetch_xor +integer(atomic_int_kind) :: caf[*], var +logical(atomic_logical_kind) :: caf_log[*], var2 +integer :: stat +integer(1) :: var3 +logical(1) :: var4 + +call atomic_define(caf, var, stat=stat) +call atomic_define(caf_log, var2, stat=stat) + +call atomic_ref(var, caf, stat=stat) +call atomic_ref(var2, caf_log, stat=stat) + +call atomic_cas(caf, var, 3_atomic_int_kind, 5_1, stat=stat) +call atomic_cas(caf_log, var2, .true._atomic_logical_kind, & + .false._2, stat=stat) + +call atomic_add(caf, 77, stat=stat) +call atomic_and(caf, 88, stat=stat) +call atomic_or(caf, 101, stat=stat) +call atomic_xor(caf, 105_2, stat=stat) + +call atomic_fetch_add(caf, var3, var, stat=stat) +call atomic_fetch_and(caf, 22_1, var, stat=stat) +call atomic_fetch_or(caf, var3, var, stat=stat) +call atomic_fetch_xor(caf, 47_2, var, stat=stat) + +end + +! All the atomic calls: +! { dg-final { scan-tree-dump-times " __atomic_store_4 \\(&caf, \\(integer\\(kind=4\\)\\) var, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times " __atomic_store_4 \\(&caf_log, \\(logical\\(kind=4\\)\\) var2, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "var = \\(integer\\(kind=4\\)\\) __atomic_load_4 \\(&caf, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "var2 = \\(logical\\(kind=4\\)\\) __atomic_load_4 \\(&caf_log, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times " __atomic_compare_exchange_4 \\(&caf, &var, 5, 0, 0, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times " __atomic_compare_exchange_4 \\(&caf_log, &var2, 0, 0, 0, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times " __atomic_fetch_add_4 \\(&caf, 77, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times " __atomic_fetch_and_4 \\(&caf, 88, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times " __atomic_fetch_or_4 \\(&caf, 101, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times " __atomic_fetch_xor_4 \\(&caf, 105, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "var = \\(integer\\(kind=4\\)\\) __atomic_fetch_add_4 \\(&caf, \\(integer\\(kind=4\\)\\) var3, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "var = \\(integer\\(kind=4\\)\\) __atomic_fetch_and_4 \\(&caf, 22, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times " var = \\(integer\\(kind=4\\)\\) __atomic_fetch_or_4 \\(&caf, \\(integer\\(kind=4\\)\\) var3, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times " var = \\(integer\\(kind=4\\)\\) __atomic_fetch_xor_4 \\(&caf, 47, 0\\);" 1 "original" } } + +! CAS: Handle "compare" argument +! { dg-final { scan-tree-dump-times "var = 3;" 1 "original" } } +! { dg-final { scan-tree-dump-times "var2 = 1;" 1 "original" } } + +! All calls should have a stat=0 +! { dg-final { scan-tree-dump-times "stat = 0;" 14 "original" } } + diff --git a/Fortran/gfortran/regression/coarray_atomic_5.f90 b/Fortran/gfortran/regression/coarray_atomic_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_atomic_5.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -fcoarray=lib" } +! +! Argument passing was wrong +! + +program atomic + use iso_fortran_env + implicit none + + integer :: me + integer(atomic_int_kind) :: atom[*] + me = this_image() + call atomic_define(atom[1],0) + sync all + call ATOMIC_ADD (atom[1], me) + if(me == 1) call atomic_ref(me,atom[1]) + sync all + write(*,*) me +end program + +! { dg-final { scan-tree-dump-times "value.. = 0;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_atomic_define \\(caf_token.0, 0, 1, &value.., 0B, 1, 4\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_atomic_op \\(1, caf_token.0, 0, 1, &me, 0B, 0B, 1, 4\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_atomic_ref \\(caf_token.0, 0, 1, &me, 0B, 1, 4\\);" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_atomic_6.f90 b/Fortran/gfortran/regression/coarray_atomic_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_atomic_6.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! Contributed by Reinhold Bader +! +! +program def_and_ref +! compile only + use, intrinsic :: iso_fortran_env + implicit none + type :: e + integer(kind=atomic_int_kind) :: ia = 0 + logical(kind=atomic_logical_kind) :: la = .false. + end type + + type(e) :: a[*] + + integer :: ival = 0 + logical :: lval = .false. + + if (this_image() == 1) then + call atomic_define(a[num_images()]%ia, 4) + call atomic_define(a[num_images()]%la, .true.) + end if + if (this_image() == num_images()) then + do while (ival == 0 .or. .not. lval) + call atomic_ref(ival, a%ia) + call atomic_ref(lval, a%la) + end do + if (ival == 4 .and. lval) then + write(*,*) 'OK' + else + write(*,*) 'FAIL: ival,lval =', ival, lval + end if + end if +end program diff --git a/Fortran/gfortran/regression/coarray_class_1.f90 b/Fortran/gfortran/regression/coarray_class_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_class_1.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/51632 +! +! Was rejected before as __def_init and __copy were +! resolved and coarray components aren't valid in this +! context +! +module periodic_2nd_order_module + implicit none + + type periodic_2nd_order + real, allocatable :: global_f(:)[:] + contains + procedure :: output + end type + +contains + subroutine output (this) + class(periodic_2nd_order), intent(in) :: this + end subroutine +end module diff --git a/Fortran/gfortran/regression/coarray_class_2.f90 b/Fortran/gfortran/regression/coarray_class_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_class_2.f90 @@ -0,0 +1,45 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } +! Check that error message is presented as long as polymorphic coarrays are +! not implemented. + +module maccscal + type t + real, allocatable :: a + end type +contains + subroutine s(x) ! { dg-error "Sorry, allocatable/pointer components in polymorphic \\(CLASS\\)" } + class(t) :: x[*] + allocate (x%a) + end +end +module mptrscal + type t + real, pointer :: a + end type +contains + subroutine s(x) ! { dg-error "Sorry, allocatable/pointer components in polymorphic \\(CLASS\\)" } + class(t) :: x[*] + allocate (x%a) + end +end +module mallarr + type t + real, allocatable :: a(:) + end type +contains + subroutine s(x) ! { dg-error "Sorry, allocatable/pointer components in polymorphic \\(CLASS\\)" } + class(t) :: x[*] + allocate (x%a(2)) + end +end +module mptrarr + type t + real, pointer :: a(:) + end type +contains + subroutine s(x) ! { dg-error "Sorry, allocatable/pointer components in polymorphic \\(CLASS\\)" } + class(t) :: x[*] + allocate (x%a(2)) + end +end diff --git a/Fortran/gfortran/regression/coarray_collectives_1.f90 b/Fortran/gfortran/regression/coarray_collectives_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_collectives_1.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! +! CO_SUM/CO_MIN/CO_MAX +! +program test + implicit none + intrinsic co_max + intrinsic co_min + intrinsic co_sum + integer :: val, i + character(len=30) :: errmsg + integer(8) :: i8 + character(len=19, kind=4) :: msg4 + + call co_sum("abc") ! { dg-error "must have a numeric type" } + call co_max(cmplx(1.0,0.0)) ! { dg-error "shall be of type integer, real or character" } + call co_min(cmplx(0.0,1.0)) ! { dg-error "shall be of type integer, real or character" } + + call co_sum(1) ! { dg-error "must be a variable" } + call co_min("abc") ! { dg-error "must be a variable" } + call co_max(2.3) ! { dg-error "must be a variable" } + + call co_sum(val, result_image=[1,2]) ! { dg-error "must be a scalar" } + call co_sum(val, result_image=1.0) ! { dg-error "must be INTEGER" } + call co_min(val, stat=[1,2]) ! { dg-error "must be a scalar" } + call co_min(val, stat=1.0) ! { dg-error "must be INTEGER" } + call co_min(val, stat=1) ! { dg-error "must be a variable" } + call co_min(val, stat=i, result_image=1) ! OK + call co_max(val, stat=i, errmsg=errmsg, result_image=1) ! OK + call co_max(val, stat=i, errmsg=[errmsg], result_image=1) ! { dg-error "must be a scalar" } + call co_max(val, stat=i, errmsg=5, result_image=1) ! { dg-error "must be CHARACTER" } + call co_sum(val, errmsg="abc") ! { dg-error "must be a variable" } + + call co_sum(val, stat=i8) ! { dg-error "The stat= argument at .1. must be a kind=4 integer variable" } + call co_min(val, errmsg=msg4) ! { dg-error "The errmsg= argument at .1. must be a default-kind character variable" } +end program test diff --git a/Fortran/gfortran/regression/coarray_collectives_10.f90 b/Fortran/gfortran/regression/coarray_collectives_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_collectives_10.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single -std=f2008" } +! +! +! CO_REDUCE/CO_BROADCAST +! +program test + implicit none + intrinsic co_reduce ! { dg-error "is not available in the current standard settings but new in Fortran 2018." } + intrinsic co_broadcast ! { dg-error "is not available in the current standard settings but new in Fortran 2018." } +end program test diff --git a/Fortran/gfortran/regression/coarray_collectives_11.f90 b/Fortran/gfortran/regression/coarray_collectives_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_collectives_11.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -fcoarray=single" } +! +! CO_BROADCAST +! +program test + implicit none + intrinsic co_reduce + integer :: stat1 + real :: val + call co_broadcast(val, source_image=1, stat=stat1) +end program test + +! { dg-final { scan-tree-dump-times "stat1 = 0;" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_collectives_12.f90 b/Fortran/gfortran/regression/coarray_collectives_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_collectives_12.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -fcoarray=lib" } +! +! CO_SUM/CO_MIN/CO_MAX +! +program test + implicit none + intrinsic co_max + integer :: stat1, stat2, stat3 + character(len=6) :: errmesg1 + character(len=7) :: errmesg2 + character(len=8) :: errmesg3 + real :: val1 + complex, allocatable :: val2(:) + character(len=99) :: val3 + integer :: res + + call co_broadcast(val1, source_image=num_images(), stat=stat1, errmsg=errmesg1) + call co_broadcast(val2, source_image=4, stat=stat2, errmsg=errmesg2) + call co_broadcast(val3, source_image=res,stat=stat3, errmsg=errmesg3) +end program test + +! { dg-final { scan-tree-dump-times "_gfortran_caf_co_broadcast \\(&desc.., _gfortran_caf_num_images \\(0, -1\\), &stat1, errmesg1, 6\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_co_broadcast \\(&val2, 4, &stat2, errmesg2, 7\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_co_broadcast \\(&desc.., res, &stat3, errmesg3, 8\\);" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_collectives_13.f90 b/Fortran/gfortran/regression/coarray_collectives_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_collectives_13.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single -std=f2008" } +! +! +! CO_REDUCE/CO_BROADCAST +! +program test + implicit none + intrinsic co_reduce ! { dg-error "is not available in the current standard settings but new in Fortran 2018." } + intrinsic co_broadcast ! { dg-error "is not available in the current standard settings but new in Fortran 2018." } +end program test diff --git a/Fortran/gfortran/regression/coarray_collectives_14.f90 b/Fortran/gfortran/regression/coarray_collectives_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_collectives_14.f90 @@ -0,0 +1,146 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single -fmax-errors=80" } +! +! +! CO_REDUCE (plus CO_MIN/MAX/SUM/BROADCAST) +! +program test + implicit none (external, type) + intrinsic co_reduce + intrinsic co_broadcast + intrinsic co_min + intrinsic co_max + intrinsic co_sum + intrinsic dprod + external ext + + type t + procedure(), pointer, nopass :: ext + procedure(valid), pointer, nopass :: valid + procedure(sub), pointer, nopass :: sub + procedure(nonpure), pointer, nopass :: nonpure + procedure(arg1), pointer, nopass :: arg1 + procedure(arg3), pointer, nopass :: arg3 + procedure(elem), pointer, nopass :: elem + procedure(realo), pointer, nopass :: realo + procedure(int8), pointer, nopass :: int8 + procedure(arr), pointer, nopass :: arr + procedure(ptr), pointer, nopass :: ptr + procedure(alloc), pointer, nopass :: alloc + procedure(opt), pointer, nopass :: opt + procedure(val), pointer, nopass :: val + procedure(async), pointer, nopass :: async + procedure(tgt), pointer, nopass :: tgt + procedure(char44), pointer, nopass :: char44 + procedure(char34), pointer, nopass :: char34 + end type t + + type(t) :: dt + integer :: caf[*] + character(len=3) :: c3 + character(len=4) :: c4 + + + + call co_min(caf[1]) ! { dg-error "shall not be coindexed" } + call co_max(caf[1]) ! { dg-error "shall not be coindexed" } + call co_sum(caf[1]) ! { dg-error "shall not be coindexed" } + call co_broadcast(caf[1], source_image=1) ! { dg-error "shall not be coindexed" } + call co_reduce(caf[1], valid) ! { dg-error "shall not be coindexed" } + + call co_reduce(caf, valid) ! OK + call co_reduce(caf, dt%valid) ! OK + call co_reduce(caf, dprod) ! { dg-error "is not permitted for CO_REDUCE" } + call co_reduce(caf, ext) ! { dg-error "must be a PURE function" } + call co_reduce(caf, dt%ext) ! { dg-error "must be a PURE function" } + call co_reduce(caf, sub) ! { dg-error "must be a PURE function" } + call co_reduce(caf, dt%sub) ! { dg-error "must be a PURE function" } + call co_reduce(caf, nonpure) ! { dg-error "must be a PURE function" } + call co_reduce(caf, dt%nonpure) ! { dg-error "must be a PURE function" } + call co_reduce(caf, arg1) ! { dg-error "shall have two arguments" } + call co_reduce(caf, dt%arg1) ! { dg-error "shall have two arguments" } + call co_reduce(caf, arg3) ! { dg-error "shall have two arguments" } + call co_reduce(caf, dt%arg3) ! { dg-error "shall have two arguments" } + call co_reduce(caf, elem) ! { dg-error "ELEMENTAL non-INTRINSIC procedure 'elem' is not allowed as an actual argument" } + call co_reduce(caf, dt%elem) ! { dg-error "ELEMENTAL procedure pointer component 'elem' is not allowed as an actual argument" } + call co_reduce(caf, realo) ! { dg-error "A argument at .1. has type INTEGER.4. but the function passed as OPERATION at .2. returns REAL.4." } + call co_reduce(caf, dt%realo) ! { dg-error "A argument at .1. has type INTEGER.4. but the function passed as OPERATION at .2. returns REAL.4." } + call co_reduce(caf, int8) ! { dg-error "A argument at .1. has type INTEGER.4. but the function passed as OPERATION at .2. returns INTEGER.8." } + call co_reduce(caf, dt%int8) ! { dg-error "A argument at .1. has type INTEGER.4. but the function passed as OPERATION at .2. returns INTEGER.8." } + call co_reduce(caf, arr) ! { dg-error "scalar nonallocatable nonpointer arguments and return a nonallocatable nonpointer scalar" } + call co_reduce(caf, dt%arr) ! { dg-error "scalar nonallocatable nonpointer arguments and return a nonallocatable nonpointer scalar" } + call co_reduce(caf, ptr) ! { dg-error "scalar nonallocatable nonpointer arguments and return a nonallocatable nonpointer scalar" } + call co_reduce(caf, dt%ptr) ! { dg-error "scalar nonallocatable nonpointer arguments and return a nonallocatable nonpointer scalar" } + call co_reduce(caf, alloc) ! { dg-error "scalar nonallocatable nonpointer arguments and return a nonallocatable nonpointer scalar" } + call co_reduce(caf, dt%alloc) ! { dg-error "scalar nonallocatable nonpointer arguments and return a nonallocatable nonpointer scalar" } + call co_reduce(caf, opt) ! { dg-error "shall not have the OPTIONAL attribute for either of the arguments" } + call co_reduce(caf, dt%opt) ! { dg-error "shall not have the OPTIONAL attribute for either of the arguments" } + call co_reduce(caf, val) ! { dg-error "shall have the VALUE attribute either for none or both arguments" } + call co_reduce(caf, dt%val) ! { dg-error "shall have the VALUE attribute either for none or both arguments" } + call co_reduce(caf, async) ! { dg-error "shall have the ASYNCHRONOUS attribute either for none or both arguments" } + call co_reduce(caf, dt%async) ! { dg-error "shall have the ASYNCHRONOUS attribute either for none or both arguments" } + call co_reduce(caf, tgt) ! { dg-error "shall have the TARGET attribute either for none or both arguments" } + call co_reduce(caf, dt%tgt) ! { dg-error "shall have the TARGET attribute either for none or both arguments" } + call co_reduce(c4, char44) ! OK + call co_reduce(c4, dt%char44) ! OK + call co_reduce(c3, char34) ! { dg-error "character length of the A argument at .1. and of the arguments of the OPERATION at .2. shall be the same" } + call co_reduce(c3, dt%char34) ! { dg-error "character length of the A argument at .1. and of the arguments of the OPERATION at .2. shall be the same" } + call co_reduce(c4, char34) ! { dg-error "The character length of the A argument at .1. and of the function result of the OPERATION at .2. shall be the same" } + call co_reduce(c4, dt%char34) ! { dg-error "The character length of the A argument at .1. and of the function result of the OPERATION at .2. shall be the same" } + +contains + pure integer function valid(x,y) + integer, value :: x, y + end function valid + impure integer function nonpure(x,y) + integer, value :: x, y + end function nonpure + pure subroutine sub() + end subroutine sub + pure integer function arg3(x, y, z) + integer, value :: x, y, z + end function arg3 + pure integer function arg1(x) + integer, value :: x + end function arg1 + pure elemental integer function elem(x,y) + integer, value :: x, y + end function elem + pure real function realo(x,y) + integer, value :: x, y + end function realo + pure integer(8) function int8(x,y) + integer, value :: x, y + end function int8 + pure integer function arr(x,y) + integer, intent(in) :: x(:), y + end function arr + pure integer function ptr(x,y) + integer, intent(in), pointer :: x, y + end function ptr + pure integer function alloc(x,y) + integer, intent(in), allocatable :: x, y + end function alloc + pure integer function opt(x,y) + integer, intent(in) :: x, y + optional :: x, y + end function opt + pure integer function val(x,y) + integer, value :: x + integer, intent(in) :: y + end function val + pure integer function tgt(x,y) + integer, intent(in) :: x, y + target :: x + end function tgt + pure integer function async(x,y) + integer, intent(in) :: x, y + asynchronous :: y + end function async + pure character(4) function char44(x,y) + character(len=4), value :: x, y + end function char44 + pure character(3) function char34(x,y) + character(len=4), value :: x, y + end function char34 +end program test diff --git a/Fortran/gfortran/regression/coarray_collectives_15.f90 b/Fortran/gfortran/regression/coarray_collectives_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_collectives_15.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -fcoarray=single" } +! +! CO_REDUCE +! +program test + implicit none + intrinsic co_reduce + integer :: stat1 + real :: val + call co_reduce(val, valid, result_image=1, stat=stat1) +contains + pure real function valid(x,y) + real, value :: x, y + valid = x * y + end function valid +end program test + +! { dg-final { scan-tree-dump-times "stat1 = 0;" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_collectives_16.f90 b/Fortran/gfortran/regression/coarray_collectives_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_collectives_16.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -fcoarray=lib" } +! +! CO_REDUCE +! +program test + implicit none + intrinsic co_max + integer :: stat1, stat2, stat3 + character(len=6) :: errmesg1 + character(len=7) :: errmesg2 + character(len=8) :: errmesg3 + real :: val1 + complex, allocatable :: val2(:) + character(len=99) :: val3 + integer :: res + + call co_reduce(val1, operation=fr, result_image=num_images(), stat=stat1, errmsg=errmesg1) + call co_reduce(val2, operation=gz, result_image=4, stat=stat2, errmsg=errmesg2) + call co_reduce(val3, operation=hc, result_image=res,stat=stat3, errmsg=errmesg3) +contains + pure real function fr(x,y) + real, value :: x, y + fr = x * y + end function fr + pure complex function gz(x,y) + complex, intent(in):: x, y + gz = x *y + end function gz + pure character(len=99) function hc(x,y) + character(len=99), intent(in):: x, y + hc = x(1:50) // y(1:49) + end function hc +end program test + +! { dg-final { scan-tree-dump-times "_gfortran_caf_co_reduce \\(&desc.., fr, 4, _gfortran_caf_num_images \\(0, -1\\), &stat1, errmesg1, 0, 6\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_co_reduce \\(&val2, gz, 0, 4, &stat2, errmesg2, 0, 7\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_co_reduce \\(&desc.., hc, 1, res, &stat3, errmesg3, 99, 8\\);" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_collectives_17.f90 b/Fortran/gfortran/regression/coarray_collectives_17.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_collectives_17.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +! { dg-options "-fcoarray=single" } +! +! PR 100337 +! Test case inspired by code submitted by Brad Richardson + +program main + implicit none + + integer, parameter :: MESSAGE = 42 + integer :: result + + call myco_broadcast(MESSAGE, result, 1) + + if (result /= MESSAGE) error stop 1 +contains + subroutine myco_broadcast(m, r, source_image, stat, errmsg) + integer, intent(in) :: m + integer, intent(out) :: r + integer, intent(in) :: source_image + integer, intent(out), optional :: stat + character(len=*), intent(inout), optional :: errmsg + + integer :: data_length + + data_length = 1 + + call co_broadcast(data_length, source_image, stat, errmsg) + + if (present(stat)) then + if (stat /= 0) return + end if + + if (this_image() == source_image) then + r = m + end if + + call co_broadcast(r, source_image, stat, errmsg) + end subroutine + +end program + diff --git a/Fortran/gfortran/regression/coarray_collectives_18.f90 b/Fortran/gfortran/regression/coarray_collectives_18.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_collectives_18.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original -fcoarray=lib" } +! +! PR 103970 +! Test case inspired by code submitted by Damian Rousson + +program main + + implicit none + + type foo_t + integer i + integer, allocatable :: j + end type + + type(foo_t) foo + integer, parameter :: source_image = 1 + + if (this_image() == source_image) then + foo = foo_t(2,3) + else + allocate(foo%j) + end if + call co_broadcast(foo, source_image) + + if ((foo%i /= 2) .or. (foo%j /= 3)) error stop 1 + sync all + +end program + +! Wrong code generation produced too many temp descriptors +! leading to stacked descriptors handed to the co_broadcast. +! This lead to access to non exsitant memory in opencoarrays. +! In single image mode just checking for reduced number of +! descriptors is possible, i.e., execute always works. +! { dg-final { scan-tree-dump-times "desc\\.\[0-9\]+" 12 "original" } } + diff --git a/Fortran/gfortran/regression/coarray_collectives_2.f90 b/Fortran/gfortran/regression/coarray_collectives_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_collectives_2.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single -std=f2008" } +! +! +! CO_SUM/CO_MIN/CO_MAX +! +program test + implicit none + intrinsic co_max ! { dg-error "is not available in the current standard settings but new in Fortran 2018." } + intrinsic co_min ! { dg-error "is not available in the current standard settings but new in Fortran 2018." } + intrinsic co_sum ! { dg-error "is not available in the current standard settings but new in Fortran 2018." } +end program test diff --git a/Fortran/gfortran/regression/coarray_collectives_3.f90 b/Fortran/gfortran/regression/coarray_collectives_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_collectives_3.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! CO_SUM/CO_MIN/CO_MAX +! +program test + implicit none + intrinsic co_max + integer :: val + call co_max(val) ! { dg-error "Coarrays disabled at .1., use '-fcoarray=' to enable" } +end program test +! { dg-prune-output "compilation terminated" } diff --git a/Fortran/gfortran/regression/coarray_collectives_4.f90 b/Fortran/gfortran/regression/coarray_collectives_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_collectives_4.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -fcoarray=single" } +! +! CO_SUM/CO_MIN/CO_MAX +! +program test + implicit none + intrinsic co_max + integer :: stat1, stat2, stat3 + real :: val + call co_max(val, stat=stat1) + call co_min(val, stat=stat2) + call co_sum(val, stat=stat3) +end program test + +! { dg-final { scan-tree-dump-times "stat1 = 0;" 1 "original" } } +! { dg-final { scan-tree-dump-times "stat2 = 0;" 1 "original" } } +! { dg-final { scan-tree-dump-times "stat3 = 0;" 1 "original" } } + diff --git a/Fortran/gfortran/regression/coarray_collectives_5.f90 b/Fortran/gfortran/regression/coarray_collectives_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_collectives_5.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -fcoarray=lib" } +! +! CO_SUM/CO_MIN/CO_MAX +! +program test + implicit none + intrinsic co_max + integer :: stat1, stat2, stat3 + real :: val + call co_max(val, stat=stat1) + call co_min(val, stat=stat2) + call co_sum(val, stat=stat3) +end program test + +! { dg-final { scan-tree-dump-times "_gfortran_caf_co_max \\(&desc.., 0, &stat1, 0B, 0, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_co_min \\(&desc.., 0, &stat2, 0B, 0, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_co_sum \\(&desc.., 0, &stat3, 0B, 0\\);" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_collectives_6.f90 b/Fortran/gfortran/regression/coarray_collectives_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_collectives_6.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -fcoarray=lib" } +! +! CO_SUM/CO_MIN/CO_MAX +! +program test + implicit none + intrinsic co_max + integer :: stat1, stat2, stat3 + character(len=6) :: errmesg1 + character(len=7) :: errmesg2 + character(len=8) :: errmesg3 + real :: val1 + complex, allocatable :: val2(:) + character(len=99) :: val3 + integer :: res + + call co_max(val1, stat=stat1, errmsg=errmesg1) + call co_sum(val2, result_image=4, stat=stat2, errmsg=errmesg2) + call co_min(val3, result_image=res,stat=stat3, errmsg=errmesg3) +end program test + +! { dg-final { scan-tree-dump-times "_gfortran_caf_co_max \\(&desc.., 0, &stat1, errmesg1, 0, 6\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_co_sum \\(&val2, 4, &stat2, errmesg2, 7\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_co_min \\(&desc.., res, &stat3, errmesg3, 99, 8\\);" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_collectives_8.f90 b/Fortran/gfortran/regression/coarray_collectives_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_collectives_8.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } +! +! As SOURCE is INTENT(INOUT), it must be definable, +! cf. J3/14-147 +! + +intrinsic :: co_sum, co_min, co_max +integer :: vec(3), idx(3) + +call co_sum(vec(idx)) ! { dg-error "Argument 'A' with INTENT\\(INOUT\\) at .1. of the intrinsic subroutine co_sum shall not have a vector subscript" } +call co_min(vec([1,3,2])) ! { dg-error "Argument 'A' with INTENT\\(INOUT\\) at .1. of the intrinsic subroutine co_min shall not have a vector subscript" } +call co_sum(vec([1,1,1])) ! { dg-error "Elements with the same value at .1. and .2. in vector subscript in a variable definition context \\(argument 'A' with INTENT\\(INOUT\\)\\)" } +end diff --git a/Fortran/gfortran/regression/coarray_collectives_9.f90 b/Fortran/gfortran/regression/coarray_collectives_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_collectives_9.f90 @@ -0,0 +1,62 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single -fmax-errors=40" } +! +! +! CO_BROADCAST/CO_REDUCE +! +program test + implicit none + intrinsic co_broadcast + intrinsic co_reduce + integer :: val, i + integer :: vec(3), idx(3) + character(len=30) :: errmsg + integer(8) :: i8 + character(len=19, kind=4) :: msg4 + + interface + pure function red_f(a, b) + integer :: a, b, red_f + intent(in) :: a, b + end function red_f + impure function red_f2(a, b) + integer :: a, b, red_f + intent(in) :: a, b + end function red_f2 + end interface + + call co_broadcast("abc") ! { dg-error "Missing actual argument 'source_image' in call to 'co_broadcast'" } + call co_reduce("abc") ! { dg-error "Missing actual argument 'operation' in call to 'co_reduce'" } + call co_broadcast(1, source_image=1) ! { dg-error "'a' argument of 'co_broadcast' intrinsic at .1. must be a variable" } + call co_reduce(a=1, operation=red_f) ! { dg-error "'a' argument of 'co_reduce' intrinsic at .1. must be a variable" } + call co_reduce(a=val, operation=red_f2) ! { dg-error "OPERATION argument at \\(1\\) must be a PURE function" } + + call co_broadcast(val, source_image=[1,2]) ! { dg-error "must be a scalar" } + call co_broadcast(val, source_image=1.0) ! { dg-error "must be INTEGER" } + call co_broadcast(val, 1, stat=[1,2]) ! { dg-error "must be a scalar" } + call co_broadcast(val, 1, stat=1.0) ! { dg-error "must be INTEGER" } + call co_broadcast(val, 1, stat=1) ! { dg-error "must be a variable" } + call co_broadcast(val, stat=i, source_image=1) ! OK + call co_broadcast(val, stat=i, errmsg=errmsg, source_image=1) ! OK + call co_broadcast(val, stat=i, errmsg=[errmsg], source_image=1) ! { dg-error "must be a scalar" } + call co_broadcast(val, stat=i, errmsg=5, source_image=1) ! { dg-error "must be CHARACTER" } + call co_broadcast(val, 1, errmsg="abc") ! { dg-error "must be a variable" } + call co_broadcast(val, 1, stat=i8) ! { dg-error "The stat= argument at .1. must be a kind=4 integer variable" } + call co_broadcast(val, 1, errmsg=msg4) ! { dg-error "The errmsg= argument at .1. must be a default-kind character variable" } + + call co_reduce(val, red_f, result_image=[1,2]) ! { dg-error "must be a scalar" } + call co_reduce(val, red_f, result_image=1.0) ! { dg-error "must be INTEGER" } + call co_reduce(val, red_f, stat=[1,2]) ! { dg-error "must be a scalar" } + call co_reduce(val, red_f, stat=1.0) ! { dg-error "must be INTEGER" } + call co_reduce(val, red_f, stat=1) ! { dg-error "must be a variable" } + call co_reduce(val, red_f, stat=i, result_image=1) ! OK + call co_reduce(val, red_f, stat=i, errmsg=errmsg, result_image=1) ! OK + call co_reduce(val, red_f, stat=i, errmsg=[errmsg], result_image=1) ! { dg-error "must be a scalar" } + call co_reduce(val, red_f, stat=i, errmsg=5, result_image=1) ! { dg-error "must be CHARACTER" } + call co_reduce(val, red_f, errmsg="abc") ! { dg-error "must be a variable" } + call co_reduce(val, red_f, stat=i8) ! { dg-error "The stat= argument at .1. must be a kind=4 integer variable" } + call co_reduce(val, red_f, errmsg=msg4) ! { dg-error "The errmsg= argument at .1. must be a default-kind character variable" } + + call co_broadcast(vec(idx), 1) ! { dg-error "Argument 'A' with INTENT\\(INOUT\\) at .1. of the intrinsic subroutine co_broadcast shall not have a vector subscript" } + call co_reduce(vec([1,3,2]), red_f) ! { dg-error "Argument 'A' with INTENT\\(INOUT\\) at .1. of the intrinsic subroutine co_reduce shall not have a vector subscript" } +end program test diff --git a/Fortran/gfortran/regression/coarray_critical_1.f90 b/Fortran/gfortran/regression/coarray_critical_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_critical_1.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } +! + +module m + contains + subroutine f() + critical + end critical + end subroutine f + end module m +end program diff --git a/Fortran/gfortran/regression/coarray_data_1.f90 b/Fortran/gfortran/regression/coarray_data_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_data_1.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -lcaf_single " } +! { dg-additional-options "-latomic" { target libatomic_available } } +! PR 71066 - this used to ICE +program p + real :: a(2,2)[*] + integer :: b(2,2)[*] + data a /4*0.0/ + data b /1234, 2345, 3456, 4567/ + if (any (a /= 0.0)) stop 1 + if (any (b /= reshape([1234, 2345, 3456, 4567],[2,2]))) stop 2 +end diff --git a/Fortran/gfortran/regression/coarray_dependency_1.f90 b/Fortran/gfortran/regression/coarray_dependency_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_dependency_1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -lcaf_single" } +! +! Check that reffing x on both sides of a coarray send does not ICE. +! PR 85507 + +program check_dependency + integer :: x[*] + x[42] = x +end program check_dependency + diff --git a/Fortran/gfortran/regression/coarray_event_1.f08 b/Fortran/gfortran/regression/coarray_event_1.f08 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_event_1.f08 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -lcaf_single" } + +! Check that pr70696 is really fixed. + + use iso_fortran_env + type(event_type) :: x[*] + + ! exchange must not be called or the link problem before the patch + ! does not occur. +contains + subroutine exchange + event post (x[1]) + end subroutine +end diff --git a/Fortran/gfortran/regression/coarray_event_2.f08 b/Fortran/gfortran/regression/coarray_event_2.f08 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_event_2.f08 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -lcaf_single" } + +! Check that pr79866 is really fixed. + + use iso_fortran_env + type(event_type) :: x ! { dg-error "of type EVENT_TYPE or with subcomponent of type EVENT_TYPE must be a coarray" } + +contains + subroutine exchange + event post (x[1]) ! { dg-error "Syntax error in EVENT POST statement at .1." } + end subroutine +end diff --git a/Fortran/gfortran/regression/coarray_fail_st.f90 b/Fortran/gfortran/regression/coarray_fail_st.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_fail_st.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -fcoarray=lib" } +! +program fail_statement + implicit none + + integer :: me,np,stat + + me = this_image() + np = num_images() + stat = 0 + + if(me == 1) fail image + + sync all(stat=stat) + + if(stat /= 0) write(*,*) 'Image failed during sync' + +end program fail_statement + +! { dg-final { scan-tree-dump-times "_gfortran_caf_fail_image \\\(\\\);" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_failed_images_1.f08 b/Fortran/gfortran/regression/coarray_failed_images_1.f08 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_failed_images_1.f08 @@ -0,0 +1,30 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original -fcoarray=lib -lcaf_single" } +! { dg-additional-options "-latomic" { target libatomic_available } } + +program test_failed_images_1 + implicit none + + integer :: me,np,stat + character(len=1) :: c + integer, allocatable :: fi(:) + integer(kind=1), allocatable :: sfi(:) + + fi = failed_images() + if (size(fi) > 0) error stop "failed_images result shall be empty array" + if (allocated(fi)) error stop "failed_images result shall not be allocated" + + sfi = failed_images(KIND=1) + if (size(sfi) > 0) error stop "failed_images result shall be empty array" + if (allocated(sfi)) error stop "failed_images result shall not be allocated" + + sfi = failed_images(KIND=8) + if (size(sfi) > 0) error stop "failed_images result shall be empty array" +! The implicit type conversion in the assignment above allocates an array. +! if (allocated(sfi)) error stop "failed_images result shall not be allocated" + +end program test_failed_images_1 + +! { dg-final { scan-tree-dump-times "_gfortran_caf_failed_images \\\(&D\\\.\[0-9\]+, 0B, 0B\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_failed_images \\\(&D\\\.\[0-9\]+, 0B, D\\\.\[0-9\]+\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_failed_images \\\(&D\\\.\[0-9\]+, 0B, D\\\.\[0-9\]+\\\);" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_image_status_1.f08 b/Fortran/gfortran/regression/coarray_image_status_1.f08 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_image_status_1.f08 @@ -0,0 +1,17 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -lcaf_single -fdump-tree-original" } +! { dg-additional-options "-latomic" { target libatomic_available } } + +program test_image_status_1 + use iso_fortran_env , only : STAT_STOPPED_IMAGE + implicit none + + if (image_status(1) /= 0) error stop "image_status(1) should not fail" + if (image_status(42) /= STAT_STOPPED_IMAGE) error stop "image_status(42) should report stopped image" + +end program test_image_status_1 + +! { dg-final { scan-tree-dump-times "_gfortran_caf_image_status \\\(1, .+\\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_image_status \\\(42, .+\\\)" 1 "original" } } + + diff --git a/Fortran/gfortran/regression/coarray_lib_alloc_1.f90 b/Fortran/gfortran/regression/coarray_lib_alloc_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_lib_alloc_1.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -fdump-tree-original" } +! +! Allocate/deallocate with libcaf. +! + + subroutine test() + integer(4), allocatable :: xx[:], yy(:)[:] + integer :: stat + character(len=200) :: errmsg + allocate(xx[*], stat=stat, errmsg=errmsg) + allocate(yy(2)[*], stat=stat, errmsg=errmsg) + deallocate(xx,yy,stat=stat, errmsg=errmsg) + end + +! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(4, 1, &xx.token, \\(void \\*\\) &xx, &stat.., &errmsg, 200\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(8, 1, &yy.token, \\(void \\*\\) &yy, &stat.., &errmsg, 200\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx.token, 0, &stat.., &errmsg, 200.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy.token, 0, &stat.., &errmsg, 200.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy.token, 0, 0B, 0B, 0.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx.token, 0, 0B, 0B, 0.;" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_lib_alloc_2.f90 b/Fortran/gfortran/regression/coarray_lib_alloc_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_lib_alloc_2.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -fdump-tree-original" } +! +! Allocate/deallocate with libcaf. +! + + subroutine test() + type t + end type t + class(t), allocatable :: xx[:], yy(:)[:] + integer :: stat + character(len=200) :: errmsg + allocate(xx[*], stat=stat, errmsg=errmsg) + allocate(yy(2)[*], stat=stat, errmsg=errmsg) + deallocate(xx,yy,stat=stat, errmsg=errmsg) + end + +! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(1, 1, &xx._data.token, \\(void \\*\\) &xx._data, &stat.., &errmsg, 200\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(1, 1, &yy._data.token, \\(void \\*\\) &yy._data, &stat.., &errmsg, 200\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, 0, &stat.., &errmsg, 200.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0, &stat.., &errmsg, 200.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0, 0B, 0B, 0.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, 0, 0B, 0B, 0.;" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_lib_alloc_3.f90 b/Fortran/gfortran/regression/coarray_lib_alloc_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_lib_alloc_3.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -fdump-tree-original" } +! +! Allocate/deallocate with libcaf. +! +! As coarray_lib_alloc_2.f90 but for a subroutine instead of the PROGRAM +! +subroutine test + type t + end type t + class(t), allocatable :: xx[:], yy(:)[:] + integer :: stat + character(len=200) :: errmsg + allocate(xx[*], stat=stat, errmsg=errmsg) + allocate(yy(2)[*], stat=stat, errmsg=errmsg) + deallocate(xx,yy,stat=stat, errmsg=errmsg) + end + +! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(1, 1, &xx._data.token, \\(void \\*\\) &xx._data, &stat.., &errmsg, 200\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(1, 1, &yy._data.token, \\(void \\*\\) &yy._data, &stat.., &errmsg, 200\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, 0, &stat.., &errmsg, 200.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0, &stat.., &errmsg, 200.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&yy._data.token, 0, 0B, 0B, 0.;" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister .&xx._data.token, 0, 0B, 0B, 0.;" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_lib_alloc_4.f90 b/Fortran/gfortran/regression/coarray_lib_alloc_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_lib_alloc_4.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -lcaf_single -fdump-tree-original" } +! { dg-additional-options "-latomic" { target libatomic_available } } +! +! Allocate/deallocate with libcaf. +! + +program test_caf_alloc + + type t + integer, allocatable :: i + real, allocatable :: r(:) + end type t + + type(t), allocatable :: xx[:] + + allocate (xx[*]) + + if (allocated(xx%i)) STOP 1 + if (allocated(xx[1]%i)) STOP 2 + if (allocated(xx[1]%r)) STOP 3 + allocate(xx%i) + if (.not. allocated(xx[1]%i)) STOP 4 + if (allocated(xx[1]%r)) STOP 5 + + allocate(xx%r(5)) + if (.not. allocated(xx[1]%i)) STOP 6 + if (.not. allocated(xx[1]%r)) STOP 7 + + deallocate(xx%i) + if (allocated(xx[1]%i)) STOP 8 + if (.not. allocated(xx[1]%r)) STOP 9 + + deallocate(xx%r) + if (allocated(xx[1]%i)) STOP 10 + if (allocated(xx[1]%r)) STOP 11 + + deallocate(xx) +end + +! { dg-final { scan-tree-dump-times "_gfortran_caf_is_present \\(xx\\.token, \\(integer\\(kind=4\\)\\) \\(2 - xx\\.dim\\\[0\\\]\\.lbound\\), &caf_ref\\.\[0-9\]+\\)|_gfortran_caf_is_present \\(xx\\.token, 2 - xx\\.dim\\\[0\\\]\\.lbound, &caf_ref\\.\[0-9\]+\\)" 10 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(\[0-9\]+, 1, &xx\\.token, \\(void \\*\\) &xx, 0B, 0B, 0\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(\[0-9\]+, 7" 2 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(\[0-9\]+, 8" 2 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister \\(&xx\\.token, 0, 0B, 0B, 0\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister \\(&\\(\\(struct t \\* restrict\\) xx\\.data\\)->r\\.token, 1, 0B, 0B, 0\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister \\(&\\(\\(struct t \\* restrict\\) xx\\.data\\)->_caf_i, 1, 0B, 0B, 0\\)" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_lib_comm_1.f90 b/Fortran/gfortran/regression/coarray_lib_comm_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_lib_comm_1.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original -fcoarray=lib -lcaf_single" } +! { dg-additional-options "-latomic" { target libatomic_available } } +! +! Some dependency-analysis check for coarray communication +! +integer, target, save :: A(10)[*] +integer, pointer :: P(:) +integer, save :: B(10)[*] + +A = [1,2,3,4,5,6,7,8,9,10] +B = [1,2,3,4,5,6,7,8,9,10] +A(10:2:-1) = A(9:1:-1)[1] ! 0 +B(10:2:-1) = B(9:1:-1) +if (any (A-B /= 0)) STOP 1 + +A = [1,2,3,4,5,6,7,8,9,10] +B = [1,2,3,4,5,6,7,8,9,10] +A(9:1:-1) = A(10:2:-1)[1] ! 1 +B(9:1:-1) = B(10:2:-1) +if (any (A-B /= 0)) STOP 2 + +A = [1,2,3,4,5,6,7,8,9,10] +B = [1,2,3,4,5,6,7,8,9,10] +allocate(P(10)) +P(:) = A(:)[1] ! 1 +if (any (A-B /= 0)) STOP 3 + +A = [1,2,3,4,5,6,7,8,9,10] +B = [1,2,3,4,5,6,7,8,9,10] +allocate(P(10)) +P(:) = B(:)[1] ! 0 + +A = [1,2,3,4,5,6,7,8,9,10] +B = [1,2,3,4,5,6,7,8,9,10] +A(1:5)[1] = A(3:7)[1] ! 1 +B(1:5) = B(3:7) +if (any (A-B /= 0)) STOP 4 +end + +! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, &parm.\[0-9\]+, 4, 4, 1, 0B\\\);" 3 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.1, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) b, 1, &parm.\[0-9\]+, 0B, &parm.\[0-9\]+, 4, 4, 0, 0B\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_sendget \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) parm.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) a, 1, &parm.\[0-9\]+, 0B, 4, 4, 1, 0B\\\);" 1 "original" } } + diff --git a/Fortran/gfortran/regression/coarray_lib_move_alloc_1.f90 b/Fortran/gfortran/regression/coarray_lib_move_alloc_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_lib_move_alloc_1.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -fdump-tree-original" } +! +! PR fortran/53526 +! +! Check handling of move_alloc with coarrays + +subroutine ma_scalar (aa, bb) + integer, allocatable :: aa[:], bb[:] + call move_alloc(aa,bb) +end + +subroutine ma_array (cc, dd) + integer, allocatable :: cc(:)[:], dd(:)[:] + call move_alloc (cc, dd) +end + +! { dg-final { scan-tree-dump-times "free" 0 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_sync_all" 2 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister" 2 "original" } } +! { dg-final { scan-tree-dump-times "\\*bb = \\*aa" 1 "original" } } +! { dg-final { scan-tree-dump-times "\\*dd = \\*cc" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_lib_realloc_1.f90 b/Fortran/gfortran/regression/coarray_lib_realloc_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_lib_realloc_1.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -fcoarray=lib" } +! +! PR fortran/52052 +! +! Test that for CAF components _gfortran_caf_deregister is called +! Test that norealloc happens for CAF components during assignment +! +module m +type t + integer, allocatable :: CAF[:] + integer, allocatable :: ii +end type t +end module m + +subroutine foo() +use m +type(t) :: x,y +if (allocated(x%caf)) STOP 1 +x = y +end + +! For comp%ii: End of scope of x + y (2x) and for the LHS of the assignment (1x) +! { dg-final { scan-tree-dump-times "__builtin_free" 6 "original" } } + +! For comp%CAF: End of scope of x + y (2x); no LHS freeing for the CAF in assignment +! { dg-final { scan-tree-dump-times "_gfortran_caf_deregister" 3 "original" } } + +! Only malloc "ii": +! { dg-final { scan-tree-dump-times "__builtin_malloc" 4 "original" } } + +! But copy "ii" and "CAF": +! { dg-final { scan-tree-dump-times "__builtin_memcpy|= MEM" 5 "original" } } + diff --git a/Fortran/gfortran/regression/coarray_lib_this_image_1.f90 b/Fortran/gfortran/regression/coarray_lib_this_image_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_lib_this_image_1.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -fdump-tree-original" } +! + + implicit none + real :: x(2)[*] + call bar(x) +contains + subroutine bar(x) + integer :: mylcobound, myucobound, mylbound, mythis_image + real :: x(2)[5:*] + mylcobound = lcobound(x,dim=1) + myucobound = ucobound(x,dim=1) + mylbound = lbound(x,dim=1) + mythis_image = this_image() + end subroutine bar +end + +! { dg-final { scan-tree-dump-times "bar \\(real\\(kind=4\\)\\\[2\\\] \\* restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "mylcobound = 5;" 1 "original" } } +! { dg-final { scan-tree-dump-times "parm...dim\\\[1\\\].lbound = 5;" 1 "original" } } +! { dg-final { scan-tree-dump-times "myucobound =\[^\n\r\]* parm...dim\\\[1\\\].lbound \\+ \[^\n\r]*_gfortran_caf_num_images \\(0, -1\\).? \\+ -?\[0-9\]+\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "mylbound = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "mythis_image = _gfortran_caf_this_image \\(0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "bar \\(x, caf_token.., 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_init \\(&argc, &argv\\);" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_lib_this_image_2.f90 b/Fortran/gfortran/regression/coarray_lib_this_image_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_lib_this_image_2.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -fdump-tree-original" } +! + + implicit none + real :: x(2)[*] + call bar(x) +contains + subroutine bar(x) + integer :: mylcobound, myucobound, mylbound, mythis_image + real :: x(:)[5:*] + mylcobound = lcobound(x,dim=1) + myucobound = ucobound(x,dim=1) + mylbound = lbound(x,dim=1) + mythis_image = this_image() + end subroutine bar +end + +! { dg-final { scan-tree-dump-times "bar \\(struct array01_real\\(kind=4\\) & restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "mylcobound = 5;" 1 "original" } } +! { dg-final { scan-tree-dump-times "parm...dim\\\[1\\\].lbound = 5;" 1 "original" } } +! { dg-final { scan-tree-dump-times "myucobound =\[^\n\r\]* parm...dim\\\[1\\\].lbound \\+ \[^\n\r\]*_gfortran_caf_num_images \\(0, -1\\).? \\+ -?\[0-9\]+\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "mylbound = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "mythis_image = _gfortran_caf_this_image \\(0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "bar \\(&parm.\[0-9\]+, caf_token.\[0-9\]+, \\(integer\\(kind=\[48\]\\)\\) parm.\[0-9\]+.data - \\(integer\\(kind=\[48\]\\)\\) x\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_init \\(&argc, &argv\\);" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_lib_token_1.f90 b/Fortran/gfortran/regression/coarray_lib_token_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_lib_token_1.f90 @@ -0,0 +1,87 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -fdump-tree-original" } +! +! Check whether TOKEN and OFFSET are correctly propagated +! + +program main + implicit none + type t + integer(4) :: a, b + end type t + integer :: caf[*] + type(t) :: caf_dt[*] + + caf = 42 + caf_dt = t (1,2) + call sub (caf, caf_dt%b) + print *,caf, caf_dt%b + if (caf /= -99 .or. caf_dt%b /= -101) STOP 1 + call sub_opt () + call sub_opt (caf) + if (caf /= 124) STOP 2 +contains + + subroutine sub (x1, x2) + integer :: x1[*], x2[*] + + call sub2 (x1, x2) + end subroutine sub + + subroutine sub2 (y1, y2) + integer :: y1[*], y2[*] + + print *, y1, y2 + if (y1 /= 42 .or. y2 /= 2) STOP 3 + y1 = -99 + y2 = -101 + end subroutine sub2 + + subroutine sub_opt (z) + integer, optional :: z[*] + if (present (z)) then + if (z /= -99) STOP 4 + z = 124 + end if + end subroutine sub_opt + +end program main + +! SCAN TREE DUMP AND CLEANUP +! +! PROTOTYPE 1: +! +! sub (integer(kind=4) * restrict x1, integer(kind=4) * restrict x2, +! void * restrict caf_token.4, integer(kind=8) caf_offset.5, +! void * restrict caf_token.6, integer(kind=8) caf_offset.7) +! +! { dg-final { scan-tree-dump-times "sub \\(integer.kind=4. . restrict x1, integer.kind=4. . restrict x2, void . restrict caf_token.\[0-9\]+, integer.kind=.. caf_offset.\[0-9\]+, void . restrict caf_token.\[0-9\]+, integer.kind=.. caf_offset.\[0-9\]+\\)" 1 "original" } } +! +! PROTOTYPE 2: +! +! sub2 (integer(kind=4) * restrict y1, integer(kind=4) * restrict y2, +! void * restrict caf_token.0, integer(kind=8) caf_offset.1, +! void * restrict caf_token.2, integer(kind=8) caf_offset.3) +! +! { dg-final { scan-tree-dump-times "sub2 \\(integer.kind=4. . restrict y1, integer.kind=4. . restrict y2, void . restrict caf_token.\[0-9\]+, integer.kind=.. caf_offset.\[0-9\]+, void . restrict caf_token.\[0-9\]+, integer.kind=.. caf_offset.\[0-9\]+\\)" 1 "original" } } +! +! CALL 1 +! +! sub ((integer(kind=4) *) caf, &caf_dt->b, caf_token.9, 0, caf_token.10, 4); +! +! { dg-final { scan-tree-dump-times "sub \\(\[^,\]*caf, &caf_dt->b, caf_token.\[0-9\]+, 0, caf_token.\[0-9\]+, 4\\)" 1 "original" } } +! +! sub2 ((integer(kind=4) *) x1, (integer(kind=4) *) x2, +! caf_token.4, NON_LVALUE_EXPR , +! caf_token.6, NON_LVALUE_EXPR ); +! +! { dg-final { scan-tree-dump-times "sub2 \\(\[^,\]*x1, \[^,\]*x2, caf_token.\[0-9]+, \[^,\]*caf_offset\[^,\]*, caf_token.\[0-9\]+, \[^,\]*caf_offset\[^,\]*\\)" 1 "original" } } +! +! CALL 3 +! +! { dg-final { scan-tree-dump-times "sub_opt \\(0B, 0B, 0\\)" 1 "original" } } +! +! CALL 4 +! +! { dg-final { scan-tree-dump-times "sub_opt \\(.integer.kind=4. .. caf, caf_token.\[0-9\]+, 0\\)" 1 "original" } } +! diff --git a/Fortran/gfortran/regression/coarray_lib_token_2.f90 b/Fortran/gfortran/regression/coarray_lib_token_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_lib_token_2.f90 @@ -0,0 +1,114 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -fdump-tree-original" } +! +! Check whether TOKEN and OFFSET are correctly propagated +! + +! THIS PART FAILED (ICE) DUE TO TYPE SHARING + +module matrix_data + implicit none + type sparse_CSR_matrix + integer, allocatable :: a(:) + end type sparse_CSR_matrix +CONTAINS + +subroutine build_CSR_matrix(CSR) + type(sparse_CSR_matrix), intent(out) :: CSR + integer, allocatable :: CAF_begin[:] + call global_to_local_index(CAF_begin) +end subroutine build_CSR_matrix + +subroutine global_to_local_index(CAF_begin) + integer, intent(out) :: CAF_begin[*] +end subroutine global_to_local_index + +end module matrix_data + + +! DUMP TESTING + +program main + implicit none + type t + integer(4) :: a, b + end type t + integer, allocatable :: caf[:] + type(t), allocatable :: caf_dt[:] + + allocate (caf[*]) + allocate (caf_dt[*]) + + caf = 42 + caf_dt = t (1,2) + call sub (caf, caf_dt%b) + print *,caf, caf_dt%b + if (caf /= -99 .or. caf_dt%b /= -101) STOP 1 + call sub_opt () + call sub_opt (caf) + if (caf /= 124) STOP 2 +contains + + subroutine sub (x1, x2) + integer :: x1[*], x2[*] + call sub2 (x1, x2) + end subroutine sub + + subroutine sub2 (y1, y2) + integer :: y1[*], y2[*] + + print *, y1, y2 + if (y1 /= 42 .or. y2 /= 2) STOP 3 + y1 = -99 + y2 = -101 + end subroutine sub2 + + subroutine sub_opt (z) + integer, optional :: z[*] + if (present (z)) then + if (z /= -99) STOP 4 + z = 124 + end if + end subroutine sub_opt + +end program main + +! SCAN TREE DUMP AND CLEANUP +! +! PROTOTYPE 1: +! +! sub (integer(kind=4) * restrict x1, integer(kind=4) * restrict x2, +! void * restrict caf_token.4, integer(kind=8) caf_offset.5, +! void * restrict caf_token.6, integer(kind=8) caf_offset.7) +! +! { dg-final { scan-tree-dump-times "sub \\(integer.kind=4. . restrict x1, integer.kind=4. . restrict x2, void . restrict caf_token.\[0-9\]+, integer.kind=.. caf_offset.\[0-9\]+, void . restrict caf_token.\[0-9\]+, integer.kind=.. caf_offset.\[0-9\]+\\)" 1 "original" } } +! +! PROTOTYPE 2: +! +! sub2 (integer(kind=4) * restrict y1, integer(kind=4) * restrict y2, +! void * restrict caf_token.0, integer(kind=8) caf_offset.1, +! void * restrict caf_token.2, integer(kind=8) caf_offset.3) +! +! { dg-final { scan-tree-dump-times "sub2 \\(integer.kind=4. . restrict y1, integer.kind=4. . restrict y2, void . restrict caf_token.\[0-9\]+, integer.kind=.. caf_offset.\[0-9\]+, void . restrict caf_token.\[0-9\]+, integer.kind=.. caf_offset.\[0-9\]+\\)" 1 "original" } } +! +! CALL 1 +! +! sub ((integer(kind=4) *) caf.data, &((struct t * restrict) caf_dt.data)->b, +! caf.token, 0, caf_dt.token, 4); +! +! { dg-final { scan-tree-dump-times "sub \\(\[^,\]*caf.data, &\[^,\]*caf_dt.data.->b, caf.token, 0, caf_dt.token, 4\\)" 1 "original" } } +! +! sub2 ((integer(kind=4) *) x1, (integer(kind=4) *) x2, +! caf_token.4, NON_LVALUE_EXPR , +! caf_token.6, NON_LVALUE_EXPR ); +! +! { dg-final { scan-tree-dump-times "sub2 \\(\[^,\]*x1, \[^,\]*x2, caf_token.\[0-9]+, \[^,\]*caf_offset\[^,\]*, caf_token.\[0-9\]+, \[^,\]*caf_offset\[^,\]*\\)" 1 "original" } } +! +! CALL 3 +! +! { dg-final { scan-tree-dump-times "sub_opt \\(0B, 0B, 0\\)" 1 "original" } } +! +! CALL 4 +! +! { dg-final { scan-tree-dump-times "sub_opt \\(.integer.kind=4. .. caf.data, caf.token, 0\\)" 1 "original" } } +! diff --git a/Fortran/gfortran/regression/coarray_lib_token_3.f90 b/Fortran/gfortran/regression/coarray_lib_token_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_lib_token_3.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -fdump-tree-original" } +! +! Test coarray registering +! +integer, allocatable :: CAF(:)[:], caf_scalar[:] +allocate(CAF(1)[*]) +allocate(CAF_SCALAR[*]) +end + +! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(4, 1, &caf.token, \\(void \\*\\) &caf, 0B, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(4, 1, &caf_scalar.token, \\(void \\*\\) &caf_scalar, 0B, 0B, 0\\);" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_lib_token_4.f90 b/Fortran/gfortran/regression/coarray_lib_token_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_lib_token_4.f90 @@ -0,0 +1,51 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -fdump-tree-original" } +! +! Check argument passing with assumed-shape coarray dummies +! +program test_caf + implicit none + integer, allocatable :: A(:)[:] + integer, save :: B(3)[*] + integer :: i + + allocate (A(3)[*]) + A = [1, 2, 3 ] + B = [9, 7, 4 ] + call foo (A, A, test=1) + call foo (A(2:3), B, test=2) + call foo (B, A, test=3) +contains + subroutine foo(x, y, test) + integer :: x(:)[*] + integer, contiguous :: y(:)[*] + integer :: test + call bar (x) + call expl (y) + end subroutine foo + + subroutine bar(y) + integer :: y(:)[*] + end subroutine bar + + subroutine expl(z) + integer :: z(*)[*] + end subroutine expl +end program test_caf + +! { dg-final { scan-tree-dump-times "expl \\(integer\\(kind=4\\).0:. . restrict z, void . restrict caf_token.\[0-9\]+, integer\\(kind=.\\) caf_offset.\[0-9\]+\\)" 1 "original" } } +! +! { dg-final { scan-tree-dump-times "bar \\(struct array01_integer\\(kind=4\\) & restrict y, void . restrict caf_token.\[0-9\]+, integer\\(kind=.\\) caf_offset.\[0-9\]+\\)" 1 "original" } } +! +! { dg-final { scan-tree-dump-times "foo \\(struct array01_integer\\(kind=4\\) & restrict x, struct array01_integer\\(kind=4\\) & restrict y, integer\\(kind=4\\) & restrict test, void . restrict caf_token.\[0-9\]+, integer\\(kind=.\\) caf_offset.\[0-9\]+, void . restrict caf_token.\[0-9\]+, integer\\(kind=.\\) caf_offset.\[0-9\]+\\)" 1 "original" } } +! +! { dg-final { scan-tree-dump-times "bar \\(&parm.\[0-9\]+, caf_token.\[0-9\]+, \\(\\(integer\\(kind=.\\)\\) parm.\[0-9\]+.data - \\(integer\\(kind=.\\)\\) x.\[0-9\]+\\) \\+ caf_offset.\[0-9\]+\\);" 1 "original" } } +! +! { dg-final { scan-tree-dump-times "expl \\(\\(integer\\(kind=4\\).0:. .\\) parm.\[0-9\]+.data, caf_token.\[0-9\]+, \\(\\(integer\\(kind=.\\)\\) parm.\[0-9\]+.data - \\(\\(integer\\(kind=.\\)\\) y.\[0-9\]+\\) \\+ caf_offset.\[0-9\]+\\);" 0 "original" } } +! +! { dg-final { scan-tree-dump-times "foo \\(&a, &a, &C.\[0-9\]+, a.token, 0, a.token, 0\\);" 1 "original" } } +! +! { dg-final { scan-tree-dump-times "foo \\(&parm.\[0-9\]+, &parm.\[0-9\]+, &C.\[0-9\]+, a.token, \\(integer\\(kind=.\\)\\) parm.\[0-9\]+.data - \\(integer\\(kind=.\\)\\) a.data, caf_token.\[0-9\]+, \\(integer\\(kind=.\\)\\) parm.\[0-9\]+.data - \\(integer\\(kind=.\\)\\) b\\);" 1 "original" } } +! +! { dg-final { scan-tree-dump-times "foo \\(&parm.\[0-9\]+, &a, &C.\[0-9\]+, caf_token.\[0-9\]+, \\(integer\\(kind=.\\)\\) parm.\[0-9\]+.data - \\(integer\\(kind=.\\)\\) b, a.token, 0\\);" 1 "original" } } +! diff --git a/Fortran/gfortran/regression/coarray_lock_1.f90 b/Fortran/gfortran/regression/coarray_lock_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_lock_1.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single -std=f2008" } +! +! LOCK/UNLOCK intrinsics +! +! PR fortran/18918 +! +integer :: a[*] +integer :: s +character(len=3) :: c +logical :: bool + +LOCK (a, stat=s, acquired_lock=bool, errmsg=c) ! { dg-error "must be a scalar of type LOCK_TYPE" } +UNLOCK (a, stat=s, errmsg=c) ! { dg-error "must be a scalar of type LOCK_TYPE" } +end diff --git a/Fortran/gfortran/regression/coarray_lock_2.f90 b/Fortran/gfortran/regression/coarray_lock_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_lock_2.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single -std=f2003" } +! +! LOCK/UNLOCK intrinsics +! +! PR fortran/18918 +! +integer :: a[*] ! { dg-error "Fortran 2008: Coarray declaration" } +integer :: s +character(len=3) :: c +logical :: bool + +LOCK (a, stat=s, acquired_lock=bool, errmsg=c) ! { dg-error "Fortran 2008: LOCK statement" } +UNLOCK (a, stat=s, errmsg=c) ! { dg-error "Fortran 2008: UNLOCK statement" } +end diff --git a/Fortran/gfortran/regression/coarray_lock_3.f90 b/Fortran/gfortran/regression/coarray_lock_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_lock_3.f90 @@ -0,0 +1,115 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! +! LOCK/LOCK_TYPE checks +! +subroutine extends() +use iso_fortran_env +type t +end type t +type, extends(t) :: t2 ! { dg-error "coarray component, parent type .t. shall also have one" } + type(lock_type), allocatable :: c(:)[:] +end type t2 +end subroutine extends + +module m + use iso_fortran_env + + type t + type(lock_type), allocatable :: x(:)[:] + end type t +end module m + +module m2 + use iso_fortran_env + type t2 + type(lock_type), allocatable :: x ! { dg-error "Allocatable component x at .1. of type LOCK_TYPE must have a codimension" } + end type t2 +end module m2 + +module m3 + use iso_fortran_env + type t3 + type(lock_type) :: x ! OK + end type t3 +end module m3 + +subroutine sub(x) + use iso_fortran_env + type(lock_type), intent(out) :: x[*] ! OK +end subroutine sub + +subroutine sub1(x) ! { dg-error "is INTENT.OUT. and can thus not be an allocatable coarray or have coarray components" } + use iso_fortran_env + type(lock_type), allocatable, intent(out) :: x(:)[:] +end subroutine sub1 + +subroutine sub2(x) ! { dg-error "is INTENT.OUT. and can thus not be an allocatable coarray or have coarray components" } + use m + type(t), intent(out) :: x +end subroutine sub2 + +subroutine sub3(x) ! { dg-error "with coarray component shall be a nonpointer, nonallocatable scalar" } + use m + type(t), intent(inout) :: x[*] +end subroutine sub3 + +subroutine sub4(x) + use m3 + type(t3), intent(inout) :: x[*] ! OK +end subroutine sub4 + +subroutine lock_test + use iso_fortran_env + type t + end type t + type(lock_type) :: lock ! { dg-error "of type LOCK_TYPE or with subcomponent of type LOCK_TYPE must be a coarray" } +end subroutine lock_test + +subroutine lock_test2 + use iso_fortran_env + implicit none + type t + end type t + type(t) :: x + type(lock_type), save :: lock[*],lock2(2)[*] + lock(t) ! { dg-error "Syntax error in LOCK statement" } + lock(x) ! { dg-error "must be a scalar of type LOCK_TYPE" } + lock(lock) + lock(lock2(1)) + lock(lock2) ! { dg-error "must be a scalar of type LOCK_TYPE" } + lock(lock[1]) ! OK +end subroutine lock_test2 + + +subroutine lock_test3 + use iso_fortran_env + type(lock_type), save :: a[*], b[*] + a = b ! { dg-error "LOCK_TYPE in variable definition context" } + b = lock_type() ! { dg-error "LOCK_TYPE in variable definition context" } + print *, a ! { dg-error "cannot have PRIVATE components" } +end subroutine lock_test3 + + +subroutine lock_test4 + use iso_fortran_env + type(lock_type), allocatable :: A(:)[:] + logical :: ob + allocate(A(1)[*]) + lock(A(1), acquired_lock=ob) + unlock(A(1)) + deallocate(A) +end subroutine lock_test4 + + +subroutine argument_check() + use iso_fortran_env + type(lock_type), SAVE :: ll[*] + call no_interface(ll) ! { dg-error "Actual argument of LOCK_TYPE or with LOCK_TYPE component at .1. requires an explicit interface" } + call test(ll) ! { dg-error "non-INTENT.INOUT. dummy .x. at .1., which is LOCK_TYPE or has a LOCK_TYPE component" } +contains + subroutine test(x) + type(lock_type), intent(in) :: x[*] + end subroutine test +end subroutine argument_check diff --git a/Fortran/gfortran/regression/coarray_lock_4.f90 b/Fortran/gfortran/regression/coarray_lock_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_lock_4.f90 @@ -0,0 +1,64 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! +! LOCK/LOCK_TYPE checks +! + +subroutine valid() + use iso_fortran_env + implicit none + type t + type(lock_type) :: lock + end type t + + type t2 + type(lock_type), allocatable :: lock(:)[:] + end type t2 + + type(t), save :: a[*] + type(t2), save :: b ! OK + + allocate(b%lock(1)[*]) + LOCK(a%lock) ! OK + LOCK(a[1]%lock) ! OK + + LOCK(b%lock(1)) ! OK + LOCK(b%lock(1)[1]) ! OK +end subroutine valid + +subroutine invalid() + use iso_fortran_env + implicit none + type t + type(lock_type) :: lock + end type t + type(t), save :: a ! { dg-error "type LOCK_TYPE or with subcomponent of type LOCK_TYPE must be a coarray" } +end subroutine invalid + +subroutine more_tests + use iso_fortran_env + implicit none + type t + type(lock_type) :: a ! OK + end type t + + type t1 + type(lock_type), allocatable :: c2(:)[:] ! OK + end type t1 + type(t1) :: x1 ! OK + + type t2 + type(lock_type), allocatable :: c1(:) ! { dg-error "Allocatable component c1 at .1. of type LOCK_TYPE must have a codimension" } + end type t2 + + type t3 + type(t) :: b + end type t3 + type(t3) :: x3 ! { dg-error "of type LOCK_TYPE or with subcomponent of type LOCK_TYPE must be a coarray" } + + type t4 + type(lock_type) :: c0(2) + end type t4 + type(t4) :: x4 ! { dg-error "of type LOCK_TYPE or with subcomponent of type LOCK_TYPE must be a coarray" } +end subroutine more_tests diff --git a/Fortran/gfortran/regression/coarray_lock_5.f90 b/Fortran/gfortran/regression/coarray_lock_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_lock_5.f90 @@ -0,0 +1,51 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! LOCK_TYPE checks +! +module m3 + use iso_fortran_env + type, extends(lock_type) :: lock + integer :: j = 7 + end type lock +end module m3 + +use m3 +type(lock_type) :: tl[*] = lock_type () +type(lock) :: t[*] +tl = lock_type () ! { dg-error "variable definition context" } +print *,t%j +end + +subroutine test() + use iso_fortran_env + type t + type(lock_type) :: lock + end type t + + type t2 + type(t), pointer :: x ! { dg-error "Pointer component x at .1. has a noncoarray subcomponent of type LOCK_TYPE, which must have a codimension or be a subcomponent of a coarray" } + end type t2 +end subroutine test + +subroutine test2() + use iso_fortran_env + implicit none + type t + type(lock_type), allocatable :: lock ! { dg-error "Allocatable component lock at .1. of type LOCK_TYPE must have a codimension" } + end type t + type t2 + type(lock_type) :: lock + end type t2 + type t3 + type(t2), allocatable :: lock_cmp + end type t3 + type t4 + integer, allocatable :: a[:] + type(t2) :: b ! { dg-error "Noncoarray component b at .1. of type LOCK_TYPE or with subcomponent of type LOCK_TYPE must have a codimension or be a subcomponent of a coarray. .Variables of type t4 may not have a codimension as already a coarray subcomponent exists." } + end type t4 + type t5 + type(t2) :: c ! { dg-error "Noncoarray component c at .1. of type LOCK_TYPE or with subcomponent of type LOCK_TYPE must have a codimension or be a subcomponent of a coarray. .Variables of type t5 may not have a codimension as d at .2. has a codimension or a coarray subcomponent." } + integer, allocatable :: d[:] ! { dg-error "Noncoarray component c at .1. of type LOCK_TYPE or with subcomponent of type LOCK_TYPE must have a codimension or be a subcomponent of a coarray. .Variables of type t5 may not have a codimension as d at .2. has a codimension or a coarray subcomponent." } + end type t5 +end subroutine test2 diff --git a/Fortran/gfortran/regression/coarray_lock_6.f90 b/Fortran/gfortran/regression/coarray_lock_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_lock_6.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } +! +! +use iso_fortran_env +implicit none + +type t1 + type(lock_type), allocatable :: x[:] +end type t1 + +type t2 + type(lock_type) :: x +end type t2 + +type(t1) :: a +type(t2) :: b[*] +!class(lock_type), allocatable :: cl[:] + +lock(a%x) ! { dg-error "the lock component of derived type at \\(1\\) is not yet supported" } +lock(b%x) ! { dg-error "the lock component of derived type at \\(1\\) is not yet supported" } +!lock(cl) + +unlock(a%x) ! { dg-error "the lock component of derived type at \\(1\\) is not yet supported" } +unlock(b%x) ! { dg-error "the lock component of derived type at \\(1\\) is not yet supported" } +!unlock(cl) +end diff --git a/Fortran/gfortran/regression/coarray_lock_7.f90 b/Fortran/gfortran/regression/coarray_lock_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_lock_7.f90 @@ -0,0 +1,46 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -fcoarray=lib" } +! +use iso_fortran_env +implicit none + +type(lock_type) :: one[*] +type(lock_type) :: two(5,5)[*] +type(lock_type), allocatable :: three[:] +type(lock_type), allocatable :: four(:)[:] +integer :: ii +logical :: ll + +allocate(three[*], stat=ii) +allocate(four(7)[*], stat=ii) + +lock(one) +unlock(one) + +lock(two(3,3), stat=ii) +unlock(two(2,3), stat=ii) + +lock(three[4], acquired_lock=ll) +unlock(three[7], stat=ii) + +lock(four(1)[6], acquired_lock=ll, stat=ii) +unlock(four(2)[7]) +end + +! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(1, 2, \\(void \\* \\*\\) &caf_token.., \\(void \\*\\) &desc.., 0B, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(25, 2, \\(void \\* \\*\\) &caf_token.., \\(void \\*\\) &desc.., 0B, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(1, 3, &three.token, \\(void \\*\\) &three, &stat.., 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(7, 3, &four.token, \\(void \\*\\) &four, &stat.., 0B, 0\\);" 1 "original" } } + +! { dg-final { scan-tree-dump-times "_gfortran_caf_lock \\(caf_token.., 0, 0, 0B, 0B, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_unlock \\(caf_token.., 0, 0, 0B, 0B, 0\\);" 1 "original" } } + +! { dg-final { scan-tree-dump-times "_gfortran_caf_lock \\(caf_token.., .*\\(\\(3 - parm.\\d+.dim\\\[0\\\].lbound\\) \\+ \\(MAX_EXPR \\+ 1\\) \\* \\(3 - parm.\\d+.dim\\\[1\\\].lbound\\)\\), 0, 0B, &ii, 0B, 0\\);|_gfortran_caf_lock \\(caf_token.1, \\(3 - parm.\\d+.dim\\\[0\\\].lbound\\) \\+ \\(MAX_EXPR \\+ 1\\) \\* \\(3 - parm.\\d+.dim\\\[1\\\].lbound\\), 0, 0B, &ii, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_unlock \\(caf_token.., .*\\(\\(2 - parm.\\d+.dim\\\[0\\\].lbound\\) \\+ \\(MAX_EXPR \\+ 1\\) \\* \\(3 - parm.\\d+.dim\\\[1\\\].lbound\\)\\), 0, &ii, 0B, 0\\);|_gfortran_caf_unlock \\(caf_token.., \\(2 - parm.\\d+.dim\\\[0\\\].lbound\\) \\+ \\(MAX_EXPR \\+ 1\\) \\* \\(3 - parm.\\d+.dim\\\[1\\\].lbound\\), 0, &ii, 0B, 0\\);" 1 "original" } } + +! { dg-final { scan-tree-dump-times "_gfortran_caf_lock \\(three.token, 0, \\(integer\\(kind=4\\)\\) \\(5 - three.dim\\\[0\\\].lbound\\), &acquired.\[0-9\]+, 0B, 0B, 0\\);|_gfortran_caf_lock \\(three.token, 0, 5 - three.dim\\\[0\\\].lbound, &acquired.\[0-9\]+, 0B, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_unlock \\(three.token, 0, \\(integer\\(kind=4\\)\\) \\(8 - three.dim\\\[0\\\].lbound\\), &ii, 0B, 0\\);|_gfortran_caf_unlock \\(three.token, 0, 8 - three.dim\\\[0\\\].lbound, &ii, 0B, 0\\);" 1 "original" } } + +! { dg-final { scan-tree-dump-times "_gfortran_caf_lock \\(four.token, .*\\(1 - four.dim\\\[0\\\].lbound\\), \\(integer\\(kind=4\\)\\) \\(7 - four.dim\\\[1\\\].lbound\\), &acquired.\[0-9\]+, &ii, 0B, 0\\);|_gfortran_caf_lock \\(four.token, \[^\n\r]*1 - four.dim\\\[0\\\].lbound\\)?, 7 - four.dim\\\[1\\\].lbound, &acquired.\[0-9\]+, &ii, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_unlock \\(four.token, .*\\(2 - four.dim\\\[0\\\].lbound\\), \\(integer\\(kind=4\\)\\) \\(8 - four.dim\\\[1\\\].lbound\\), 0B, 0B, 0\\);|_gfortran_caf_unlock \\(four.token, \[^\n\r]*2 - four.dim\\\[0\\\].lbound\\)?, 8 - four.dim\\\[1\\\].lbound, 0B, 0B, 0\\);" 1 "original" } } + diff --git a/Fortran/gfortran/regression/coarray_poly_1.f90 b/Fortran/gfortran/regression/coarray_poly_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_poly_1.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! Test for polymorphic coarrays +! +subroutine s2() + type t + end type t + class(t) :: A(:)[4,2:*] ! { dg-error "is not ALLOCATABLE, SAVE nor a dummy argument" } + print *, ucobound(a) + allocate(a) ! { dg-error "must be ALLOCATABLE or a POINTER" } +end + diff --git a/Fortran/gfortran/regression/coarray_poly_2.f90 b/Fortran/gfortran/regression/coarray_poly_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_poly_2.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! + type t + end type t + type(t) :: a[*] + call test(a) ! { dg-error "Rank mismatch in argument 'x' at .1. .rank-1 and scalar." } +contains + subroutine test(x) + class(t) :: x(:)[*] + print *, ucobound(x) + end +end diff --git a/Fortran/gfortran/regression/coarray_poly_3.f90 b/Fortran/gfortran/regression/coarray_poly_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_poly_3.f90 @@ -0,0 +1,165 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! + + +subroutine cont1(x) ! { dg-error "has the CONTIGUOUS attribute but is not an array pointer or an assumed-shape or assumed-rank array" } + type t + end type t + class(t), contiguous, allocatable :: x(:) +end + +subroutine cont2(x) ! { dg-error "has the CONTIGUOUS attribute but is not an array pointer or an assumed-shape or assumed-rank array" } + type t + end type t + class(t), contiguous, allocatable :: x(:)[:] +end + +subroutine cont3(x, y) + type t + end type t + class(t), contiguous, pointer :: x(:) + class(t), contiguous :: y(:) +end + +function func() ! { dg-error "shall not be a coarray or have a coarray component" } + type t + end type t + class(t), allocatable :: func[*] +end + +function func2() ! { dg-error "must be dummy, allocatable or pointer" } + type t + integer, allocatable :: caf[:] + end type t + class(t) :: func2a ! { dg-error "CLASS variable 'func2a' at .1. must be dummy, allocatable or pointer" } + class(t) :: func2 +end + +subroutine foo1(x1) ! { dg-error "Coarray variable 'x1' at .1. shall not have codimensions with deferred shape" } + type t + end type t + type(t) :: x1(:)[:] +end + +subroutine foo2(x2) ! { dg-error "Coarray variable 'x2' at .1. shall not have codimensions with deferred shape" } + type t + end type t + type(t) :: x2[:] +end + + +! DITTO FOR CLASS + +subroutine foo3(x1) ! { dg-error "Coarray variable 'x1' at .1. shall not have codimensions with deferred shape" } + type t + end type t + class(t) :: x1(:)[:] +end + +subroutine foo4(x2) ! { dg-error "Coarray variable 'x2' at .1. shall not have codimensions with deferred shape" } + type t + end type t + class(t) :: x2[:] +end + + + + +subroutine bar1(y1) ! { dg-error "Allocatable coarray variable 'y1' at .1. must have deferred shape" } + type t + end type t + type(t), allocatable :: y1(:)[5:*] +end + +subroutine bar2(y2) ! { dg-error "Allocatable coarray variable 'y2' at .1. must have deferred shape" } + type t + end type t + type(t), allocatable :: y2[5:*] +end + +subroutine bar3(z1) ! { dg-error "Allocatable coarray variable 'z1' at .1. must have deferred shape" } + type t + end type t + type(t), allocatable :: z1(5)[:] +end + +subroutine bar4(z2) ! { dg-error "Allocatable array 'z2' at .1. must have a deferred shape" } + type t + end type t + type(t), allocatable :: z2(5) +end subroutine bar4 + +subroutine bar5(z3) ! { dg-error "Array pointer 'z3' at .1. must have a deferred shape" } + type t + end type t + type(t), pointer :: z3(5) +end subroutine bar5 + + + + +! DITTO FOR CLASS + +subroutine bar1c(y1) ! { dg-error "Allocatable coarray variable 'y1' at .1. must have deferred shape" } + type t + end type t + class(t), allocatable :: y1(:)[5:*] +end + +subroutine bar2c(y2) ! { dg-error "Allocatable coarray variable 'y2' at .1. must have deferred shape" } + type t + end type t + class(t), allocatable :: y2[5:*] +end + +subroutine bar3c(z1) ! { dg-error "Allocatable coarray variable 'z1' at .1. must have deferred shape" } + type t + end type t + class(t), allocatable :: z1(5)[:] +end + +subroutine bar4c(z2) ! { dg-error "Allocatable array 'z2' at .1. must have a deferred shape" } + type t + end type t + class(t), allocatable :: z2(5) +end subroutine bar4c + +subroutine bar5c(z3) ! { dg-error "Array pointer 'z3' at .1. must have a deferred shape" } + type t + end type t + class(t), pointer :: z3(5) +end subroutine bar5c + + +subroutine sub() + type t + end type + type(t) :: a(5) + class(t), allocatable :: b(:) + call inter(a) + call inter(b) +contains + subroutine inter(x) + class(t) :: x(5) + end subroutine inter +end subroutine sub + +subroutine sub2() + type t + end type + type(t) :: a(5) +contains + subroutine inter(x) + class(t) :: x(5) + end subroutine inter +end subroutine sub2 + +subroutine sub3() + type t + end type +contains + subroutine inter2(x) ! { dg-error "must have a deferred shape" } + class(t), pointer :: x(5) + end subroutine inter2 +end subroutine sub3 diff --git a/Fortran/gfortran/regression/coarray_poly_4.f90 b/Fortran/gfortran/regression/coarray_poly_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_poly_4.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -fdump-tree-original" } + +subroutine test(i) +type t + real, allocatable :: x[:] +end type t + +interface + subroutine sub(y) + import + real :: y[*] + end subroutine sub +end interface + +integer :: i +type(t), save :: var +allocate(var%x[*]) +call sub(var%x) +end subroutine test + +! { dg-final { scan-tree-dump-times "sub \\(\\(real\\(kind=4\\) \\*\\) var.x.data, var.x.token, 0\\);" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_poly_5.f90 b/Fortran/gfortran/regression/coarray_poly_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_poly_5.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -fdump-tree-original" } + +subroutine test(x) +type t + real, allocatable :: x[:] +end type t + +class(t) :: x +allocate(x%x[*]) +end subroutine test + +! { dg-final { scan-tree-dump-times "_gfortran_caf_register \\(4, 1, &x->_data->x.token, \\(void \\*\\) &x->_data->x, 0B, 0B, 0\\);" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_poly_6.f90 b/Fortran/gfortran/regression/coarray_poly_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_poly_6.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -fdump-tree-original" } +! + implicit none + type t + end type t + class(t), allocatable :: y[:] + call bar() + call foo(y) +contains + subroutine bar(x) + class(t), optional :: x[*] + end subroutine bar + subroutine foo(x) + class(t) :: x[*] + end subroutine foo +end +! { dg-final { scan-tree-dump-times "foo \\(struct __class_MAIN___T_0_1t & restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_0_1t \\* x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "bar \\(0B, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data.token, \\(integer\\(kind=\[48\]\\)\\) class..._data.data - \\(integer\\(kind=\[48\]\\)\\) y._data.data\\);" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_poly_7.f90 b/Fortran/gfortran/regression/coarray_poly_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_poly_7.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -fdump-tree-original" } +! + implicit none + type t + end type t + class(t), allocatable :: y(:)[:] + call bar() + call foo(y) +contains + subroutine bar(x) + class(t), optional :: x(:)[*] + end subroutine bar + subroutine foo(x) + class(t) :: x(:)[*] + end subroutine foo +end +! { dg-final { scan-tree-dump-times "foo \\(struct __class_MAIN___T_1_1t & restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_1_1t \\* x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "bar \\(0B, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data.token, \\(integer\\(kind=\[48\]\\)\\) class..._data.data - \\(integer\\(kind=\[48\]\\)\\) y._data.data\\);" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_poly_8.f90 b/Fortran/gfortran/regression/coarray_poly_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_poly_8.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib -fdump-tree-original" } +! + implicit none + type t + end type t + class(t), allocatable :: y(:)[:] + call bar() + call foo(y) +contains + subroutine bar(x) + class(t), optional :: x(2)[*] + end subroutine bar + subroutine foo(x) + class(t) :: x(2)[*] + end subroutine foo +end +! { dg-final { scan-tree-dump-times "foo \\(struct __class_MAIN___T_1_1t & restrict x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "bar \\(struct __class_MAIN___T_1_1t \\* x, void \\* restrict caf_token.., integer\\(kind=\[48\]\\) caf_offset..\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "bar \\(0B, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "foo \\(&class.., y._data.token, \\(integer\\(kind=\[48\]\\)\\) class..._data.data - \\(integer\\(kind=\[48\]\\)\\) y._data.data\\);" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_poly_9.f90 b/Fortran/gfortran/regression/coarray_poly_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_poly_9.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! { dg-options "-fcoarray=single" } +! +! Test the fix for PR91726. +! +! Contributed by Gerhardt Steinmetz +! +module m + type s + class(*), allocatable :: a[:] ! This ICEd + end type + type t + class(*), allocatable :: a(:)[:] ! This was OK + end type +end + + use m + call foo + call bar +contains + subroutine foo + type (s) :: a + integer(4) :: i = 42_4 + allocate (a%a[*], source = i) ! This caused runtime segfaults + select type (z => a%a) ! ditto + type is (integer(4)) + if (z .ne. 42_4) stop 1 + end select + end subroutine + subroutine bar ! Arrays always worked + type (t) :: a + allocate (a%a(3)[*], source = [1_4, 2_4, 3_4]) + select type (z => a%a) + type is (integer(4)) + if (any (z .ne. [1_4, 2_4, 3_4])) stop 2 + end select + end subroutine +end diff --git a/Fortran/gfortran/regression/coarray_ptr_comp_1.f08 b/Fortran/gfortran/regression/coarray_ptr_comp_1.f08 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_ptr_comp_1.f08 @@ -0,0 +1,99 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -lcaf_single" } +! { dg-additional-options "-latomic" { target libatomic_available } } + +! Contributed by Damian Rouson +! Check the new _caf_get_by_ref()-routine. +! Same like coarray_alloc_comp_1 but for pointers. + +program main + +implicit none + +type :: mytype + integer :: i + integer, pointer :: indices(:) + real, dimension(2,5,3) :: volume + integer, pointer :: scalar + integer :: j + integer, pointer :: matrix(:,:) + real, pointer :: dynvol(:,:,:) +end type + +type arrtype + type(mytype), pointer :: vec(:) + type(mytype), pointer :: mat(:,:) +end type arrtype + +type(mytype), save :: object[*] +type(arrtype), save :: bar[*] +integer :: i,j,me,neighbor +integer :: idx(5) +real, allocatable :: volume(:,:,:), vol2(:,:,:) +real, target :: vol_static(2,5,3) + +idx = (/ 1,2,1,7,5 /) + +me=this_image() +allocate(object%indices, source=[(i,i=1,5)]) +allocate(object%scalar, object%matrix(10,7)) +object%i = 37 +object%scalar = 42 +vol_static = reshape([(i, i=1, 2*5*3)], [2, 5, 3]) +object%volume = vol_static +object%matrix = reshape([(i, i=1, 70)], [10, 7]) +object%dynvol => vol_static +sync all +neighbor = merge(1,neighbor,me==num_images()) +if (object[neighbor]%scalar /= 42) STOP 1 +if (object[neighbor]%indices(4) /= 4) STOP 2 +if (object[neighbor]%matrix(3,6) /= 53) STOP 3 +if (any( object[neighbor]%indices(:) /= [1,2,3,4,5] )) STOP 4 +if (any( object[neighbor]%matrix(:,:) /= reshape([(i, i=1, 70)], [10, 7]))) STOP 5 +if (any( object[neighbor]%matrix(3,:) /= [(i * 10 + 3, i=0, 6)])) STOP 6 +if (any( object[neighbor]%matrix(:,2) /= [(i + 10, i=1, 10)])) STOP 7 +if (any( object[neighbor]%matrix(idx,2) /= [11, 12, 11, 17, 15])) STOP 8 +if (any( object[neighbor]%matrix(3,idx) /= [3, 13, 3, 63, 43])) STOP 9 +if (any( object[neighbor]%matrix(2:8:4, 5:1:-1) /= reshape([42, 46, 32, 36, 22, 26, 12, 16, 2, 6], [2,5]))) STOP 10 +if (any( object[neighbor]%matrix(:8:4, 2::2) /= reshape([11, 15, 31, 35, 51, 55], [2,3]))) STOP 11 +if (any( object[neighbor]%volume /= vol_static)) STOP 12 +if (any( object[neighbor]%dynvol /= vol_static)) STOP 13 +if (any( object[neighbor]%volume(:, 2:4, :) /= vol_static(:, 2:4, :))) STOP 14 +if (any( object[neighbor]%dynvol(:, 2:4, :) /= vol_static(:, 2:4, :))) STOP 15 + +vol2 = vol_static(:, ::2, :) +if (any( object[neighbor]%volume(:, ::2, :) /= vol2)) STOP 16 +if (any( object[neighbor]%dynvol(:, ::2, :) /= vol2)) STOP 17 + +allocate(bar%vec(-2:2)) + +bar%vec(1)%volume = vol_static +if (any(bar[neighbor]%vec(1)%volume /= vol_static)) STOP 18 + +i = 15 +allocate(bar%vec(1)%scalar, bar%vec(0)%scalar) +bar%vec(1)%scalar = i +if (.not. associated(bar%vec(1)%scalar)) STOP 19 +if (bar[neighbor]%vec(1)%scalar /= 15) STOP 20 + +bar%vec(0)%scalar = 27 +if (.not. associated(bar%vec(0)%scalar)) STOP 21 +if (bar[neighbor]%vec(0)%scalar /= 27) STOP 22 + +allocate(bar%vec(1)%indices(3), bar%vec(2)%indices(5)) +bar%vec(1)%indices = [ 3, 4, 15 ] +bar%vec(2)%indices = 89 + +if (.not. associated(bar%vec(1)%indices)) STOP 23 +if (associated(bar%vec(-2)%indices)) STOP 24 +if (associated(bar%vec(-1)%indices)) STOP 25 +if (associated(bar%vec( 0)%indices)) STOP 26 +if (.not. associated(bar%vec( 2)%indices)) STOP 27 +if (any(bar[me]%vec(2)%indices /= 89)) STOP 28 + +if (any (bar[neighbor]%vec(1)%indices /= [ 3,4,15])) STOP 29 + +deallocate(bar%vec(2)%indices, bar%vec(1)%indices, bar%vec(1)%scalar, bar%vec(0)%scalar) +deallocate(object%indices, object%scalar, object%matrix) +deallocate(bar%vec) +end program diff --git a/Fortran/gfortran/regression/coarray_ptr_comp_2.f08 b/Fortran/gfortran/regression/coarray_ptr_comp_2.f08 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_ptr_comp_2.f08 @@ -0,0 +1,88 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -lcaf_single" } +! { dg-additional-options "-latomic" { target libatomic_available } } + +! Contributed by Damian Rouson +! Check the new _caf_send_by_ref()-routine. +! Same as coarray_alloc_comp_2 but for pointers. + +program main + +implicit none + +type :: mytype + integer :: i + integer, pointer :: indices(:) + real, dimension(2,5,3) :: volume + integer, pointer :: scalar + integer :: j + integer, pointer :: matrix(:,:) + real, pointer :: dynvol(:,:,:) +end type + +type arrtype + type(mytype), pointer :: vec(:) + type(mytype), pointer :: mat(:,:) +end type arrtype + +type(mytype), save :: object[*] +type(arrtype), save :: bar[*] +integer :: i,j,me,neighbor +integer :: idx(5) +real, allocatable :: volume(:,:,:), vol2(:,:,:) +real :: vol_static(2,5,3) + +idx = (/ 1,2,1,7,5 /) + +me=this_image() +neighbor = merge(1,me+1,me==num_images()) +allocate(object%indices(5), object%scalar, object%matrix(10,7), object%dynvol(2,5,3)) +object[neighbor]%indices=[(i,i=1,5)] +object[neighbor]%i = 37 +object[neighbor]%scalar = 42 +vol_static = reshape([(i, i=1, 2*5*3)], [2, 5, 3]) +object[neighbor]%volume = vol_static +object[neighbor]%matrix = reshape([(i, i=1, 70)], [10, 7]) +object[neighbor]%dynvol = vol_static +sync all +if (object%scalar /= 42) STOP 1 +if (any( object%indices /= [1,2,3,4,5] )) STOP 2 +if (any( object%matrix /= reshape([(i, i=1, 70)], [10, 7]))) STOP 3 +if (any( object%volume /= vol_static)) STOP 4 +if (any( object%dynvol /= vol_static)) STOP 5 + +vol2 = vol_static +vol2(:, ::2, :) = 42 +object[neighbor]%volume(:, ::2, :) = 42 +object[neighbor]%dynvol(:, ::2, :) = 42 +if (any( object%volume /= vol2)) STOP 6 +if (any( object%dynvol /= vol2)) STOP 7 + +allocate(bar%vec(-2:2)) + +bar[neighbor]%vec(1)%volume = vol_static +if (any(bar%vec(1)%volume /= vol_static)) STOP 8 + +allocate(bar%vec(1)%scalar, bar%vec(0)%scalar, bar%vec(1)%indices(3)) +i = 15 +bar[neighbor]%vec(1)%scalar = i +if (.not. associated(bar%vec(1)%scalar)) STOP 9 +if (bar%vec(1)%scalar /= 15) STOP 10 + +bar[neighbor]%vec(0)%scalar = 27 +if (.not. associated(bar%vec(0)%scalar)) STOP 11 +if (bar%vec(0)%scalar /= 27) STOP 12 + +bar[neighbor]%vec(1)%indices = [ 3, 4, 15 ] +allocate(bar%vec(2)%indices(5)) +bar[neighbor]%vec(2)%indices = 89 + +if (.not. associated(bar%vec(1)%indices)) STOP 13 +if (associated(bar%vec(-2)%indices)) STOP 14 +if (associated(bar%vec(-1)%indices)) STOP 15 +if (associated(bar%vec( 0)%indices)) STOP 16 +if (.not. associated(bar%vec( 2)%indices)) STOP 17 +if (any(bar%vec(2)%indices /= 89)) STOP 18 + +if (any (bar%vec(1)%indices /= [ 3,4,15])) STOP 19 +end program diff --git a/Fortran/gfortran/regression/coarray_ptr_comp_3.f08 b/Fortran/gfortran/regression/coarray_ptr_comp_3.f08 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_ptr_comp_3.f08 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } + +program ptr_comp + type t + integer, pointer :: z(:) + end type + type(t), save :: obj[*] + integer, allocatable, target :: i(:)[:] + + obj%z => i(:)[4] ! { dg-error "shall not have a coindex" } +end program + diff --git a/Fortran/gfortran/regression/coarray_send_by_ref_1.f08 b/Fortran/gfortran/regression/coarray_send_by_ref_1.f08 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_send_by_ref_1.f08 @@ -0,0 +1,30 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -lcaf_single" } +! { dg-additional-options "-latomic" { target libatomic_available } } + +program check_caf_send_by_ref + + implicit none + + type T + integer, allocatable :: scal + integer, allocatable :: array(:) + end type T + + type(T), save :: obj[*] + integer :: me, np, i + + me = this_image() + np = num_images() + + obj[np]%scal = 42 + + ! Check the token for the scalar is set. + if (obj[np]%scal /= 42) STOP 1 + + ! Now the same for arrays. + obj[np]%array = [(i * np + me, i = 1, 15)] + if (any(obj[np]%array /= [(i * np + me, i = 1, 15)])) STOP 2 + +end program check_caf_send_by_ref + diff --git a/Fortran/gfortran/regression/coarray_stat_2.f90 b/Fortran/gfortran/regression/coarray_stat_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_stat_2.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -lcaf_single" } +! { dg-additional-options "-latomic" { target libatomic_available } } +! +! Support for stat= in caf reference +! +program whitespace + implicit none + + integer :: me[*],tmp,stat + + me = this_image() + stat = 0 + + sync all(stat = stat) + + if(stat /= 0) write(*,*) 'failure during sync' + + stat = 42 + + tmp = me[num_images(),stat = stat] + if(stat /= 0) STOP 1 + +end program whitespace diff --git a/Fortran/gfortran/regression/coarray_stat_function.f90 b/Fortran/gfortran/regression/coarray_stat_function.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_stat_function.f90 @@ -0,0 +1,45 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -fcoarray=lib" } +! +program function_stat + implicit none + + integer :: me[*],tmp,stat,stat2,next + + me = this_image() + next = me + 1 + if(me == num_images()) next = 1 + stat = 0 + + sync all(stat=stat) + + if(stat /= 0) write(*,*) 'Image failed during sync' + + stat = 0 + if(me == 1) then + tmp = func(me[4,stat=stat]) + if(stat /= 0) write(*,*) me,'failure in func arg' + else if(me == 2) then + tmp = func2(me[1,stat=stat2],me[3,stat=stat]) + if(stat2 /= 0 .or. stat /= 0) write(*,*) me,'failure in func2 args' + endif + +contains + + function func(remote_me) + integer func + integer remote_me + func = remote_me + end function func + + function func2(remote_me,remote_neighbor) + integer func2 + integer remote_me,remote_neighbor + func2 = remote_me + remote_neighbor + end function func2 + +end program function_stat + +! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) desc.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) me, 4, &desc.\[0-9\]+, 0B, &desc.\[0-9\]+, 4, 4, 0, &stat\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) desc.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) me, 1, &desc.\[0-9\]+, 0B, &desc.\[0-9\]+, 4, 4, 0, &stat2\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_get \\\(caf_token.0, \\\(integer\\\(kind=\[48\]\\\)\\\) desc.\[0-9\]+.data - \\\(integer\\\(kind=\[48\]\\\)\\\) me, 3, &desc.\[0-9\]+, 0B, &desc.\[0-9\]+, 4, 4, 0, &stat\\\);" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_stat_whitespace.f90 b/Fortran/gfortran/regression/coarray_stat_whitespace.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_stat_whitespace.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } +! +! Support for stat= in caf reference +! +program whitespace + implicit none + + integer :: me[*],tmp,stat,i + + me = this_image() + stat = 0 + i = 1 + + sync all(stat = stat) + + if(stat /= 0) write(*,*) 'failure during sync' + + stat = 0 + + if(me == 1) then + tmp = me[num_images(),stat = stat] + if(stat /= 0) write(*,*) 'failure in img:',me + else if(me == 2) then + tmp = me[i,stat=stat] + if(stat /= 0) write(*,*) 'failure in img:',me + endif + +end program whitespace diff --git a/Fortran/gfortran/regression/coarray_stopped_images_1.f08 b/Fortran/gfortran/regression/coarray_stopped_images_1.f08 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_stopped_images_1.f08 @@ -0,0 +1,30 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original -fcoarray=lib -lcaf_single" } +! { dg-additional-options "-latomic" { target libatomic_available } } + +program test_stopped_images_1 + implicit none + + integer :: me,np,stat + character(len=1) :: c + integer, allocatable :: si(:) + integer(kind=1), allocatable :: ssi(:) + + si = stopped_images() + if (size(si) > 0) error stop "stopped_images result shall be empty array at 1" + if (allocated(si)) error stop "stopped_images result shall not be allocated at 1" + + ssi = stopped_images(KIND=1) + if (size(ssi) > 0) error stop "stopped_images result shall be empty array at 2" + if (allocated(ssi)) error stop "stopped_images result shall not be allocated at 2" + + ssi = stopped_images(KIND=8) + if (size(ssi) > 0) error stop "stopped_images result shall be empty array at 3" +! The implicit type conversion in the assignment above allocates an array. +! if (allocated(ssi)) error stop "stopped_images result shall not be allocated at 3" + +end program test_stopped_images_1 + +! { dg-final { scan-tree-dump-times "_gfortran_caf_stopped_images \\\(&D\\\.\[0-9\]+, 0B, 0B\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_stopped_images \\\(&D\\\.\[0-9\]+, 0B, D\\\.\[0-9\]+\\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_stopped_images \\\(&D\\\.\[0-9\]+, 0B, D\\\.\[0-9\]+\\\);" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_subobject_1.f90 b/Fortran/gfortran/regression/coarray_subobject_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_subobject_1.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/50420 +! Coarray subobjects were not accepted as valid coarrays +! They should still be rejected if one of the component reference is allocatable +! or pointer + +type t + integer :: i +end type t +type t2 + type(t), allocatable :: a + type(t), pointer :: c +end type t2 +type(t2) :: b[5:*] +allocate(b%a) +allocate(b%c) +b%a%i = 7 +b%c%i = 13 +if (b%a%i /= 7) STOP 1 +if (any (lcobound(b%a) /= (/ 5 /))) STOP 2! { dg-error "Expected coarray variable" } +if (ucobound(b%a, dim=1) /= this_image() + 4) STOP 3! { dg-error "Expected coarray variable" } +if (any (lcobound(b%a%i) /= (/ 5 /))) STOP 4! { dg-error "Expected coarray variable" } +if (ucobound(b%a%i, dim=1) /= this_image() + 4) STOP 5! { dg-error "Expected coarray variable" } +if (b%c%i /= 13) STOP 6 +if (any (lcobound(b%c) /= (/ 5 /))) STOP 7! { dg-error "Expected coarray variable" } +if (ucobound(b%c, dim=1) /= this_image() + 4) STOP 8! { dg-error "Expected coarray variable" } +if (any (lcobound(b%c%i) /= (/ 5 /))) STOP 9! { dg-error "Expected coarray variable" } +if (ucobound(b%c%i, dim=1) /= this_image() + 4) STOP 10! { dg-error "Expected coarray variable" } +end diff --git a/Fortran/gfortran/regression/coarray_sync.f90 b/Fortran/gfortran/regression/coarray_sync.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_sync.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! { dg-options "-fcoarray=lib" } +! PR fortran/99351 - ICE in gfc_finish_var_decl, at fortran/trans-decl.c:695 + +module m + character(3), parameter :: c = 'abc' + integer, parameter :: s = 42 + integer, target :: i + character(:), allocatable :: a + target :: a +contains + subroutine s1 + allocate (character(42) :: a) + sync all (stat=i) + sync all (stat=f()) + sync all (errmsg=a) + sync all (errmsg=p()) + sync all (stat=a%len) ! { dg-error "variable definition context" } + sync all (stat=s) ! { dg-error "variable definition context" } + sync all (errmsg=c) ! { dg-error "variable definition context" } + end + subroutine s2 + sync images (*, stat=i) + sync images (*, errmsg=a) + sync images (*, stat=a%len) ! { dg-error "variable definition context" } + sync images (*, stat=s) ! { dg-error "variable definition context" } + sync images (*, errmsg=c) ! { dg-error "variable definition context" } + end + subroutine s3 + sync memory (stat=i,errmsg=p()) + sync memory (stat=f(),errmsg=a) + sync memory (stat=a%len) ! { dg-error "variable definition context" } + sync memory (stat=s) ! { dg-error "variable definition context" } + sync memory (errmsg=c) ! { dg-error "variable definition context" } + end + integer function f() + pointer :: f + f => i + end function f + function p() + character(:), pointer :: p + p => a + end function p +end diff --git a/Fortran/gfortran/regression/coarray_sync_memory.f90 b/Fortran/gfortran/regression/coarray_sync_memory.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_sync_memory.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -fcoarray=lib" } +! +! Coarray sync memory managed by the external library +! +implicit none +integer :: stat +character(len=42) :: msg +sync memory +sync memory(stat=stat) +sync memory(errmsg=msg) +sync memory(errmsg=msg, stat=stat) +end + +! { dg-final { scan-tree-dump-times "_gfortran_caf_sync_memory \\(0B, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_sync_memory \\(&stat, 0B, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_sync_memory \\(0B, &&msg, 42\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "_gfortran_caf_sync_memory \\(&stat, &&msg, 42\\);" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_this_image_1.f90 b/Fortran/gfortran/regression/coarray_this_image_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_this_image_1.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -fcoarray=single" } +! +j1 = this_image(distance=4) +j2 = this_image(5) +k1 = num_images() +k2 = num_images(6) +k3 = num_images(distance=7) +k4 = num_images(distance=8, failed=.true.) +k5 = num_images(failed=.false.) +end + +! { dg-final { scan-tree-dump-times "j1 = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "j2 = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "k1 = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "k2 = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "k3 = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "k4 = 0;" 1 "original" } } +! { dg-final { scan-tree-dump-times "k5 = 1;" 1 "original" } } diff --git a/Fortran/gfortran/regression/coarray_this_image_2.f90 b/Fortran/gfortran/regression/coarray_this_image_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coarray_this_image_2.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original -fcoarray=lib" } +! +j1 = this_image(distance=4) +j2 = this_image(5) +k1 = num_images() +k2 = num_images(6) +k3 = num_images(distance=7) +k4 = num_images(distance=8, failed=.true.) +k5 = num_images(failed=.false.) +end + +! { dg-final { scan-tree-dump-times "j1 = _gfortran_caf_this_image \\(4\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "j2 = _gfortran_caf_this_image \\(5\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "k1 = _gfortran_caf_num_images \\(0, -1\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "k2 = _gfortran_caf_num_images \\(6, -1\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "k3 = _gfortran_caf_num_images \\(7, -1\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "k4 = _gfortran_caf_num_images \\(8, 1\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "k5 = _gfortran_caf_num_images \\(0, 0\\);" 1 "original" } } diff --git a/Fortran/gfortran/regression/coindexed_1.f90 b/Fortran/gfortran/regression/coindexed_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coindexed_1.f90 @@ -0,0 +1,73 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -lcaf_single" } +! { dg-additional-options "-latomic" { target libatomic_available } } +! +! Contributed by Reinhold Bader +! + +program pmup + implicit none + type t + integer :: b, a + end type t + + CLASS(*), allocatable :: a(:)[:] + integer :: ii + + !! --- ONE --- + allocate(real :: a(3)[*]) + IF (this_image() == num_images()) THEN + SELECT TYPE (a) + TYPE IS (real) + a(:)[1] = 2.0 + END SELECT + END IF + SYNC ALL + + IF (this_image() == 1) THEN + SELECT TYPE (a) + TYPE IS (real) + IF (ALL(A(:)[1] == 2.0)) THEN + !WRITE(*,*) 'OK' + ELSE + WRITE(*,*) 'FAIL' + STOP 1 + END IF + TYPE IS (t) + ii = a(1)[1]%a + STOP 2 + CLASS IS (t) + ii = a(1)[1]%a + STOP 3 + END SELECT + END IF + + !! --- TWO --- + deallocate(a) + allocate(t :: a(3)[*]) + IF (this_image() == num_images()) THEN + SELECT TYPE (a) + TYPE IS (t) + a(:)[1]%a = 4.0 + END SELECT + END IF + SYNC ALL + + IF (this_image() == 1) THEN + SELECT TYPE (a) + TYPE IS (real) + ii = a(1)[1] + STOP 4 + TYPE IS (t) + IF (ALL(A(:)[1]%a == 4.0)) THEN + !WRITE(*,*) 'OK' + ELSE + WRITE(*,*) 'FAIL' + STOP 5 + END IF + CLASS IS (t) + ii = a(1)[1]%a + STOP 6 + END SELECT + END IF +end program diff --git a/Fortran/gfortran/regression/com_block_driver.f90 b/Fortran/gfortran/regression/com_block_driver.f90 --- /dev/null +++ b/Fortran/gfortran/regression/com_block_driver.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +module myComModule + use, intrinsic :: iso_c_binding + + common /COM2/ R2, S2 + real(c_double) :: r2 + real(c_double) :: s2 + bind(c) :: /COM2/ + +end module myComModule + +module comBlockTests + use, intrinsic :: iso_c_binding + use myComModule + + implicit none + + common /COM/ R, S + real(c_double) :: r + real(c_double) :: s + bind(c) :: /COM/ + + contains + + subroutine testTypes() + implicit none + end subroutine testTypes +end module comBlockTests + +program comBlockDriver + use comBlockTests + + call testTypes() +end program comBlockDriver diff --git a/Fortran/gfortran/regression/comma.f b/Fortran/gfortran/regression/comma.f --- /dev/null +++ b/Fortran/gfortran/regression/comma.f @@ -0,0 +1,19 @@ +! { dg-do run { target fd_truncate } } +! PR25419 Default input with commas. +! Derived from example given in PR. +! Contributed by Jerry DeLisle + stuff = 1 + stuff2 = 2 + write(11,'(a)') ",," + rewind(11) + read(11,*)stuff, stuff2 + if (stuff.ne.1.0) STOP 1 + if (stuff2.ne.2.0) STOP 2 + rewind (11) + write(11,'(a)') "," + rewind(11) + read(11,*)stuff + if (stuff.ne.1.0) STOP 3 + close(11, status='delete') + end + diff --git a/Fortran/gfortran/regression/comma_IO_extension_1.f90 b/Fortran/gfortran/regression/comma_IO_extension_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/comma_IO_extension_1.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR 60751 +! Contributed by Walter Spector +program extracomma + implicit none + + write (*,*), 1, 2, 3 ! { dg-warning "Legacy Extension: Comma before i/o item list" } +end program diff --git a/Fortran/gfortran/regression/comma_IO_extension_2.f90 b/Fortran/gfortran/regression/comma_IO_extension_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/comma_IO_extension_2.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! PR 60751 +! Contributed by Walter Spector +program extracomma + implicit none + + write (*,*), 1, 2, 3 +end program diff --git a/Fortran/gfortran/regression/comma_format_extension_1.f b/Fortran/gfortran/regression/comma_format_extension_1.f --- /dev/null +++ b/Fortran/gfortran/regression/comma_format_extension_1.f @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "" } +! test that the extension for a missing comma is accepted + + subroutine mysub + dimension ibar(5) + write (3,1001) ( ibar(m), m = 1, 5 ) + + 1001 format (/5x,' ',i4' '/ ) + return + end diff --git a/Fortran/gfortran/regression/comma_format_extension_2.f b/Fortran/gfortran/regression/comma_format_extension_2.f --- /dev/null +++ b/Fortran/gfortran/regression/comma_format_extension_2.f @@ -0,0 +1,10 @@ +! { dg-do compile } +! test that the extension for a missing comma is accepted + + subroutine mysub + dimension ibar(5) + write (3,1001) ( ibar(m), m = 1, 5 ) + + 1001 format (/5x,' ',i4' '/ ) ! { dg-warning "Missing comma" } + return + end diff --git a/Fortran/gfortran/regression/comma_format_extension_3.f b/Fortran/gfortran/regression/comma_format_extension_3.f --- /dev/null +++ b/Fortran/gfortran/regression/comma_format_extension_3.f @@ -0,0 +1,16 @@ +! PR libfortran/15332 and PR fortran/13257 +! We used to accept this as an extension but +! did do the correct thing at runtime. +! Note the missing , before i1 in the format. +! { dg-do run } +! { dg-options "" } + character*12 c + + write (c,100) 0, 1 + if (c .ne. 'i = 0, j = 1') STOP 1 + + write (c,100) 0 + if (c .ne. 'i = 0 ') STOP 2 + + 100 format ('i = 'i1,:,', j = ',i1) + end diff --git a/Fortran/gfortran/regression/comma_format_extension_4.f b/Fortran/gfortran/regression/comma_format_extension_4.f --- /dev/null +++ b/Fortran/gfortran/regression/comma_format_extension_4.f @@ -0,0 +1,10 @@ +! PR fortran/13257 +! Note the missing , before i1 in the format. +! { dg-do run } +! { dg-options "" } + character*6 c + write (c,1001) 1 + if (c .ne. ' 1 ') STOP 1 + + 1001 format (' ',i4' ') + end diff --git a/Fortran/gfortran/regression/common_1.f b/Fortran/gfortran/regression/common_1.f --- /dev/null +++ b/Fortran/gfortran/regression/common_1.f @@ -0,0 +1,14 @@ +! { dg-do compile } + module mymod + type :: mytyp + integer :: i + end type mytyp + contains + subroutine mysub + implicit none + type(mytyp) :: a + integer :: commoni,commonj + commoni = a%i + commonj = a%j ! { dg-error "is not a member of" } + end subroutine mysub + end module mymod diff --git a/Fortran/gfortran/regression/common_1.f90 b/Fortran/gfortran/regression/common_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_1.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! tests various allowed variants of the common statement +! inspired by PR 18869 + +! blank common block + common x + common y, z + common // xx + +! one named common block on a line + common /a/ e + +! appending to a common block + common /a/ g + +! several named common blocks on a line + common /foo/ a, /bar/ b ! note 'a' is also the name of the + ! above common block + common /baz/ c /foobar/ d, /bazbar/ f + + end diff --git a/Fortran/gfortran/regression/common_10.f90 b/Fortran/gfortran/regression/common_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_10.f90 @@ -0,0 +1,55 @@ +use iso_c_binding +implicit none + +type, bind(C) :: mytype1 + integer(c_int) :: x + real(c_float) :: y +end type mytype1 + +type mytype2 + sequence + integer :: x + real :: y +end type mytype2 + +type mytype3 + integer :: x + real :: y +end type mytype3 + +type mytype4 + sequence + integer, allocatable, dimension(:) :: x +end type mytype4 + +type mytype5 + sequence + integer, pointer :: x + integer :: y +end type mytype5 + +type mytype6 + sequence + type(mytype5) :: t +end type mytype6 + +type mytype7 + sequence + type(mytype4) :: t +end type mytype7 + +common /a/ t1 +common /b/ t2 +common /c/ t3 ! { dg-error "has neither the SEQUENCE nor the BIND.C. attribute" } +common /d/ t4 ! { dg-error "has an ultimate component that is allocatable" } +common /e/ t5 +common /f/ t6 +common /f/ t7 ! { dg-error "has an ultimate component that is allocatable" } +type(mytype1) :: t1 +type(mytype2) :: t2 +type(mytype3) :: t3 +type(mytype4) :: t4 +type(mytype5) :: t5 +type(mytype6) :: t6 +type(mytype7) :: t7 +end diff --git a/Fortran/gfortran/regression/common_11.f90 b/Fortran/gfortran/regression/common_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_11.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! +! PR fortran/34658 +! +! Check for more COMMON constrains +! +block data + implicit none + integer :: x, a ! { dg-warning "Initialized variable 'a' at .1. is in a blank COMMON" } + integer :: y = 5, b = 5 ! { dg-warning "Initialized variable 'b' at .1. is in a blank COMMON" } + data x/5/, a/5/ + common // a, b + common /a/ x, y +end block data + +subroutine foo() + implicit none + type t + sequence + integer :: i = 5 + end type t + type(t) x ! { dg-error "may not have default initializer" } + common // x +end subroutine foo + +program test + implicit none + common /a/ I ! { dg-warning "in COMMON but only in BLOCK DATA initialization" } + integer :: I = 43 +end program test diff --git a/Fortran/gfortran/regression/common_12.f90 b/Fortran/gfortran/regression/common_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_12.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR fortran/39594 +! +! Contributed by Peter Knowles and reduced by Jakub Jelinek. +! +module pr39594 + implicit double precision(z) + common /z/ z0,z1,z2,z3,z4,z5,z6,z7 +contains + subroutine foo + implicit double precision(z) + common /z/ z0,z1,z2,z3,z4,z5,z6,z7 + call bar(z0) + end subroutine foo +end module diff --git a/Fortran/gfortran/regression/common_13.f90 b/Fortran/gfortran/regression/common_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_13.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! PR 50070: Segmentation fault at size_binop_loc in fold-const.c +! +! Contributed by Vittorio Zecca + +subroutine sub + common n,z ! { dg-error "must have constant character length" } + integer :: n + character(len=n) :: z +end diff --git a/Fortran/gfortran/regression/common_14.f90 b/Fortran/gfortran/regression/common_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_14.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-options "-Wno-align-commons" } +! +! PR fortran/45044 +! +! Named common blocks need to be all of the same size +! check that the compiler warns for those. + +module m + common /xx/ a +end module m + +subroutine two() +integer :: a, b, c +real(8) :: y +common /xx/ a, b, c, y ! { dg-warning "Named COMMON block 'xx' at \\(1\\) shall be of the same size as elsewhere \\(24 vs 4 bytes" } +end + + +subroutine one() +integer :: a, b +common /xx/ a, b ! { dg-warning "Named COMMON block 'xx' at \\(1\\) shall be of the same size as elsewhere \\(8 vs 24 bytes" } +end + +call two() +end diff --git a/Fortran/gfortran/regression/common_15.f90 b/Fortran/gfortran/regression/common_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_15.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! +! PR 50515: gfortran should not accept an external that is a common (r178939) +! +! Contributed by Vittorio Zecca + +common/sub/ a ! { dg-error "cannot have the EXTERNAL attribute" } +external sub +end diff --git a/Fortran/gfortran/regression/common_16.f90 b/Fortran/gfortran/regression/common_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_16.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-pedantic -mdalign" { target sh*-*-* } } +! +! PR fortran/50273 +! +subroutine test() + character :: a + integer :: b + character :: c + common /global_var/ a, b, c ! { dg-warning "Padding of 3 bytes required before 'b' in COMMON" } + print *, a, b, c +end subroutine test diff --git a/Fortran/gfortran/regression/common_17.f90 b/Fortran/gfortran/regression/common_17.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_17.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-Wall" } +! PR fortran/49693 - this used to cause a spurious warning for the +! variable in the common block. +! Test case by Stephan Kramer. +module foo + implicit none + integer:: a, b + common a +end module foo diff --git a/Fortran/gfortran/regression/common_18.f90 b/Fortran/gfortran/regression/common_18.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_18.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! +! PR fortran/48858 +! +! +use iso_c_binding +contains +subroutine one() + bind(C, name="com1") :: /foo/ + integer(c_int) :: a + common /foo/ a +end subroutine +subroutine two() + integer(c_long) :: a + common /foo/ a +end subroutine two +end + +! { dg-final { scan-assembler "com1" } } +! { dg-final { scan-assembler "foo_" } } diff --git a/Fortran/gfortran/regression/common_19.f90 b/Fortran/gfortran/regression/common_19.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_19.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! PR fortran/48858 +! +integer :: i +common /foo/ i +bind(C) :: /foo/ ! { dg-error "Fortran 2003: BIND.C. statement" } +end diff --git a/Fortran/gfortran/regression/common_2.f90 b/Fortran/gfortran/regression/common_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_2.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! The equivalence was causing us to miss out c when laying out the common +! block. +program common_2 + common /block/ a, b, c, d + integer a, b, c, d, n + dimension n(4) + equivalence (a, n(1)) + equivalence (c, n(3)) + a = 1 + b = 2 + c = 3 + d = 4 + if (any (n .ne. (/1, 2, 3, 4/))) STOP 1 +end program diff --git a/Fortran/gfortran/regression/common_20.f90 b/Fortran/gfortran/regression/common_20.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_20.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/48858 +! +subroutine test + integer :: l, m + common /g/ l ! { dg-error "Fortran 2008: COMMON block 'g' with binding label at .1. sharing the identifier with global non-COMMON-block entity at .2." } + common /jj/ m ! { dg-error "Global name 'jj' at .1. is already being used as a COMMON at .2." } + bind(C,name="bar") :: /g/ + bind(C,name="foo") :: /jj/ +end + +subroutine g ! { dg-error "Fortran 2008: COMMON block 'g' with binding label at .1. sharing the identifier with global non-COMMON-block entity at .2." } + call jj() ! { dg-error "Global name 'jj' at .1. is already being used as a COMMON at .2." } +end + + diff --git a/Fortran/gfortran/regression/common_21.f90 b/Fortran/gfortran/regression/common_21.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_21.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +! PR fortran/48858 +! +subroutine test + integer :: l, m + common /g/ l + common /jj/ m + bind(C,name="bar") :: /g/ + bind(C,name="foo") :: /jj/ +end + +subroutine g + call jj() +end + + diff --git a/Fortran/gfortran/regression/common_22.f90 b/Fortran/gfortran/regression/common_22.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_22.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! +! PR fortran/59746 +! Check that symbols present in common block are properly cleaned up +! upon error. +! +! Contributed by Bud Davis + + CALL RCCFL (NVE,IR,NU3,VE (1,1,1,I)) + COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL !{ dg-error "Unexpected COMMON" } + COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL !{ dg-error "Unexpected COMMON" } +! the PR only contained the two above. +! success is no segfaults or infinite loops. +! let's check some combinations + CALL ABC (INTG) + COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL !{ dg-error "Unexpected COMMON" } + COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL !{ dg-error "Unexpected COMMON" } + CALL DEF (NT1) + COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL !{ dg-error "Unexpected COMMON" } + COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL !{ dg-error "Unexpected COMMON" } + CALL GHI (NRESL) + COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL !{ dg-error "Unexpected COMMON" } + COMMON /CCFILE/ INTG,NT1,NT2,NT3,NVM,NVE,NFRLE,NRESF,NRESL !{ dg-error "Unexpected COMMON" } + END diff --git a/Fortran/gfortran/regression/common_23.f90 b/Fortran/gfortran/regression/common_23.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_23.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! PR fortran/66707 +! Check the compilation on wrong usage of common +! Contributed by Gerhard Steinmetz +program p + integer, pointer :: a + common a, a ! { dg-error "is already in a COMMON block" } + common a +end diff --git a/Fortran/gfortran/regression/common_24.f b/Fortran/gfortran/regression/common_24.f --- /dev/null +++ b/Fortran/gfortran/regression/common_24.f @@ -0,0 +1,11 @@ +c { dg-do compile } +c PR fortran/67758 +c +c Check the absence of ICE after emitting the error message +c +c Contributed by Ilya Enkovich + + COMMON /FMCOM / X(80 000 000) + CALL T(XX(A)) + COMMON /FMCOM / XX(80 000 000) ! { dg-error "Unexpected COMMON" } + END diff --git a/Fortran/gfortran/regression/common_25.f90 b/Fortran/gfortran/regression/common_25.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_25.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! PR fortran/67758 +! +! Check the absence of ICE after emitting the error message +! +! This test is the free form variant of common_24.f. + + REAL :: X + COMMON /FMCOM / X(80 000 000) ! { dg-error "Expected another dimension" } + CALL T(XX(A)) + COMMON /FMCOM / XX(80 000 000) ! { dg-error "Expected another dimension" } + END diff --git a/Fortran/gfortran/regression/common_26.f90 b/Fortran/gfortran/regression/common_26.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_26.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +module mymod + type :: mytyp + integer :: i + end type mytyp +contains + subroutine mysub + implicit none + type(mytyp) :: a + integer :: commoni,commonj + commoni = a%i + commonj = a%j ! { dg-error "is not a member of" } + end subroutine mysub +end module mymod diff --git a/Fortran/gfortran/regression/common_27.f90 b/Fortran/gfortran/regression/common_27.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_27.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! PR fortran/108453 - a use associated variable cannot occur in COMMON +! Contributed by G.Steinmetz + +module m + type t + end type + real :: r +end +program p + use m, only: t, r + common t ! { dg-error "USE associated from module" } + common /cm/ r ! { dg-error "USE associated from module" } +end diff --git a/Fortran/gfortran/regression/common_3.f90 b/Fortran/gfortran/regression/common_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_3.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! Check that equivalences match common block layout. +program common_3 + common /block/ a, b, c, d ! { dg-error "not match ordering" } + integer a, b, c, d, n + dimension n(4) + equivalence (a, n(1)) + equivalence (c, n(4)) +end program diff --git a/Fortran/gfortran/regression/common_4.f90 b/Fortran/gfortran/regression/common_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_4.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! Suppress warnings about misaligned common blocks. +! { dg-options "-w" } +! Check misaligned common blocks. +program prog + common /block/ a, b, c + integer(kind=1) a + integer b, c + a = 1 + b = HUGE(b) + c = 2 + call foo +end program +subroutine foo + common /block/ a, b, c + integer(kind=1) a + integer b, c + if (a .ne. 1 .or. b .ne. HUGE(b) .or. c .ne. 2) STOP 1 +end subroutine diff --git a/Fortran/gfortran/regression/common_5.f b/Fortran/gfortran/regression/common_5.f --- /dev/null +++ b/Fortran/gfortran/regression/common_5.f @@ -0,0 +1,11 @@ +C { dg-do compile } +C { dg-options "-pedantic-errors -mdalign" { target sh*-*-* } } +C PR 20059 +C Check that the warning for padding works correctly. + SUBROUTINE PLOTZ + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + COMMON /CCPOOL/ RMIN,RMAX,ZMIN,ZMAX,IMIN,JMIN,IMAX,JMAX,NFLOP, ! { dg-warning "Padding" } + $ HTP +C + RETURN + END diff --git a/Fortran/gfortran/regression/common_6.f90 b/Fortran/gfortran/regression/common_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_6.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR 23765 : We used to incorrectly accept common blocks with no symbols +common ! { dg-error "Syntax error" } +common // ! { dg-error "Syntax error" } +common /a/ ! { dg-error "Syntax error" } +common /b/x/c/ ! { dg-error "Syntax error" } +common y/d/ ! { dg-error "Syntax error" } +common /e//f/ ! { dg-error "Syntax error" } +common ///g/ ! { dg-error "Syntax error" } +end diff --git a/Fortran/gfortran/regression/common_7.f90 b/Fortran/gfortran/regression/common_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_7.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! F2003: 16.2.1 +! "A name that identifies a common block in a scoping unit shall not be used +! to identify a constant or an intrinsic procedure in that scoping unit." +! +subroutine x134 + INTEGER, PARAMETER :: C1=1 ! { dg-error "COMMON block 'c1' at \\(1\\) is used as PARAMETER" } + COMMON /C1/ I ! { dg-error "COMMON block 'c1' at \\(1\\) is used as PARAMETER" } +end subroutine +end diff --git a/Fortran/gfortran/regression/common_8.f90 b/Fortran/gfortran/regression/common_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_8.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +! PR fortran/25062 +! +! F2003: 16.2.1 +! "A name that identifies a common block in a scoping unit shall not be used +! to identify a constant or an intrinsic procedure in that scoping unit." +! +subroutine try + implicit none + COMMON /s/ J + COMMON /bar/ I + INTEGER I, J + real s, x + s(x)=sin(x) + print *, s(5.0) + call bar() +contains + subroutine bar + print *, 'Hello world' + end subroutine bar + +end subroutine try + +program test + implicit none + COMMON /abs/ J ! { dg-error "is also an intrinsic procedure" } + intrinsic :: abs + INTEGER J + external try + call try +end program test diff --git a/Fortran/gfortran/regression/common_9.f90 b/Fortran/gfortran/regression/common_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_9.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-std=f95" } + +! PR fortran/25062 +! +! F95: 14.1.2.1: +! "A common block name in a scoping unit also may be the name of any local +! entity other than a named constant, intrinsic procedure, or a local variable +! that is also an external function in a function subprogram." +! +! F2003: 16.2.1 +! "A name that identifies a common block in a scoping unit shall not be used +! to identify a constant or an intrinsic procedure in that scoping unit. If +! a local identifier is also the name of a common block, the appearance of +! that name in any context other than as a common block name in a COMMON +! or SAVE statement is an appearance of the local identifier." +! +function func1() result(res) + implicit none + real res, r + common /res/ r ! { dg-error "is also a function result" } +end function func1 +end diff --git a/Fortran/gfortran/regression/common_align_1.f90 b/Fortran/gfortran/regression/common_align_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_align_1.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! { dg-options "-fno-align-commons" } + +! PR fortran/37486 +! +! Test for -fno-align-commons. +! +! Contributed by Tobias Burnus . + +subroutine one() + integer :: i + common i + if (i/=5) STOP 1 +end subroutine one + +program test +integer :: i +real(8) :: r8 +common i, r8 +i = 5 +call one() +end program test diff --git a/Fortran/gfortran/regression/common_align_2.f90 b/Fortran/gfortran/regression/common_align_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_align_2.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! { dg-options "-pedantic-errors -mdalign" { target sh*-*-* } } +! Tests the fix for PR37614, in which the alignment of commons followed +! g77 rather than the standard or other compilers. +! +! Contributed by Tobias Burnus +! +subroutine foo (z) + real(8) x, y, z + common i(8) + equivalence (x, i(3)),(y,i(7)) + if ((i(1) .ne. 42) .or. (i(5) .ne. 43)) STOP 1 + if ((i(2) .ne. 0) .or. (i(2) .ne. 0)) STOP 2 + if ((x .ne. z) .or. (y .ne. z)) STOP 3 +end subroutine + +subroutine bar + common i(8) + i = 0 +end subroutine + + real(8) x, y + common i, x, j, y ! { dg-warning "Padding" } + call bar + i = 42 + j = 43 + x = atan (1.0)*4.0 + y = x + call foo (x) +end + diff --git a/Fortran/gfortran/regression/common_equivalence_1.f b/Fortran/gfortran/regression/common_equivalence_1.f --- /dev/null +++ b/Fortran/gfortran/regression/common_equivalence_1.f @@ -0,0 +1,21 @@ +c { dg-do run } +c This program tests the fix for PR22304. +c +c provided by Paul Thomas - pault@gcc.gnu.org +c + integer a(2), b, c + COMMON /foo/ a + EQUIVALENCE (a(1),b), (c, a(2)) + a(1) = 101 + a(2) = 102 + call bar () + END + + subroutine bar () + integer a(2), b, c, d + COMMON /foo/ a + EQUIVALENCE (a(1),b), (c, a(2)) + if (b.ne.101) STOP 1 + if (c.ne.102) STOP 2 + END + diff --git a/Fortran/gfortran/regression/common_equivalence_2.f b/Fortran/gfortran/regression/common_equivalence_2.f --- /dev/null +++ b/Fortran/gfortran/regression/common_equivalence_2.f @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR fortran/18870 +! + program main + common /foo/ a + common /bar/ b + equivalence (a,c) + equivalence (b,c) ! { dg-error "indirectly overlap COMMON" } + c=3. + print *,a + print *,b + end + diff --git a/Fortran/gfortran/regression/common_equivalence_3.f b/Fortran/gfortran/regression/common_equivalence_3.f --- /dev/null +++ b/Fortran/gfortran/regression/common_equivalence_3.f @@ -0,0 +1,14 @@ +! { dg-do compile } +! PR fortran/18870 +! + program main + equivalence (a,c) + equivalence (b,c) + common /foo/ a + common /bar/ b ! { dg-error "equivalenced to another COMMON" } + c=3. + print *,a + print *,b + end + + diff --git a/Fortran/gfortran/regression/common_errors_1.f90 b/Fortran/gfortran/regression/common_errors_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_errors_1.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! Tests a number of error messages relating to derived type objects +! in common blocks. Originally due to PR 33198 + +subroutine one +type a + sequence + integer :: i = 1 +end type a +type(a) :: t ! { dg-error "Derived type variable .t. in COMMON at ... may not have default initializer" } +common /c/ t +end + +subroutine first +type a + integer :: i + integer :: j +end type a +type(a) :: t ! { dg-error "Derived type variable .t. in COMMON at ... has neither the SEQUENCE nor the BIND.C. attribute" } +common /c/ t +end + +subroutine prime +type a + sequence + integer, allocatable :: i(:) + integer :: j +end type a +type(a) :: t ! { dg-error "Derived type variable .t. in COMMON at ... has an ultimate component that is allocatable" } +common /c/ t +end + +subroutine source +parameter(x=0.) ! { dg-error "COMMON block .x. at ... is used as PARAMETER at ..." } +common /x/ i ! { dg-error "COMMON block .x. at ... is used as PARAMETER at ..." } +intrinsic sin +common /sin/ j ! { dg-error "COMMON block .sin. at ... is also an intrinsic procedure" } +end subroutine source diff --git a/Fortran/gfortran/regression/common_pointer_1.f90 b/Fortran/gfortran/regression/common_pointer_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/common_pointer_1.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! PR13415 +! Test pointer variables in common blocks. + +subroutine test + implicit none + real, pointer :: p(:), q + common /block/ p, q + + if (any (p .ne. (/1.0, 2.0/)) .or. (q .ne. 42.0)) STOP 1 +end subroutine + +program common_pointer_1 + implicit none + real, target :: a(2), b + real, pointer :: x(:), y + common /block/ x, y + + a = (/1.0, 2.0/) + b = 42.0 + x=>a + y=>b + call test +end program diff --git a/Fortran/gfortran/regression/common_resize_1.f b/Fortran/gfortran/regression/common_resize_1.f --- /dev/null +++ b/Fortran/gfortran/regression/common_resize_1.f @@ -0,0 +1,177 @@ +c { dg-do run } +c { dg-options "-std=legacy" } +c +c Tests the fix for PR32302, in which the resizing of 'aux32' would cause +c misalignment for double precision types and a wrong result would be obtained +c at any level of optimization except none. +c +c Contributed by Dale Ranta +c + subroutine unpki(ixp,nwcon,nmel) + parameter(lnv=32) + implicit double precision (a-h,o-z) dp +c +c unpack connection data +c + common/aux32/kka(lnv),kkb(lnv),kkc(lnv), ! { dg-warning "shall be of the same size as elsewhere" } + 1 kk1(lnv),kk2(lnv),kk3(lnv),dxy(lnv), + 2 dyx(lnv),dyz(lnv),dzy(lnv),dzx(lnv), + 3 dxz(lnv),vx17(lnv),vx28(lnv),vx35(lnv), + 4 vx46(lnv),vy17(lnv),vy28(lnv), + 5 vy35(lnv),vy46(lnv),vz17(lnv),vz28(lnv),vz35(lnv),vz46(lnv) + common/aux33/ix1(lnv),ix2(lnv),ix3(lnv),ix4(lnv),ix5(lnv), ! { dg-warning "shall be of the same size as elsewhere" } + 1 ix6(lnv),ix7(lnv),ix8(lnv),mxt(lnv) + dimension ixp(nwcon,*) +c + return + end + subroutine prtal + parameter(lnv=32) + implicit double precision (a-h,o-z) dp + common/aux8/ + & x1(lnv),x2(lnv),x3(lnv),x4(lnv), + & x5(lnv),x6(lnv),x7(lnv),x8(lnv), + & y1(lnv),y2(lnv),y3(lnv),y4(lnv), + & y5(lnv),y6(lnv),y7(lnv),y8(lnv), + & z1(lnv),z2(lnv),z3(lnv),z4(lnv), + & z5(lnv),z6(lnv),z7(lnv),z8(lnv) + common/aux9/vlrho(lnv),det(lnv) + common/aux10/ + 1 px1(lnv),px2(lnv),px3(lnv),px4(lnv), + & px5(lnv),px6(lnv),px7(lnv),px8(lnv), + 2 py1(lnv),py2(lnv),py3(lnv),py4(lnv), + & py5(lnv),py6(lnv),py7(lnv),py8(lnv), + 3 pz1(lnv),pz2(lnv),pz3(lnv),pz4(lnv), + & pz5(lnv),pz6(lnv),pz7(lnv),pz8(lnv), + 4 vx1(lnv),vx2(lnv),vx3(lnv),vx4(lnv), + 5 vx5(lnv),vx6(lnv),vx7(lnv),vx8(lnv), + 6 vy1(lnv),vy2(lnv),vy3(lnv),vy4(lnv), + 7 vy5(lnv),vy6(lnv),vy7(lnv),vy8(lnv), + 8 vz1(lnv),vz2(lnv),vz3(lnv),vz4(lnv), + 9 vz5(lnv),vz6(lnv),vz7(lnv),vz8(lnv) + ! XFAILed here and below because of PRs 45045 and 45044 + common/aux32/ ! { dg-warning "shall be of the same size" "" { xfail *-*-*} } + a a17(lnv),a28(lnv),dett(lnv), + 1 aj1(lnv),aj2(lnv),aj3(lnv),aj4(lnv), + 2 aj5(lnv),aj6(lnv),aj7(lnv),aj8(lnv), + 3 aj9(lnv),x17(lnv),x28(lnv),x35(lnv), + 4 x46(lnv),y17(lnv),y28(lnv),y35(lnv), + 5 y46(lnv),z17(lnv),z28(lnv),z35(lnv),z46(lnv) + common/aux33/ ! { dg-warning "shall be of the same size" "" { xfail *-*-*} } + a ix1(lnv),ix2(lnv),ix3(lnv),ix4(lnv),ix5(lnv), + 1 ix6(lnv),ix7(lnv),ix8(lnv),mxt(lnv),nmel + common/aux36/lft,llt + common/failu/sieu(lnv),failu(lnv) + common/sand1/ihf,ibemf,ishlf,itshf + dimension aj5968(lnv),aj6749(lnv),aj4857(lnv),aji1(lnv),aji2(lnv), + 1 aji3(lnv),aji4(lnv),aji5(lnv), + 1 aji6(lnv),aji7(lnv),aji8(lnv),aji9(lnv),aj12(lnv), + 2 aj45(lnv),aj78(lnv),b17(lnv),b28(lnv),c17(lnv),c28(lnv) +c + equivalence (x17,aj5968),(x28,aj6749),(x35,aj4857),(x46,aji1), + 1 (y17,aji2),(y28,aji3),(y35,aji4),(y46,aji5),(z17,aji6), + 2 (z28,aji7),(z35,aji8),(z46,aji9),(aj1,aj12),(aj2,aj45), + 3 (aj3,aj78),(px1,b17),(px2,b28),(px3,c17),(px4,c28) + data o64th/0.0156250/ +c +c jacobian matrix +c + do 10 i=lft,llt + x17(i)=x7(i)-x1(i) + x28(i)=x8(i)-x2(i) + x35(i)=x5(i)-x3(i) + x46(i)=x6(i)-x4(i) + y17(i)=y7(i)-y1(i) + y28(i)=y8(i)-y2(i) + y35(i)=y5(i)-y3(i) + y46(i)=y6(i)-y4(i) + z17(i)=z7(i)-z1(i) + z28(i)=z8(i)-z2(i) + z35(i)=z5(i)-z3(i) + 10 z46(i)=z6(i)-z4(i) + do 20 i=lft,llt + aj1(i)=x17(i)+x28(i)-x35(i)-x46(i) + aj2(i)=y17(i)+y28(i)-y35(i)-y46(i) + aj3(i)=z17(i)+z28(i)-z35(i)-z46(i) + a17(i)=x17(i)+x46(i) + a28(i)=x28(i)+x35(i) + b17(i)=y17(i)+y46(i) + b28(i)=y28(i)+y35(i) + c17(i)=z17(i)+z46(i) + 20 c28(i)=z28(i)+z35(i) + do 30 i=lft,llt + aj4(i)=a17(i)+a28(i) + aj5(i)=b17(i)+b28(i) + aj6(i)=c17(i)+c28(i) + aj7(i)=a17(i)-a28(i) + aj8(i)=b17(i)-b28(i) + 30 aj9(i)=c17(i)-c28(i) +c +c jacobian +c + do 40 i=lft,llt + aj5968(i)=aj5(i)*aj9(i)-aj6(i)*aj8(i) + aj6749(i)=aj6(i)*aj7(i)-aj4(i)*aj9(i) + 40 aj4857(i)=aj4(i)*aj8(i)-aj5(i)*aj7(i) + if (ihf.ne.1) then + do 50 i=lft,llt + 50 det(i)=o64th*(aj1(i)*aj5968(i)+aj2(i)*aj6749(i)+aj3(i)*aj4857(i)) + else + do 55 i=lft,llt + det(i)=o64th*(aj1(i)*aj5968(i)+aj2(i)*aj6749(i)+aj3(i)*aj4857(i)) + 1 *failu(i) + (1. - failu(i)) + 55 continue + endif + do 60 i=lft,llt + 60 dett(i)=o64th/det(i) + + if (det(lft) .ne. 1d0) STOP 1 + if (det(llt) .ne. 1d0) STOP 2 + + return +c + end + program main + parameter(lnv=32) + implicit double precision (a-h,o-z) dp + common/aux8/ + & x1(lnv),x2(lnv),x3(lnv),x4(lnv), + & x5(lnv),x6(lnv),x7(lnv),x8(lnv), + & y1(lnv),y2(lnv),y3(lnv),y4(lnv), + & y5(lnv),y6(lnv),y7(lnv),y8(lnv), + & z1(lnv),z2(lnv),z3(lnv),z4(lnv), + & z5(lnv),z6(lnv),z7(lnv),z8(lnv) + common/aux36/lft,llt + common/sand1/ihf,ibemf,ishlf,itshf + lft=1 + llt=1 + x1(1)=0 + x2(1)=1 + x3(1)=1 + x4(1)=0 + x5(1)=0 + x6(1)=1 + x7(1)=1 + x8(1)=0 + + y1(1)=0 + y2(1)=0 + y3(1)=1 + y4(1)=1 + y5(1)=0 + y6(1)=0 + y7(1)=1 + y8(1)=1 + + z1(1)=0 + z2(1)=0 + z3(1)=0 + z4(1)=0 + z5(1)=1 + z6(1)=1 + z7(1)=1 + z8(1)=1 + call prtal + stop + end + diff --git a/Fortran/gfortran/regression/compare_interfaces.f90 b/Fortran/gfortran/regression/compare_interfaces.f90 --- /dev/null +++ b/Fortran/gfortran/regression/compare_interfaces.f90 @@ -0,0 +1,73 @@ +! { dg-do compile } +! +! Contributed by Mark Eggleston + +subroutine f(a, b) + integer :: a + real :: b + + write(*,*) a, b +end subroutine + +subroutine g(a, b) + integer :: a + character(*) :: b + + write(*,*) a, b +end subroutine + +subroutine h + interface + subroutine f(a, b) ! { dg-error "\\(CHARACTER\\(\\*\\)/REAL\\(4\\)\\)" } + integer :: a + character(*) :: b + end subroutine + subroutine g(a, b) ! { dg-error "\\(REAL\\(4\\)/CHARACTER\\(\\*\\)\\)" } + integer :: a + real :: b + end subroutine + end interface + + call f(6, 6.0) + call g(6, "abcdef") +end subroutine + +subroutine f4(a, b) + integer :: a + real :: b + + write(*,*) a, b +end subroutine + +subroutine g4(a, b) + integer :: a + character(*,4) :: b + + write(*,*) a, b +end subroutine + +subroutine h4 + interface + subroutine f4(a, b) ! { dg-error "\\(CHARACTER\\(\\*,4\\)/REAL\\(4\\)\\)" } + integer :: a + character(*,4) :: b + end subroutine + subroutine g4(a, b) ! { dg-error "REAL\\(4\\)/CHARACTER\\(\\*,4\\)" } + integer :: a + real :: b + end subroutine + end interface + + call f4(6, 6.0) + call g4(6, 4_"abcdef") +end subroutine + +program test + call h + call h4 +end program + +! { dg-error "passed REAL\\(4\\) to CHARACTER\\(\\*\\)" "type mismatch" { target \*-\*-\* } 31 } +! { dg-error "passed CHARACTER\\(6\\) to REAL\\(4\\)" "type mismatch" { target \*-\*-\* } 32 } +! { dg-error "passed REAL\\(4\\) to CHARACTER\\(\\*,4\\)" "type mismatch" { target \*-\*-\* } 61 } +! { dg-error "passed CHARACTER\\(6,4\\) to REAL\\(4\\)" "type mismatch" { target \*-\*-\* } 62 } diff --git a/Fortran/gfortran/regression/compiler-directive_1.f90 b/Fortran/gfortran/regression/compiler-directive_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/compiler-directive_1.f90 @@ -0,0 +1,48 @@ +! { dg-do compile } +! +! PR fortran/34112 +! +! Check for calling convention consitency +! in procedure-pointer assignments. + +program test + interface + subroutine sub1() + end subroutine sub1 + subroutine sub2() + !GCC$ ATTRIBUTES CDECL :: sub2 + end subroutine sub2 + subroutine sub3() + !GCC$ ATTRIBUTES STDCALL :: sub3 + end subroutine sub3 + subroutine sub4() +!GCC$ ATTRIBUTES FASTCALL :: sub4 + end subroutine sub4 + end interface + + !gcc$ attributes cdecl :: cdecl + !gcc$ attributes stdcall :: stdcall + procedure(), pointer :: ptr + procedure(), pointer :: cdecl + procedure(), pointer :: stdcall + procedure(), pointer :: fastcall + !gcc$ attributes fastcall :: fastcall + + ! Valid: + ptr => sub1 + cdecl => sub2 + stdcall => sub3 + fastcall => sub4 + + ! Invalid: + ptr => sub3 ! { dg-error "mismatch in the calling convention" } + ptr => sub4 ! { dg-error "mismatch in the calling convention" } + cdecl => sub3 ! { dg-error "mismatch in the calling convention" } + cdecl => sub4 ! { dg-error "mismatch in the calling convention" } + stdcall => sub1 ! { dg-error "mismatch in the calling convention" } + stdcall => sub2 ! { dg-error "mismatch in the calling convention" } + stdcall => sub4 ! { dg-error "mismatch in the calling convention" } + fastcall => sub1 ! { dg-error "mismatch in the calling convention" } + fastcall => sub2 ! { dg-error "mismatch in the calling convention" } + fastcall => sub3 ! { dg-error "mismatch in the calling convention" } +end program diff --git a/Fortran/gfortran/regression/compiler-directive_2.f b/Fortran/gfortran/regression/compiler-directive_2.f --- /dev/null +++ b/Fortran/gfortran/regression/compiler-directive_2.f @@ -0,0 +1,10 @@ +! { dg-do compile { target { { i?86-*-* x86_64-*-* } && ia32 } } } +! +! PR fortran/34112 +! +! Check for calling convention consitency +! in procedure-pointer assignments. +! + subroutine test() ! { dg-error "fastcall and stdcall attributes are not compatible" } +cGCC$ attributes stdcall, fastcall::test + end subroutine test diff --git a/Fortran/gfortran/regression/complex_int_1.f90 b/Fortran/gfortran/regression/complex_int_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/complex_int_1.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! Complex constants with integer components should take ther kind from +! the real typed component, or default complex type if both components have +! integer type. +program prog + call test1 ((1_8, 1.0_4)) + call test2 ((1_8, 2_8)) +contains +subroutine test1(x) + complex(4) :: x +end subroutine +subroutine test2(x) + complex :: x +end subroutine +end program diff --git a/Fortran/gfortran/regression/complex_intrinsic_1.f90 b/Fortran/gfortran/regression/complex_intrinsic_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/complex_intrinsic_1.f90 @@ -0,0 +1,5 @@ +! Testcase for the COMPLEX intrinsic +! { dg-do run } + if (complex(1_1, -1_2) /= complex(1.0_4, -1.0_8)) STOP 1 + if (complex(1_4, -1.0) /= complex(1.0_4, -1_8)) STOP 2 + end diff --git a/Fortran/gfortran/regression/complex_intrinsic_2.f90 b/Fortran/gfortran/regression/complex_intrinsic_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/complex_intrinsic_2.f90 @@ -0,0 +1,7 @@ +! Testcase for the COMPLEX intrinsic +! { dg-do compile } + complex c + c = complex(.true.,1.0) ! { dg-error "must be INTEGER or REAL" } + c = complex(1) ! { dg-error "Missing actual argument" } + c = complex(1,c) ! { dg-error "must be INTEGER or REAL" } + end diff --git a/Fortran/gfortran/regression/complex_intrinsic_3.f90 b/Fortran/gfortran/regression/complex_intrinsic_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/complex_intrinsic_3.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! +! PR fortran/33197 +! +! Fortran 2008 complex trigonometric functions: tan, cosh, sinh, tanh +! +implicit none +real(4), parameter :: pi = 2*acos(0.0_4) +real(8), parameter :: pi8 = 2*acos(0.0_8) +real(4), parameter :: eps = 10*epsilon(0.0_4) +real(8), parameter :: eps8 = 10*epsilon(0.0_8) +complex(4), volatile :: z0_0 = cmplx(0.0_4, 0.0_4, kind=4) +complex(4), volatile :: z1_1 = cmplx(1.0_4, 1.0_4, kind=4) +complex(4), volatile :: zp_p = cmplx(pi, pi, kind=4) +complex(8), volatile :: z80_0 = cmplx(0.0_8, 0.0_8, kind=8) +complex(8), volatile :: z81_1 = cmplx(1.0_8, 1.0_8, kind=8) +complex(8), volatile :: z8p_p = cmplx(pi8, pi8, kind=8) + +if (abs(tan(z0_0) - cmplx(0.0,0.0,4)) > eps) STOP 1 +if (abs(tan(z1_1) - cmplx(0.27175257,1.0839232,4)) > eps) STOP 2 +if (abs(tan(z80_0) - cmplx(0.0_8,0.0_8,8)) > eps8) STOP 3 +if (abs(tan(z81_1) - cmplx(0.27175258531951174_8,1.0839233273386946_8,8)) > eps8) STOP 4 + +if (abs(cosh(z0_0) - cmplx(1.0,0.0,4)) > eps) STOP 5 +if (abs(cosh(z1_1) - cmplx(0.83372992,0.98889768,4)) > eps) STOP 6 +if (abs(cosh(z80_0) - cmplx(1.0_8,0.0_8,8)) > eps8) STOP 7 +if (abs(cosh(z81_1) - cmplx(0.83373002513114913_8,0.98889770576286506_8,8)) > eps8) STOP 8 + +if (abs(sinh(z0_0) - cmplx(0.0,0.0,4)) > eps) STOP 9 +if (abs(sinh(z1_1) - cmplx(0.63496387,1.2984575,4)) > eps) STOP 10 +if (abs(sinh(z80_0) - cmplx(0.0_8,0.0_8,8)) > eps8) STOP 11 +if (abs(sinh(z81_1) - cmplx(0.63496391478473613_8,1.2984575814159773_8,8)) > eps8) STOP 12 + +if (abs(tanh(z0_0) - cmplx(0.0,0.0,4)) > eps) STOP 13 +if (abs(tanh(z1_1) - cmplx(1.0839232,0.27175257,4)) > eps) STOP 14 +if (abs(tanh(z80_0) - cmplx(0.0_8,0.0_8,8)) > eps8) STOP 15 +if (abs(tanh(z81_1) - cmplx(1.0839233273386946_8,0.27175258531951174_8,8)) > eps8) STOP 16 + +end diff --git a/Fortran/gfortran/regression/complex_intrinsic_4.f90 b/Fortran/gfortran/regression/complex_intrinsic_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/complex_intrinsic_4.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/33197 +! +! Fortran 2008 complex trigonometric functions: tan, cosh, sinh, tanh +! +real :: r +complex :: z +r = -45.5 +r = sin(r) +r = cos(r) +r = tan(r) +r = cosh(r) +r = sinh(r) +r = tanh(r) +z = 4.0 +z = cos(z) +z = sin(z) +z = tan(z) ! { dg-error "Fortran 2008: COMPLEX argument" } +z = cosh(z)! { dg-error "Fortran 2008: COMPLEX argument" } +z = sinh(z)! { dg-error "Fortran 2008: COMPLEX argument" } +z = tanh(z)! { dg-error "Fortran 2008: COMPLEX argument" } +end diff --git a/Fortran/gfortran/regression/complex_intrinsic_5.f90 b/Fortran/gfortran/regression/complex_intrinsic_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/complex_intrinsic_5.f90 @@ -0,0 +1,219 @@ +! { dg-do run } +! +! PR fortran/33197 +! +! Complex inverse trigonometric functions +! and complex inverse hyperbolic functions +! +! Run-time evaluation check +! +module test + implicit none + real(4), parameter :: eps4 = epsilon(0.0_4)*4.0_4 + real(8), parameter :: eps8 = epsilon(0.0_8)*2.0_8 + interface check + procedure check4, check8 + end interface check +contains + SUBROUTINE check4(z, zref) + complex(4), intent(in) :: z, zref + if ( abs (real(z)-real(zref)) > eps4 & + .or.abs (aimag(z)-aimag(zref)) > eps4) then + print '(a,/,2((2g0," + I ",g0),/))', "check4:"," z=",z,'zref=',zref + print '(a,g0," + I*",g0," eps=",g0)', 'Diff: ', & + real(z)-real(zref), & + aimag(z)-aimag(zref), eps4 + STOP 1 + end if + END SUBROUTINE check4 + SUBROUTINE check8(z, zref) + complex(8), intent(in) :: z, zref + if ( abs (real(z)-real(zref)) > eps8 & + .or.abs (aimag(z)-aimag(zref)) > eps8) then + print '(a,/,2((2g0," + I ",g0),/))', "check8:"," z=",z,'zref=',zref + print '(a,g0," + I*",g0," eps=",g0)', 'Diff: ', & + real(z)-real(zref), & + aimag(z)-aimag(zref), eps8 + STOP 2 + end if + END SUBROUTINE check8 +end module test + +PROGRAM ArcTrigHyp + use test + IMPLICIT NONE + complex(4), volatile :: z4 + complex(8), volatile :: z8 + +!!!!! ZERO !!!!!! + + ! z = 0 + z4 = cmplx(0.0_4, 0.0_4, kind=4) + z8 = cmplx(0.0_8, 0.0_8, kind=8) + + ! Exact: 0 + call check(asin(z4), cmplx(0.0_4, 0.0_4, kind=4)) + call check(asin(z8), cmplx(0.0_8, 0.0_8, kind=8)) + ! Exact: Pi/2 = 1.5707963267948966192313216916397514 + call check(acos(z4), cmplx(1.57079632679489661920_4, 0.0_4, kind=4)) + call check(acos(z8), cmplx(1.57079632679489661920_8, 0.0_8, kind=8)) + ! Exact: 0 + call check(atan(z4), cmplx(0.0_4, 0.0_4, kind=4)) + call check(atan(z8), cmplx(0.0_8, 0.0_8, kind=8)) + ! Exact: 0 + call check(asinh(z4), cmplx(0.0_4, 0.0_4, kind=4)) + call check(asinh(z8), cmplx(0.0_8, 0.0_8, kind=8)) + ! Exact: I*Pi/2 = I*1.5707963267948966192313216916397514 + call check(acosh(z4), cmplx(0.0_4, 1.57079632679489661920_4, kind=4)) + call check(acosh(z8), cmplx(0.0_8, 1.57079632679489661920_8, kind=8)) + ! Exact: 0 + call check(atanh(z4), cmplx(0.0_4, 0.0_4, kind=4)) + call check(atanh(z8), cmplx(0.0_8, 0.0_8, kind=8)) + + +!!!!! POSITIVE NUMBERS !!!!!! + + ! z = tanh(1.0) + z4 = cmplx(0.76159415595576488811945828260479359_4, 0.0_4, kind=4) + z8 = cmplx(0.76159415595576488811945828260479359_8, 0.0_8, kind=8) + + ! Numerically: 0.86576948323965862428960184619184444 + call check(asin(z4), cmplx(0.86576948323965862428960184619184444_4, 0.0_4, kind=4)) + call check(asin(z8), cmplx(0.86576948323965862428960184619184444_8, 0.0_8, kind=8)) + ! Numerically: 0.70502684355523799494171984544790700 + call check(acos(z4), cmplx(0.70502684355523799494171984544790700_4, 0.0_4, kind=4)) + call check(acos(z8), cmplx(0.70502684355523799494171984544790700_8, 0.0_8, kind=8)) + ! Numerically: 0.65088016802300754993807813168285564 + call check(atan(z4), cmplx(0.65088016802300754993807813168285564_4, 0.0_4, kind=4)) + call check(atan(z8), cmplx(0.65088016802300754993807813168285564_8, 0.0_8, kind=8)) + ! Numerically: 0.70239670712987482778422106260749699 + call check(asinh(z4), cmplx(0.70239670712987482778422106260749699_4, 0.0_4, kind=4)) + call check(asinh(z8), cmplx(0.70239670712987482778422106260749699_8, 0.0_8, kind=8)) + ! Numerically: 0.70502684355523799494171984544790700*I + call check(acosh(z4), cmplx(0.0_4, 0.70502684355523799494171984544790700_4, kind=4)) + call check(acosh(z8), cmplx(0.0_8, 0.70502684355523799494171984544790700_8, kind=8)) + ! Exact: 1 + call check(atanh(z4), cmplx(1.0_4, 0.0_4, kind=4)) + call check(atanh(z8), cmplx(1.0_8, 0.0_8, kind=8)) + + + ! z = I*tanh(1.0) + z4 = cmplx(0.0_4, 0.76159415595576488811945828260479359_4, kind=4) + z8 = cmplx(0.0_8, 0.76159415595576488811945828260479359_8, kind=8) + + ! Numerically: I*0.70239670712987482778422106260749699 + call check(asin(z4), cmplx(0.0_4, 0.70239670712987482778422106260749699_4, kind=4)) + call check(asin(z8), cmplx(0.0_8, 0.70239670712987482778422106260749699_8, kind=8)) + ! Numerically: 1.5707963267948966192313216916397514 - I*0.7023967071298748277842210626074970 + call check(acos(z4), cmplx(1.5707963267948966192313216916397514_4, -0.7023967071298748277842210626074970_4, kind=4)) + call check(acos(z8), cmplx(1.5707963267948966192313216916397514_8, -0.7023967071298748277842210626074970_8, kind=8)) + ! Exact: I*1 + call check(atan(z4), cmplx(0.0_4, 1.0_4, kind=4)) + call check(atan(z8), cmplx(0.0_8, 1.0_8, kind=8)) + ! Numerically: I*0.86576948323965862428960184619184444 + call check(asinh(z4), cmplx(0.0_4, 0.86576948323965862428960184619184444_4, kind=4)) + call check(asinh(z8), cmplx(0.0_8, 0.86576948323965862428960184619184444_8, kind=8)) + ! Numerically: 0.7023967071298748277842210626074970 + I*1.5707963267948966192313216916397514 + call check(acosh(z4), cmplx(0.7023967071298748277842210626074970_4, 1.5707963267948966192313216916397514_4, kind=4)) + call check(acosh(z8), cmplx(0.7023967071298748277842210626074970_8, 1.5707963267948966192313216916397514_8, kind=8)) + ! Numerically: I*0.65088016802300754993807813168285564 + call check(atanh(z4), cmplx(0.0_4, 0.65088016802300754993807813168285564_4, kind=4)) + call check(atanh(z8), cmplx(0.0_8, 0.65088016802300754993807813168285564_8, kind=8)) + + + ! z = (1+I)*tanh(1.0) + z4 = cmplx(0.76159415595576488811945828260479359_4, 0.76159415595576488811945828260479359_4, kind=4) + z8 = cmplx(0.76159415595576488811945828260479359_8, 0.76159415595576488811945828260479359_8, kind=8) + + ! Numerically: 0.59507386031622633330574869409179139 + I*0.82342412550090412964986631390412834 + call check(asin(z4), cmplx(0.59507386031622633330574869409179139_4, 0.82342412550090412964986631390412834_4, kind=4)) + call check(asin(z8), cmplx(0.59507386031622633330574869409179139_8, 0.82342412550090412964986631390412834_8, kind=8)) + ! Numerically: 0.97572246647867028592557299754796005 - I*0.82342412550090412964986631390412834 + call check(acos(z4), cmplx(0.97572246647867028592557299754796005_4, -0.82342412550090412964986631390412834_4, kind=4)) + call check(acos(z8), cmplx(0.97572246647867028592557299754796005_8, -0.82342412550090412964986631390412834_8, kind=8)) + ! Numerically: 0.83774433133636226305479129936568267 + I*0.43874835208710654149508159123595167 + call check(atan(z4), cmplx(0.83774433133636226305479129936568267_4, 0.43874835208710654149508159123595167_4, kind=4)) + call check(atan(z8), cmplx(0.83774433133636226305479129936568267_8, 0.43874835208710654149508159123595167_8, kind=8)) + ! Numerically: 0.82342412550090412964986631390412834 + I*0.59507386031622633330574869409179139 + call check(asinh(z4), cmplx(0.82342412550090412964986631390412834_4, 0.59507386031622633330574869409179139_4, kind=4)) + call check(asinh(z8), cmplx(0.82342412550090412964986631390412834_8, 0.59507386031622633330574869409179139_8, kind=8)) + ! Numerically: 0.82342412550090412964986631390412834 + I*0.97572246647867028592557299754796005 + call check(acosh(z4), cmplx(0.82342412550090412964986631390412834_4, 0.97572246647867028592557299754796005_4, kind=4)) + call check(acosh(z8), cmplx(0.82342412550090412964986631390412834_8, 0.97572246647867028592557299754796005_8, kind=8)) + ! Numerically: 0.43874835208710654149508159123595167 + I*0.83774433133636226305479129936568267 + call check(atanh(z4), cmplx(0.43874835208710654149508159123595167_4, 0.83774433133636226305479129936568267_4, kind=4)) + call check(atanh(z8), cmplx(0.43874835208710654149508159123595167_8, 0.83774433133636226305479129936568267_8, kind=8)) + + + ! z = 1+I + z4 = cmplx(1.0_4, 1.0_4, kind=4) + z8 = cmplx(1.0_8, 1.0_8, kind=8) + + ! Numerically: 0.66623943249251525510400489597779272 + I*1.06127506190503565203301891621357349 + call check(asin(z4), cmplx(0.66623943249251525510400489597779272_4, 1.06127506190503565203301891621357349_4, kind=4)) + call check(asin(z8), cmplx(0.66623943249251525510400489597779272_8, 1.06127506190503565203301891621357349_8, kind=8)) + ! Numerically: 0.90455689430238136412731679566195872 - I*1.06127506190503565203301891621357349 + call check(acos(z4), cmplx(0.90455689430238136412731679566195872_4, -1.06127506190503565203301891621357349_4, kind=4)) + call check(acos(z8), cmplx(0.90455689430238136412731679566195872_8, -1.06127506190503565203301891621357349_8, kind=8)) + ! Numerically: 1.01722196789785136772278896155048292 + I*0.40235947810852509365018983330654691 + call check(atan(z4), cmplx(1.01722196789785136772278896155048292_4, 0.40235947810852509365018983330654691_4, kind=4)) + call check(atan(z8), cmplx(1.01722196789785136772278896155048292_8, 0.40235947810852509365018983330654691_8, kind=8)) + ! Numerically: 1.06127506190503565203301891621357349 + I*0.66623943249251525510400489597779272 + call check(asinh(z4), cmplx(1.06127506190503565203301891621357349_4, 0.66623943249251525510400489597779272_4, kind=4)) + call check(asinh(z8), cmplx(1.06127506190503565203301891621357349_8, 0.66623943249251525510400489597779272_8, kind=8)) + ! Numerically: 1.06127506190503565203301891621357349 + I*0.90455689430238136412731679566195872 + call check(acosh(z4), cmplx(1.06127506190503565203301891621357349_4, 0.90455689430238136412731679566195872_4, kind=4)) + call check(acosh(z8), cmplx(1.06127506190503565203301891621357349_8, 0.90455689430238136412731679566195872_8, kind=8)) + ! Numerically: 0.40235947810852509365018983330654691 + I*1.01722196789785136772278896155048292 + call check(atanh(z4), cmplx(0.40235947810852509365018983330654691_4, 1.01722196789785136772278896155048292_4, kind=4)) + call check(atanh(z8), cmplx(0.40235947810852509365018983330654691_8, 1.01722196789785136772278896155048292_8, kind=8)) + + + ! z = (1+I)*1.1 + z4 = cmplx(1.1_4, 1.1_4, kind=4) + z8 = cmplx(1.1_8, 1.1_8, kind=8) + + ! Numerically: 0.68549840630267734494444454677951503 + I*1.15012680127435581678415521738176733 + call check(asin(z4), cmplx(0.68549840630267734494444454677951503_4, 1.15012680127435581678415521738176733_4, kind=4)) + call check(asin(z8), cmplx(0.68549840630267734494444454677951503_8, 1.15012680127435581678415521738176733_8, kind=8)) + ! Numerically: 0.8852979204922192742868771448602364 - I*1.1501268012743558167841552173817673 + call check(acos(z4), cmplx(0.8852979204922192742868771448602364_4, -1.1501268012743558167841552173817673_4, kind=4)) + call check(acos(z8), cmplx(0.8852979204922192742868771448602364_8, -1.1501268012743558167841552173817673_8, kind=8)) + ! Numerically: 1.07198475450905931839240655913126728 + I*0.38187020129010862908881230531688930 + call check(atan(z4), cmplx(1.07198475450905931839240655913126728_4, 0.38187020129010862908881230531688930_4, kind=4)) + call check(atan(z8), cmplx(1.07198475450905931839240655913126728_8, 0.38187020129010862908881230531688930_8, kind=8)) + ! Numerically: 1.15012680127435581678415521738176733 + I*0.68549840630267734494444454677951503 + call check(asinh(z4), cmplx(1.15012680127435581678415521738176733_4, 0.68549840630267734494444454677951503_4, kind=4)) + call check(asinh(z8), cmplx(1.15012680127435581678415521738176733_8, 0.68549840630267734494444454677951503_8, kind=8)) + ! Numerically: 1.1501268012743558167841552173817673 + I*0.8852979204922192742868771448602364 + call check(acosh(z4), cmplx(1.1501268012743558167841552173817673_4, 0.8852979204922192742868771448602364_4, kind=4)) + call check(acosh(z8), cmplx(1.1501268012743558167841552173817673_8, 0.8852979204922192742868771448602364_8, kind=8)) + ! Numerically: 0.38187020129010862908881230531688930 + I*1.07198475450905931839240655913126728 + call check(atanh(z4), cmplx(0.38187020129010862908881230531688930_4, 1.07198475450905931839240655913126728_4, kind=4)) + call check(atanh(z8), cmplx(0.38187020129010862908881230531688930_8, 1.07198475450905931839240655913126728_8, kind=8)) + + +!!!!! Negative NUMBERS !!!!!! + ! z = -(1+I)*1.1 + z4 = cmplx(-1.1_4, -1.1_4, kind=4) + z8 = cmplx(-1.1_8, -1.1_8, kind=8) + + ! Numerically: -0.68549840630267734494444454677951503 - I*1.15012680127435581678415521738176733 + call check(asin(z4), cmplx(-0.68549840630267734494444454677951503_4, -1.15012680127435581678415521738176733_4, kind=4)) + call check(asin(z8), cmplx(-0.68549840630267734494444454677951503_8, -1.15012680127435581678415521738176733_8, kind=8)) + ! Numerically: 2.2562947330975739641757662384192665 + I*1.1501268012743558167841552173817673 + call check(acos(z4), cmplx(2.2562947330975739641757662384192665_4, 1.1501268012743558167841552173817673_4, kind=4)) + call check(acos(z8), cmplx(2.2562947330975739641757662384192665_8, 1.1501268012743558167841552173817673_8, kind=8)) + ! Numerically: -1.07198475450905931839240655913126728 - I*0.38187020129010862908881230531688930 + call check(atan(z4), cmplx(-1.07198475450905931839240655913126728_4, -0.38187020129010862908881230531688930_4, kind=4)) + call check(atan(z8), cmplx(-1.07198475450905931839240655913126728_8, -0.38187020129010862908881230531688930_8, kind=8)) + ! Numerically: -1.15012680127435581678415521738176733 - I*0.68549840630267734494444454677951503 + call check(asinh(z4), cmplx(-1.15012680127435581678415521738176733_4, -0.68549840630267734494444454677951503_4, kind=4)) + call check(asinh(z8), cmplx(-1.15012680127435581678415521738176733_8, -0.68549840630267734494444454677951503_8, kind=8)) + ! Numerically: 1.1501268012743558167841552173817673 - I*2.2562947330975739641757662384192665 + call check(acosh(z4), cmplx(1.1501268012743558167841552173817673_4, -2.2562947330975739641757662384192665_4, kind=4)) + call check(acosh(z8), cmplx(1.1501268012743558167841552173817673_8, -2.2562947330975739641757662384192665_8, kind=8)) + ! Numerically: 0.38187020129010862908881230531688930 + I*1.07198475450905931839240655913126728 + call check(atanh(z4), cmplx(-0.38187020129010862908881230531688930_4, -1.07198475450905931839240655913126728_4, kind=4)) + call check(atanh(z8), cmplx(-0.38187020129010862908881230531688930_8, -1.07198475450905931839240655913126728_8, kind=8)) +END PROGRAM ArcTrigHyp diff --git a/Fortran/gfortran/regression/complex_intrinsic_6.f90 b/Fortran/gfortran/regression/complex_intrinsic_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/complex_intrinsic_6.f90 @@ -0,0 +1,41 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/33197 +! PR fortran/40728 +! +! Complex inverse trigonometric functions +! and complex inverse hyperbolic functions +! +! Argument type check +! + +PROGRAM ArcTrigHyp + IMPLICIT NONE + real(4), volatile :: r4 + real(8), volatile :: r8 + complex(4), volatile :: z4 + complex(8), volatile :: z8 + + r4 = 0.0_4 + r8 = 0.0_8 + z4 = cmplx(0.0_4, 0.0_4, kind=4) + z8 = cmplx(0.0_8, 0.0_8, kind=8) + + r4 = asin(r4) + r8 = asin(r8) + r4 = acos(r4) + r8 = acos(r8) + r4 = atan(r4) + r8 = atan(r8) + +! a(sin,cos,tan)h cannot be checked as they are not part of +! Fortran 2003 - not even for real arguments + + z4 = asin(z4) ! { dg-error "Fortran 2008: COMPLEX argument" } + z8 = asin(z8) ! { dg-error "Fortran 2008: COMPLEX argument" } + z4 = acos(z4) ! { dg-error "Fortran 2008: COMPLEX argument" } + z8 = acos(z8) ! { dg-error "Fortran 2008: COMPLEX argument" } + z4 = atan(z4) ! { dg-error "Fortran 2008: COMPLEX argument" } + z8 = atan(z8) ! { dg-error "Fortran 2008: COMPLEX argument" } +END PROGRAM ArcTrigHyp diff --git a/Fortran/gfortran/regression/complex_intrinsic_7.f90 b/Fortran/gfortran/regression/complex_intrinsic_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/complex_intrinsic_7.f90 @@ -0,0 +1,43 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/33197 +! +! Fortran 2008 complex trigonometric functions: tan, cosh, sinh, tanh +! +! Compile-time simplificiations +! +implicit none +real(4), parameter :: pi = 2*acos(0.0_4) +real(8), parameter :: pi8 = 2*acos(0.0_8) +real(4), parameter :: eps = 10*epsilon(0.0_4) +real(8), parameter :: eps8 = 10*epsilon(0.0_8) +complex(4), parameter :: z0_0 = cmplx(0.0_4, 0.0_4, kind=4) +complex(4), parameter :: z1_1 = cmplx(1.0_4, 1.0_4, kind=4) +complex(4), parameter :: zp_p = cmplx(pi, pi, kind=4) +complex(8), parameter :: z80_0 = cmplx(0.0_8, 0.0_8, kind=8) +complex(8), parameter :: z81_1 = cmplx(1.0_8, 1.0_8, kind=8) +complex(8), parameter :: z8p_p = cmplx(pi8, pi8, kind=8) + +if (abs(tan(z0_0) - cmplx(0.0,0.0,4)) > eps) STOP 1 +if (abs(tan(z1_1) - cmplx(0.27175257,1.0839232,4)) > eps) STOP 2 +if (abs(tan(z80_0) - cmplx(0.0_8,0.0_8,8)) > eps8) STOP 3 +if (abs(tan(z81_1) - cmplx(0.27175258531951174_8,1.0839233273386946_8,8)) > eps8) STOP 4 + +if (abs(cosh(z0_0) - cmplx(1.0,0.0,4)) > eps) STOP 5 +if (abs(cosh(z1_1) - cmplx(0.83372992,0.98889768,4)) > eps) STOP 6 +if (abs(cosh(z80_0) - cmplx(1.0_8,0.0_8,8)) > eps8) STOP 7 +if (abs(cosh(z81_1) - cmplx(0.83373002513114913_8,0.98889770576286506_8,8)) > eps8) STOP 8 + +if (abs(sinh(z0_0) - cmplx(0.0,0.0,4)) > eps) STOP 9 +if (abs(sinh(z1_1) - cmplx(0.63496387,1.2984575,4)) > eps) STOP 10 +if (abs(sinh(z80_0) - cmplx(0.0_8,0.0_8,8)) > eps8) STOP 11 +if (abs(sinh(z81_1) - cmplx(0.63496391478473613_8,1.2984575814159773_8,8)) > eps8) STOP 12 + +if (abs(tanh(z0_0) - cmplx(0.0,0.0,4)) > eps) STOP 13 +if (abs(tanh(z1_1) - cmplx(1.0839232,0.27175257,4)) > eps) STOP 14 +if (abs(tanh(z80_0) - cmplx(0.0_8,0.0_8,8)) > eps8) STOP 15 +if (abs(tanh(z81_1) - cmplx(1.0839233273386946_8,0.27175258531951174_8,8)) > eps8) STOP 16 + +end +! { dg-final { scan-tree-dump-times "_gfortran_stop" 0 "original" } } diff --git a/Fortran/gfortran/regression/complex_intrinsic_8.f90 b/Fortran/gfortran/regression/complex_intrinsic_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/complex_intrinsic_8.f90 @@ -0,0 +1,49 @@ +! { dg-do link } +! +! PR fortran/33197 +! +! Fortran complex trigonometric functions: acos, asin, atan, acosh, asinh, atanh +! +! Compile-time simplifications +! +implicit none +real(4), parameter :: pi = 2*acos(0.0_4) +real(8), parameter :: pi8 = 2*acos(0.0_8) +real(4), parameter :: eps = 10*epsilon(0.0_4) +real(8), parameter :: eps8 = 10*epsilon(0.0_8) +complex(4), parameter :: z0_0 = cmplx(0.0_4, 0.0_4, kind=4) +complex(4), parameter :: z1_1 = cmplx(1.0_4, 1.0_4, kind=4) +complex(8), parameter :: z80_0 = cmplx(0.0_8, 0.0_8, kind=8) +complex(8), parameter :: z81_1 = cmplx(1.0_8, 1.0_8, kind=8) + +if (abs(acos(z0_0) - cmplx(pi/2,-0.0,4)) > eps) call link_error() +if (abs(acos(z1_1) - cmplx(0.904556894, -1.06127506,4)) > eps) call link_error() +if (abs(acos(z80_0) - cmplx(pi8/2,-0.0_8,8)) > eps8) call link_error() +if (abs(acos(z81_1) - cmplx(0.90455689430238140_8, -1.0612750619050357_8,8)) > eps8) call link_error() + +if (abs(asin(z0_0) - cmplx(0.0,0.0,4)) > eps) call link_error() +if (abs(asin(z1_1) - cmplx(0.66623943, 1.06127506,4)) > eps) call link_error() +if (abs(asin(z80_0) - cmplx(0.0_8,0.0_8,8)) > eps8) call link_error() +if (abs(asin(z81_1) - cmplx(0.66623943249251527_8, 1.0612750619050357_8,8)) > eps8) call link_error() + +if (abs(atan(z0_0) - cmplx(0.0,0.0,4)) > eps) call link_error() +if (abs(atan(z1_1) - cmplx(1.01722196, 0.40235947,4)) > eps) call link_error() +if (abs(atan(z80_0) - cmplx(0.0_8,0.0_8,8)) > eps8) call link_error() +if (abs(atan(z81_1) - cmplx(1.0172219678978514_8, 0.40235947810852507_8,8)) > eps8) call link_error() + +if (abs(acosh(z0_0) - cmplx(0.0,pi/2,4)) > eps) call link_error() +if (abs(acosh(z1_1) - cmplx(1.06127506, 0.90455689,4)) > eps) call link_error() +if (abs(acosh(z80_0) - cmplx(0.0_8,pi8/2,8)) > eps8) call link_error() +if (abs(acosh(z81_1) - cmplx(1.0612750619050357_8, 0.90455689430238140_8,8)) > eps8) call link_error() + +if (abs(asinh(z0_0) - cmplx(0.0,0.0,4)) > eps) call link_error() +if (abs(asinh(z1_1) - cmplx(1.06127506, 0.66623943,4)) > eps) call link_error() +if (abs(asinh(z80_0) - cmplx(0.0_8,0.0_8,8)) > eps8) call link_error() +if (abs(asinh(z81_1) - cmplx(1.0612750619050357_8, 0.66623943249251527_8,8)) > eps8) call link_error() + +if (abs(atanh(z0_0) - cmplx(0.0,0.0,4)) > eps) call link_error() +if (abs(atanh(z1_1) - cmplx(0.40235947, 1.01722196,4)) > eps) call link_error() +if (abs(atanh(z80_0) - cmplx(0.0_8,0.0_8,8)) > eps8) call link_error() +if (abs(atanh(z81_1) - cmplx(0.40235947810852507_8, 1.0172219678978514_8,8)) > eps8) call link_error() + +end diff --git a/Fortran/gfortran/regression/complex_parameter_1.f90 b/Fortran/gfortran/regression/complex_parameter_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/complex_parameter_1.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-std=f95" } + integer,parameter :: i = 42 + real,parameter :: x = 17. + complex,parameter :: z = (1.,2.) + complex,parameter :: c1 = (i, 0.5) ! { dg-error "Fortran 2003: PARAMETER symbol in complex constant" } + complex,parameter :: c2 = (x, 0.5) ! { dg-error "Fortran 2003: PARAMETER symbol in complex constant" } + complex,parameter :: c3 = (z, 0.) ! { dg-error "Fortran 2003: PARAMETER symbol in complex constant" } + print *, c1, c2, c3 + end diff --git a/Fortran/gfortran/regression/complex_read.f90 b/Fortran/gfortran/regression/complex_read.f90 --- /dev/null +++ b/Fortran/gfortran/regression/complex_read.f90 @@ -0,0 +1,58 @@ +! { dg-do run { target fd_truncate } } +! Test of the fix to the bug in NIST fm906.for. +! Contributed by Paul Thomas +! +program complex_read + complex :: a + open (10, status="scratch") + +! Test that we have not broken the one line form. + + write (10, *) " ( 0.99 , 9.9 )" + rewind (10) + read (10,*) a + if (a.ne.(0.99, 9.90)) STOP 1 + +! Test a new record after the.comma (the original bug). + + rewind (10) + write (10, *) " ( 99.0 ," + write (10, *) " 999.0 )" + rewind (10) + read (10,*) a + if (a.ne.(99.0, 999.0)) STOP 2 + +! Test a new record before the.comma + + rewind (10) + write (10, *) " ( 0.99 " + write (10, *) " , 9.9 )" + rewind (10) + read (10,*) a + if (a.ne.(0.99, 9.90)) STOP 3 + +! Test a new records before and after the.comma + + rewind (10) + write (10, *) " ( 99.0 " + write (10, *) ", " + write (10, *) " 999.0 )" + rewind (10) + read (10,*) a + if (a.ne.(99.0, 999.0)) STOP 4 + +! Test a new records and blank records before and after the.comma + + rewind (10) + write (10, *) " ( 0.99 " + write (10, *) " " + write (10, *) ", " + write (10, *) " " + write (10, *) " 9.9 )" + rewind (10) + read (10,*) a + if (a.ne.(0.99, 9.9)) STOP 5 + + close (10) +end program complex_read + diff --git a/Fortran/gfortran/regression/complex_write.f90 b/Fortran/gfortran/regression/complex_write.f90 --- /dev/null +++ b/Fortran/gfortran/regression/complex_write.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! pr 19071 +! test case provided by +! Thomas.Koenig@online.de + program cio + complex a + real r1,r2 + a = cmplx(1.0, 2.0) + open(unit=74,status='scratch') + write(74,'(1P,E13.5)')a + rewind(74) +! can read the complex in as two reals, one on each line + read(74,'(E13.5)')r1,r2 + if (r1.ne.1.0 .and. r2.ne.2.0) STOP 1 + end diff --git a/Fortran/gfortran/regression/compliant_elemental_intrinsics_1.f90 b/Fortran/gfortran/regression/compliant_elemental_intrinsics_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/compliant_elemental_intrinsics_1.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! Tests the fix for PR26976, in which non-compliant elemental +! intrinsic function results were not detected. At the same +! time, the means to tests the compliance of TRANSFER with the +! optional SIZE parameter was added. +! +! Contributed by Dominique Dhumieres +! +real(4) :: pi, a(2), b(3) +character(26) :: ch + +pi = acos(-1.0) +b = pi + +a = cos(b) ! { dg-error "Different shape for array assignment" } + +a = -pi +b = cos(a) ! { dg-error "Different shape for array assignment" } + +ch = "abcdefghijklmnopqrstuvwxyz" +a = transfer (ch, pi, 3) ! { dg-error "Different shape for array assignment" } + +! This already generated an error +b = reshape ((/1.0/),(/1/)) ! { dg-error "Different shape for array assignment" } + +end diff --git a/Fortran/gfortran/regression/compliant_elemental_intrinsics_2.f90 b/Fortran/gfortran/regression/compliant_elemental_intrinsics_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/compliant_elemental_intrinsics_2.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! +! Testcases from PR32002. +! +PROGRAM test_pr32002 + + CALL test_1() ! scalar/vector + CALL test_2() ! vector/vector + CALL test_3() ! matrix/vector + CALL test_4() ! matrix/matrix + +CONTAINS + ELEMENTAL FUNCTION f(x) + INTEGER, INTENT(in) :: x + INTEGER :: f + f = x + END FUNCTION + + SUBROUTINE test_1() + INTEGER :: a = 0, b(2) = 0 + a = f(b) ! { dg-error "Incompatible ranks" } + b = f(a) ! ok, set all array elements to f(a) + END SUBROUTINE + + SUBROUTINE test_2() + INTEGER :: a(2) = 0, b(3) = 0 + a = f(b) ! { dg-error "Different shape" } + a = f(b(1:2)) ! ok, slice, stride 1 + a = f(b(1:3:2)) ! ok, slice, stride 2 + END SUBROUTINE + + SUBROUTINE test_3() + INTEGER :: a(4) = 0, b(2,2) = 0 + a = f(b) ! { dg-error "Incompatible ranks" } + a = f(RESHAPE(b, (/ 4 /))) ! ok, same shape + END SUBROUTINE + + SUBROUTINE test_4() + INTEGER :: a(2,2) = 0, b(3,3) = 0 + a = f(b) ! { dg-error "Different shape" } + a = f(b(1:3, 1:2)) ! { dg-error "Different shape" } + a = f(b(1:3:2, 1:3:2)) ! ok, same shape + END SUBROUTINE +END PROGRAM diff --git a/Fortran/gfortran/regression/conflicts.f90 b/Fortran/gfortran/regression/conflicts.f90 --- /dev/null +++ b/Fortran/gfortran/regression/conflicts.f90 @@ -0,0 +1,51 @@ +! { dg-do compile } +! Check for conflicts +! PR fortran/29657 + +function f1() ! { dg-error "PROCEDURE attribute conflicts with SAVE attribute" } + implicit none + real, save :: f1 + f1 = 1.0 +end function f1 + +function f2() ! { dg-error "PROCEDURE attribute conflicts with SAVE attribute" } + implicit none + real :: f2 + save f2 + f2 = 1.0 +end function f2 + +subroutine f3() + implicit none + dimension f3(3) ! { dg-error "SUBROUTINE attribute conflicts with DIMENSION attribute" } +end subroutine f3 + +subroutine f4(b) + implicit none + real :: b + entry b ! { dg-error "DUMMY attribute conflicts with ENTRY attribute" } +end subroutine f4 + +function f5(a) + implicit none + real :: a,f5 + entry a ! { dg-error "DUMMY attribute conflicts with ENTRY attribute" } + f5 = 3.4 +end function f5 + +subroutine f6(cos) + implicit none + real :: cos + intrinsic cos ! { dg-error "DUMMY attribute conflicts with INTRINSIC attribute" } +end subroutine f6 + +subroutine f7(sin) + implicit none + real :: sin + external sin +end subroutine f7 + +program test + implicit none + dimension test(3) ! { dg-error "PROGRAM attribute conflicts with DIMENSION attribute" } +end program test diff --git a/Fortran/gfortran/regression/conflicts_2.f90 b/Fortran/gfortran/regression/conflicts_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/conflicts_2.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! +! Check conflicts: +! - PARAMETER and BIND(C), PR fortran/33310 +! - INTRINSIC and ENTRY, PR fortran/33284 +! + +subroutine a + intrinsic cos +entry cos(x) ! { dg-error "ENTRY attribute conflicts with INTRINSIC" } + real x + x = 0 +end subroutine + +module m + use iso_c_binding + implicit none + TYPE, bind(C) :: the_distribution + INTEGER(c_int) :: parameters(1) + END TYPE the_distribution + TYPE (the_distribution), parameter, bind(C) :: & ! { dg-error "PARAMETER attribute conflicts with BIND.C." } + the_beta = the_distribution((/0/)) +end module m + +end diff --git a/Fortran/gfortran/regression/constant_shape.f90 b/Fortran/gfortran/regression/constant_shape.f90 --- /dev/null +++ b/Fortran/gfortran/regression/constant_shape.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! +! PR 78392: ICE in gfc_trans_auto_array_allocation, at fortran/trans-array.c:5979 +! +! Contributed by Janus Weil +! Error message update with patch for PR fortran/83633 +! +module mytypes + implicit none + contains + pure integer function get_i () + get_i = 13 + end function +end module + +program test + use mytypes + implicit none + integer, dimension(get_i()) :: x ! { dg-error "array with nonconstant bounds" } + print *, size (x) ! { dg-error "has no IMPLICIT type" } +end diff --git a/Fortran/gfortran/regression/constant_substring.f b/Fortran/gfortran/regression/constant_substring.f --- /dev/null +++ b/Fortran/gfortran/regression/constant_substring.f @@ -0,0 +1,13 @@ +! Simplify constant substring +! { dg-do run } +! { dg-options "-std=legacy" } +! + character*2 a + character*4 b + character*6 c + parameter (a="12") + parameter (b = a(1:2)) + write (c,'("#",A,"#")') b + if (c .ne. '#12 #') STOP 1 + end + diff --git a/Fortran/gfortran/regression/constructor_1.f90 b/Fortran/gfortran/regression/constructor_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/constructor_1.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! +! PR fortran/39427 +! +! Check constructor functionality. +! +! Contributed by Damian Rouson. +! +module mycomplex_module + private + public :: mycomplex + type mycomplex +! private + real :: argument, modulus + end type + interface mycomplex + module procedure complex_to_mycomplex, two_reals_to_mycomplex + end interface +! : + contains + type(mycomplex) function complex_to_mycomplex(c) + complex, intent(in) :: c +! : + end function complex_to_mycomplex + type(mycomplex) function two_reals_to_mycomplex(x,y) + real, intent(in) :: x + real, intent(in), optional :: y +! : + end function two_reals_to_mycomplex +! : + end module mycomplex_module +! : +program myuse + use mycomplex_module + type(mycomplex) :: a, b, c +! : + a = mycomplex(argument=5.6, modulus=1.0) ! The structure constructor + c = mycomplex(x=0.0, y=1.0) ! A function reference + c = mycomplex(0.0, 1.0) ! A function reference +end program myuse diff --git a/Fortran/gfortran/regression/constructor_2.f90 b/Fortran/gfortran/regression/constructor_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/constructor_2.f90 @@ -0,0 +1,72 @@ +! { dg-do run } +! +! PR fortran/39427 +! +module foo_module + interface foo + procedure constructor + end interface + + type foo + integer :: bar + end type +contains + type(foo) function constructor() + constructor%bar = 1 + end function + + subroutine test_foo() + type(foo) :: f + f = foo() + if (f%bar /= 1) STOP 1 + f = foo(2) + if (f%bar /= 2) STOP 2 + end subroutine test_foo +end module foo_module + + +! Same as foo_module but order +! of INTERFACE and TYPE reversed +module bar_module + type bar + integer :: bar + end type + + interface bar + procedure constructor + end interface +contains + type(bar) function constructor() + constructor%bar = 3 + end function + + subroutine test_bar() + type(bar) :: f + f = bar() + if (f%bar /= 3) STOP 3 + f = bar(4) + if (f%bar /= 4) STOP 4 + end subroutine test_bar +end module bar_module + +program main + use foo_module + use bar_module + implicit none + + type(foo) :: f + type(bar) :: b + + call test_foo() + f = foo() + if (f%bar /= 1) STOP 5 + f = foo(2) + if (f%bar /= 2) STOP 6 + + call test_bar() + b = bar() + if (b%bar /= 3) STOP 7 + b = bar(4) + if (b%bar /= 4) STOP 8 +end program main + diff --git a/Fortran/gfortran/regression/constructor_3.f90 b/Fortran/gfortran/regression/constructor_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/constructor_3.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! +! PR fortran/39427 +! +! Check constructor functionality. +! +! +module m + interface cons + procedure cons42 + end interface cons +contains + integer function cons42() + cons42 = 42 + end function cons42 +end module m + + +module m2 + type cons + integer :: j = -1 + end type cons + interface cons + procedure consT + end interface cons +contains + type(cons) function consT(k) + integer :: k + consT%j = k**2 + end function consT +end module m2 + + +use m +use m2, only: cons +implicit none +type(cons) :: x +integer :: k +x = cons(3) +k = cons() +if (x%j /= 9) STOP 1 +if (k /= 42) STOP 2 +!print *, x%j +!print *, k +end diff --git a/Fortran/gfortran/regression/constructor_4.f90 b/Fortran/gfortran/regression/constructor_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/constructor_4.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! PR fortran/39427 +! +! Check constructor functionality. +! +! +module m + type t ! { dg-error "the same name as derived type" } + integer :: x + end type t + interface t + module procedure f + end interface t +contains + function f() ! { dg-error "the same name as derived type" } + type(t) :: f + end function +end module + +module m2 + interface t2 + module procedure f2 + end interface t2 + type t2 ! { dg-error "the same name as derived type" } + integer :: x2 + end type t2 +contains + function f2() ! { dg-error "the same name as derived type" } + type(t2) :: f2 + end function +end module diff --git a/Fortran/gfortran/regression/constructor_5.f90 b/Fortran/gfortran/regression/constructor_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/constructor_5.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! +! PR fortran/39427 +! +! Check constructor functionality. +! +! +module m + type t + integer :: x + end type t + interface t + module procedure f + end interface t +contains + function f() + type(t) :: f + end function +end module + +module m2 + interface t2 + module procedure f2 + end interface t2 + type t2 + integer :: x2 + end type t2 +contains + function f2() + type(t2) :: f2 + end function +end module diff --git a/Fortran/gfortran/regression/constructor_6.f90 b/Fortran/gfortran/regression/constructor_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/constructor_6.f90 @@ -0,0 +1,169 @@ +! { dg-do run } +! +! PR fortran/39427 +! +! Contributed by Norman S. Clerman (in PR fortran/45155) +! +! Constructor test case +! +! +module test_cnt + integer, public, save :: my_test_cnt = 0 +end module test_cnt + +module Rational + use test_cnt + implicit none + private + + type, public :: rational_t + integer :: n = 0, id = 1 + contains + procedure, nopass :: Construct_rational_t + procedure :: Print_rational_t + procedure, private :: Rational_t_init + generic :: Rational_t => Construct_rational_t + generic :: print => Print_rational_t + end type rational_t + +contains + + function Construct_rational_t (message_) result (return_type) + character (*), intent (in) :: message_ + type (rational_t) :: return_type + +! print *, trim (message_) + if (my_test_cnt /= 1) STOP 1 + my_test_cnt = my_test_cnt + 1 + call return_type % Rational_t_init + + end function Construct_rational_t + + subroutine Print_rational_t (this_) + class (rational_t), intent (in) :: this_ + +! print *, "n, id", this_% n, this_% id + if (my_test_cnt == 0) then + if (this_% n /= 0 .or. this_% id /= 1) STOP 2 + else if (my_test_cnt == 2) then + if (this_% n /= 10 .or. this_% id /= 0) STOP 3 + else + STOP 4 + end if + my_test_cnt = my_test_cnt + 1 + end subroutine Print_rational_t + + subroutine Rational_t_init (this_) + class (rational_t), intent (in out) :: this_ + + this_% n = 10 + this_% id = 0 + + end subroutine Rational_t_init + +end module Rational + +module Temp_node + use test_cnt + implicit none + private + + real, parameter :: NOMINAL_TEMP = 20.0 + + type, public :: temp_node_t + real :: temperature = NOMINAL_TEMP + integer :: id = 1 + contains + procedure :: Print_temp_node_t + procedure, private :: Temp_node_t_init + generic :: Print => Print_temp_node_t + end type temp_node_t + + interface temp_node_t + module procedure Construct_temp_node_t + end interface + +contains + + function Construct_temp_node_t (message_) result (return_type) + character (*), intent (in) :: message_ + type (temp_node_t) :: return_type + + !print *, trim (message_) + if (my_test_cnt /= 4) STOP 5 + my_test_cnt = my_test_cnt + 1 + call return_type % Temp_node_t_init + + end function Construct_temp_node_t + + subroutine Print_temp_node_t (this_) + class (temp_node_t), intent (in) :: this_ + +! print *, "temp, id", this_% temperature, this_% id + if (my_test_cnt == 3) then + if (this_% temperature /= 20 .or. this_% id /= 1) STOP 6 + else if (my_test_cnt == 5) then + if (this_% temperature /= 10 .or. this_% id /= 0) STOP 7 + else + STOP 8 + end if + my_test_cnt = my_test_cnt + 1 + end subroutine Print_temp_node_t + + subroutine Temp_node_t_init (this_) + class (temp_node_t), intent (in out) :: this_ + + this_% temperature = 10.0 + this_% id = 0 + + end subroutine Temp_node_t_init + +end module Temp_node + +program Struct_over + use test_cnt + use Rational, only : rational_t + use Temp_node, only : temp_node_t + + implicit none + + type (rational_t) :: sample_rational_t + type (temp_node_t) :: sample_temp_node_t + +! print *, "rational_t" +! print *, "----------" +! print *, "" +! +! print *, "after declaration" + if (my_test_cnt /= 0) STOP 9 + call sample_rational_t % print + + if (my_test_cnt /= 1) STOP 10 + + sample_rational_t = sample_rational_t % rational_t ("using override") + if (my_test_cnt /= 2) STOP 11 +! print *, "after override" + ! call print (sample_rational_t) + ! call sample_rational_t % print () + call sample_rational_t % print + + if (my_test_cnt /= 3) STOP 12 + +! print *, "sample_t" +! print *, "--------" +! print *, "" +! +! print *, "after declaration" + call sample_temp_node_t % print + + if (my_test_cnt /= 4) STOP 13 + + sample_temp_node_t = temp_node_t ("using override") + if (my_test_cnt /= 5) STOP 14 +! print *, "after override" + ! call print (sample_rational_t) + ! call sample_rational_t % print () + call sample_temp_node_t % print + if (my_test_cnt /= 6) STOP 15 + +end program Struct_over diff --git a/Fortran/gfortran/regression/constructor_7.f90 b/Fortran/gfortran/regression/constructor_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/constructor_7.f90 @@ -0,0 +1,48 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! PR fortran/53111 +! + +! ------------ INVALID ONE ------------------------ + +module m +type t + integer :: i +end type t +end + +module m2 + interface t + module procedure sub + end interface t +contains + integer function sub() + sub = 4 + end function sub +end module m2 + +! Note: The following is formally valid as long as "t" is not used. +! For simplicity, -std=f95 will give an error. +! It is unlikely that a real-world program is rejected with -std=f95 +! because of that. + +use m ! { dg-error "Fortran 2003: Generic name 't' of function 'sub' at .1. being the same name as derived type at" } +use m2 ! { dg-error "Fortran 2003: Generic name 't' of function 'sub' at .1. being the same name as derived type at" } +! i = sub() ! << Truly invalid in F95, valid in F2003 +end + +! ------------ INVALID TWO ------------------------ + +module m3 +type t2 ! { dg-error "Fortran 2003: Generic name 't2' of function 'sub2' at .1. being the same name as derived type at" } + integer :: i +end type t2 + interface t2 + module procedure sub2 + end interface t2 +contains + integer function sub2() ! { dg-error "Fortran 2003: Generic name 't2' of function 'sub2' at .1. being the same name as derived type at" } + sub2 = 4 + end function sub2 +end module m3 diff --git a/Fortran/gfortran/regression/constructor_8.f90 b/Fortran/gfortran/regression/constructor_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/constructor_8.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! PR fortran/53111 +! +! Contributed by Jacob Middag, reduced by Janus Weil. +! + +module a + type :: my + real :: x + end type +end module + +module b + use a +end module + +program test + use a + use b +end program diff --git a/Fortran/gfortran/regression/constructor_9.f90 b/Fortran/gfortran/regression/constructor_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/constructor_9.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-Wall" } +! +! PR 58471: [4.8/4.9 Regression] ICE on invalid with missing type constructor and -Wall +! +! Contributed by Andrew Benson + +module cf + implicit none + type :: cfmde + end type + interface cfmde + module procedure mdedc ! { dg-error "is neither function nor subroutine" } + end interface +contains + subroutine cfi() + type(cfmde), pointer :: cfd + cfd=cfmde() ! { dg-error "Cannot convert" } + end subroutine +end module diff --git a/Fortran/gfortran/regression/contained_1.f90 b/Fortran/gfortran/regression/contained_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/contained_1.f90 @@ -0,0 +1,33 @@ +! PR15986 +! Siblings may be used as actual arguments, in which case they look like +! variables during parsing. Also checks that actual variables aren't replaced +! by siblings with the same name +! { dg-do run } +module contained_1_mod +integer i +contains +subroutine a + integer :: c = 42 + call sub(b, c) +end subroutine a +subroutine b() + i = i + 1 +end subroutine b +subroutine c +end subroutine +end module + +subroutine sub (proc, var) + external proc1 + integer var + + if (var .ne. 42) STOP 1 + call proc +end subroutine + +program contained_1 + use contained_1_mod + i = 0 + call a + if (i .ne. 1) STOP 2 +end program diff --git a/Fortran/gfortran/regression/contained_3.f90 b/Fortran/gfortran/regression/contained_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/contained_3.f90 @@ -0,0 +1,48 @@ +! { dg-do run } +! Tests the fix for PR33897, in which gfortran missed that the +! declaration of 'setbd' in 'nxtstg2' made it external. Also +! the ENTRY 'setbd' would conflict with the external 'setbd'. +! +! Contributed by Michael Richmond +! +MODULE ksbin1_aux_mod + CONTAINS + SUBROUTINE nxtstg1() + INTEGER :: i + i = setbd() ! available by host association. + if (setbd () .ne. 99 ) STOP 1 + END SUBROUTINE nxtstg1 + + SUBROUTINE nxtstg2() + INTEGER :: i + integer :: setbd ! makes it external. + i = setbd() ! this is the PR + if (setbd () .ne. 42 ) STOP 2 + END SUBROUTINE nxtstg2 + + FUNCTION binden() + INTEGER :: binden + INTEGER :: setbd + binden = 0 + ENTRY setbd() + setbd = 99 + END FUNCTION binden +END MODULE ksbin1_aux_mod + +PROGRAM test + USE ksbin1_aux_mod, only : nxtstg1, nxtstg2 + integer setbd ! setbd is external, since not use assoc. + CALL nxtstg1() + CALL nxtstg2() + if (setbd () .ne. 42 ) STOP 3 + call foo +contains + subroutine foo + USE ksbin1_aux_mod ! module setbd is available + if (setbd () .ne. 99 ) STOP 4 + end subroutine +END PROGRAM test + +INTEGER FUNCTION setbd() + setbd=42 +END FUNCTION setbd diff --git a/Fortran/gfortran/regression/contained_equivalence_1.f90 b/Fortran/gfortran/regression/contained_equivalence_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/contained_equivalence_1.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! This program tests that equivalence only associates variables in +! the same scope. +! +! provided by Paul Thomas - pault@gcc.gnu.org +! +program contained_equiv + real a + a = 1.0 + call foo () + if (a.ne.1.0) STOP 1 +contains + subroutine foo () + real b + equivalence (a, b) + b = 2.0 + end subroutine foo +end program contained_equiv diff --git a/Fortran/gfortran/regression/contained_module_proc_1.f90 b/Fortran/gfortran/regression/contained_module_proc_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/contained_module_proc_1.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! Tests the check for PR31292, in which the module procedure +! statement would put the symbol for assign_t in the wrong +! namespace and this caused the interface checking to fail. +! +! Contributed by Tobias Burnus +! +module chk_gfortran + implicit none + type t + integer x + end type t + contains + function is_gfortran() + logical is_gfortran + interface assignment(=) + module procedure assign_t + end interface assignment(=) + type(t) y(3) + + y%x = (/1,2,3/) + y = y((/2,3,1/)) + is_gfortran = y(3)%x == 1 + end function is_gfortran + + elemental subroutine assign_t(lhs,rhs) + type(t), intent(in) :: rhs + type(t), intent(out) :: lhs + + lhs%x = rhs%x + end subroutine assign_t +end module chk_gfortran + +program fire + use chk_gfortran + implicit none + if(.not. is_gfortran()) STOP 1 +end program fire diff --git a/Fortran/gfortran/regression/contains.f90 b/Fortran/gfortran/regression/contains.f90 --- /dev/null +++ b/Fortran/gfortran/regression/contains.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! Check whether empty contains are allowd +! PR fortran/29806 +module x + contains ! { dg-error "CONTAINS statement without FUNCTION or SUBROUTINE statement" } +end module x + +program y + contains ! { dg-error "CONTAINS statement without FUNCTION or SUBROUTINE statement" } +end program y diff --git a/Fortran/gfortran/regression/contains_empty_1.f03 b/Fortran/gfortran/regression/contains_empty_1.f03 --- /dev/null +++ b/Fortran/gfortran/regression/contains_empty_1.f03 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-std=f2003 -pedantic" } +program test + print *, 'hello there' +contains ! { dg-error "Fortran 2008: CONTAINS statement without" } +end program test + +module truc + integer, parameter :: answer = 42 +contains ! { dg-error "Fortran 2008: CONTAINS statement without" } +end module truc diff --git a/Fortran/gfortran/regression/contains_empty_2.f03 b/Fortran/gfortran/regression/contains_empty_2.f03 --- /dev/null +++ b/Fortran/gfortran/regression/contains_empty_2.f03 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-std=f2008 -pedantic" } + +program test + print *, 'hello there' +contains +end program test + +module truc + integer, parameter :: answer = 42 +contains +end module truc diff --git a/Fortran/gfortran/regression/contiguous_1.f90 b/Fortran/gfortran/regression/contiguous_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/contiguous_1.f90 @@ -0,0 +1,177 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/40632 +! +! CONTIGUOUS compile-time tests +! + +! C448: Must be an array with POINTER attribute +type t1 + integer, contiguous :: ca(5) ! { dg-error "Component .ca. at .1. has the CONTIGUOUS" } +end type t1 +type t2 + integer, contiguous, allocatable :: cb(:) ! { dg-error "Component .cb. at .1. has the CONTIGUOUS" } +end type t2 +type t3 + integer, contiguous, pointer :: cc(:) ! OK +end type t3 +type t4 + integer, pointer, contiguous :: cd ! { dg-error "Component .cd. at .1. has the CONTIGUOUS" } +end type t4 +end + +! C530: Must be an array and (a) a POINTER or (b) assumed shape. +subroutine test(x, y) + integer, pointer :: x(:) + integer, intent(in) :: y(:) + contiguous :: x, y + + integer, contiguous :: a(5) ! { dg-error ".a. at .1. has the CONTIGUOUS attribute" } + integer, contiguous, allocatable :: b(:) ! { dg-error ".b. at .1. has the CONTIGUOUS attribute" } + integer, contiguous, pointer :: c(:) ! OK + integer, pointer, contiguous :: d ! { dg-error ".d. at .1. has the CONTIGUOUS attribute" } +end + +! Pointer assignment check: +! If the pointer object has the CONTIGUOUS attribute, the pointer target shall be contiguous. +! Note: This is not compile-time checkable; but F2008, 5.3.7 except in a very few cases. +subroutine ptr_assign() + integer, pointer, contiguous :: ptr1(:) + integer, target :: tgt(5) + ptr1 => tgt +end subroutine + + +! C1239 (R1223) If an actual argument is a nonpointer array that has the ASYNCHRONOUS or VOLATILE +! attribute but is not simply contiguous (6.5.4), and the corresponding dummy argument has either the +! VOLATILE or ASYNCHRONOUS attribute, that dummy argument shall be an assumed-shape array +! that does not have the CONTIGUOUS attribute. + +subroutine C1239 + type t + integer :: e(4) + end type t + type(t), volatile :: f + integer, asynchronous :: a(4), b(4) + integer, volatile :: c(4), d(4) + call test (a,b,c) ! OK + call test (a,b(::2),c) ! { dg-error "array without CONTIGUOUS" } + call test (a(::2),b,c) ! { dg-error "array without CONTIGUOUS" } + + call test (a,b,f%e) ! OK + call test (a,f%e,c) ! OK + call test (f%e,b,c) ! OK + call test (a,b,f%e(::2)) ! OK + call test (a,f%e(::2),c) ! { dg-error "array without CONTIGUOUS" } + call test (f%e(::2),b,c) ! { dg-error "array without CONTIGUOUS" } +contains + subroutine test(u, v, w) + integer, asynchronous :: u(:), v(*) + integer, volatile :: w(:) + contiguous :: u + end subroutine test +end subroutine C1239 + + +! C1240 (R1223) If an actual argument is an array pointer that has the ASYNCHRONOUS or VOLATILE +! attribute but does not have the CONTIGUOUS attribute, and the corresponding dummy argument has +! either the VOLATILE or ASYNCHRONOUS attribute, that dummy argument shall be an array pointer +! or an assumed-shape array that does not have the CONTIGUOUS attribute. + +subroutine C1240 + type t + integer,pointer :: e(:) + end type t + type(t), volatile :: f + integer, pointer, asynchronous :: a(:), b(:) + integer,pointer, volatile :: c(:), d(:) + call test (a,b,c) ! { dg-error "array without CONTIGUOUS" } + call test (a,b(::2),c) ! { dg-error "array without CONTIGUOUS" } + call test (a(::2),b,c) ! { dg-error "array without CONTIGUOUS" } + + call test (a,b,f%e) ! { dg-error "array without CONTIGUOUS" } + call test (a,f%e,c) ! { dg-error "array without CONTIGUOUS" } + call test (f%e,b,c) ! { dg-error "array without CONTIGUOUS" } + call test (a,b,f%e(::2)) ! { dg-error "array without CONTIGUOUS" } + call test (a,f%e(::2),c) ! { dg-error "array without CONTIGUOUS" } + call test (f%e(::2),b,c) ! { dg-error "array without CONTIGUOUS" } + + call test2(a,b) + call test3(a,b) + call test2(c,d) + call test3(c,d) + call test2(f%e,d) + call test3(c,f%e) +contains + subroutine test(u, v, w) + integer, asynchronous :: u(:), v(*) + integer, volatile :: w(:) + contiguous :: u + end subroutine test + subroutine test2(x,y) + integer, asynchronous :: x(:) + integer, volatile :: y(:) + end subroutine test2 + subroutine test3(x,y) + integer, pointer, asynchronous :: x(:) + integer, pointer, volatile :: y(:) + end subroutine test3 +end subroutine C1240 + + + +! 12.5.2.7 Pointer dummy variables +! C1241 The actual argument corresponding to a dummy pointer with the CONTIGUOUS attribute shall be +! simply contiguous (6.5.4). + +subroutine C1241 + integer, pointer, contiguous :: a(:) + integer, pointer :: b(:) + call test(a) + call test(b) ! { dg-error "must be simply contiguous" } +contains + subroutine test(x) + integer, pointer, contiguous :: x(:) + end subroutine test +end subroutine C1241 + + +! 12.5.2.8 Coarray dummy variables +! If the dummy argument is an array coarray that has the CONTIGUOUS attribute or is not of assumed shape, +! the corresponding actual argument shall be simply contiguous + +subroutine sect12528(cob) + integer, save :: coa(6)[*] + integer :: cob(:)[*] + + call test(coa) + call test2(coa) + call test3(coa) + + call test(cob) ! { dg-error "must be simply contiguous" } + call test2(cob) ! { dg-error "must be simply contiguous" } + call test3(cob) +contains + subroutine test(x) + integer, contiguous :: x(:)[*] + end subroutine test + subroutine test2(x) + integer :: x(*)[*] + end subroutine test2 + subroutine test3(x) + integer :: x(:)[*] + end subroutine test3 +end subroutine sect12528 + + + +subroutine test34 + implicit none + integer, volatile,pointer :: a(:,:),i + call foo(a(2,2:3:2)) ! { dg-error "must be simply contiguous" } +contains + subroutine foo(x) + integer, pointer, contiguous, volatile :: x(:) + end subroutine +end subroutine test34 diff --git a/Fortran/gfortran/regression/contiguous_10.f90 b/Fortran/gfortran/regression/contiguous_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/contiguous_10.f90 @@ -0,0 +1,69 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } +! +! PR fortran/91640 +! +! Based on G. Steinmetz's test case +! +program p + implicit none (type, external) + real, target :: z(3) = 1.0 + real :: res(3) + real, pointer :: xxx(:) + + res = 42.0 + call sub (-z, res) + if (any (abs (res - (-1.0)) > epsilon(res))) stop 1 + if (any (abs (z - 1.0) > epsilon(z))) stop 2 + + res = 43.0 + call sub (z*2.0, res) + if (any (abs (res - 2.0) > epsilon(res))) stop 3 + if (any (abs (z - 1.0) > epsilon(z))) stop 4 + + res = 44.0 + call sub(get_var(), res) + if (any (abs (res - 1.0) > epsilon(res))) stop 5 + if (any (abs (z - 1.0) > epsilon(z))) stop 6 + + call double(get_var()) + if (any (abs (z - 2.0) > epsilon(z))) stop 7 + + call double(get_var_cont()) + if (any (abs (z - 4.0) > epsilon(z))) stop 8 + + ! For cross check for copy-out: + xxx => z + if (any (abs (z - 4.0) > epsilon(z))) stop 10 + if (any (abs (xxx - 4.0) > epsilon(z))) stop 11 + call double (xxx) + if (any (abs (z - 8.0) > epsilon(z))) stop 12 + if (any (abs (xxx - 8.0) > epsilon(z))) stop 13 + +contains + subroutine sub (x, res) + real, contiguous :: x(:) + real :: res(3) + res = x + end + subroutine double (x) + real, contiguous :: x(:) + x = x * 2.0 + end + function get_var() + real, pointer :: get_var(:) + get_var => z + end + function get_var_cont() + real, pointer, contiguous :: get_var_cont(:) + get_var_cont => z + end +end + +! only 'xxx' should have a copy out: +! { dg-final { scan-tree-dump-times "D\\.\[0-9\].* = .*atmp\\.\[0-9\]*\\.data" 1 "original" } } +! { dg-final { scan-tree-dump-times "D\\.\[0-9\].*xxx\\.span.* = .*atmp\\.\[0-9\]*\\.data" 1 "original" } } + +! Only once 'z... = ' – for: static real(kind=4) z[3] = {[0 ... 2]=1.0e+0}; +! but don't match '(si)ze' +! { dg-final { scan-tree-dump-times "z\[^e\].* = " 1 "original" } } diff --git a/Fortran/gfortran/regression/contiguous_11.f90 b/Fortran/gfortran/regression/contiguous_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/contiguous_11.f90 @@ -0,0 +1,45 @@ +! { dg-do compile } +! +! PR fortran/97242 +! +implicit none +type t + integer, allocatable :: A(:,:,:) + integer :: D(5,5,5) +end type t + +type(t), target :: B(5) +integer, pointer, contiguous :: P(:,:,:) +integer, target :: C(5,5,5) +integer :: i + +i = 1 + +! OK: contiguous +P => B(i)%A +P => B(i)%A(:,:,:) +P => C +P => C(:,:,:) +call foo (B(i)%A) +call foo (B(i)%A(:,:,:)) +call foo (C) +call foo (C(:,:,:)) + +! Invalid - not contiguous +! "If the pointer object has the CONTIGUOUS attribute, the pointer target shall be contiguous." +! → known to be noncontigous (not always checkable, however) +P => B(i)%A(:,::3,::4) ! <<< Unknown as (1:2:3,1:3:4) is contiguous and has one element. +P => B(i)%D(:,::2,::2) ! { dg-error "Assignment to contiguous pointer from non-contiguous target" } +P => C(::2,::2,::2) ! { dg-error "Assignment to contiguous pointer from non-contiguous target" } + +! This following is stricter: +! C1541 The actual argument corresponding to a dummy pointer with the +! CONTIGUOUS attribute shall be simply contiguous (9.5.4). +call foo (B(i)%A(:,::3,::4)) ! { dg-error "must be simply contiguous" } +call foo (C(::2,::2,::2)) ! { dg-error "must be simply contiguous" } + +contains + subroutine foo(Q) + integer, pointer, intent(in), contiguous :: Q(:,:,:) + end subroutine foo +end diff --git a/Fortran/gfortran/regression/contiguous_12.f90 b/Fortran/gfortran/regression/contiguous_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/contiguous_12.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/108025 + +subroutine foo (x) + real, contiguous :: x(:) + contiguous :: x ! { dg-error "Duplicate CONTIGUOUS attribute" } +end diff --git a/Fortran/gfortran/regression/contiguous_2.f90 b/Fortran/gfortran/regression/contiguous_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/contiguous_2.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR fortran/40632 +! +! CONTIGUOUS compile-time tests +! + +integer, pointer, contiguous :: a(:) ! { dg-error "Fortran 2008:" } +integer, pointer :: b(:) +contiguous :: b ! { dg-error "Fortran 2008:" } +end diff --git a/Fortran/gfortran/regression/contiguous_3.f90 b/Fortran/gfortran/regression/contiguous_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/contiguous_3.f90 @@ -0,0 +1,60 @@ +! { dg-do compile } +! { dg-options "-O0 -fdump-tree-original" } +! +! PR fortran/40632 +! +! CONTIGUOUS compile-time tests: Check that contigous +! works properly. + +subroutine test1(a,b) + integer, pointer, contiguous :: test1_a(:) + integer, target, dimension(3) :: aa + test1_a => aa + call foo(test1_a) + call foo(test1_a(::1)) + call foo(test1_a(::2)) +contains + subroutine foo(b) + integer :: b(*) + end subroutine foo +end subroutine test1 + +! For the first two no pack is done; for the third one, an array descriptor +! (cf. below test3) is created for packing. +! +! { dg-final { scan-tree-dump-times "_internal_pack.*test1_a" 0 "original" } } +! { dg-final { scan-tree-dump-times "_internal_unpack.*test1_a" 0 "original" } } + + +subroutine t2(a1,b1,c2,d2) + integer, pointer, contiguous :: a1(:), b1(:) + integer, pointer :: c2(:), d2(:) + a1 = b1 + c2 = d2 +end subroutine t2 + +! { dg-final { scan-tree-dump-times "= a1->dim.0..stride;" 0 "original" } } +! { dg-final { scan-tree-dump-times "= b1->dim.0..stride;" 0 "original" } } +! { dg-final { scan-tree-dump-times "= c2->dim.0..stride;" 1 "original" } } +! { dg-final { scan-tree-dump-times "= d2->dim.0..stride;" 1 "original" } } + + +subroutine test3() + implicit none + integer :: test3_a(8),i + test3_a = [(i,i=1,8)] + call foo(test3_a(::1)) + call foo(test3_a(::2)) + call bar(test3_a(::1)) + call bar(test3_a(::2)) +contains + subroutine foo(x) + integer, contiguous :: x(:) + print *, x + end subroutine + subroutine bar(x) + integer :: x(:) + print *, x + end subroutine bar +end subroutine test3 + diff --git a/Fortran/gfortran/regression/contiguous_4.f90 b/Fortran/gfortran/regression/contiguous_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/contiguous_4.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +program cont_01_neg + implicit none + real, pointer, contiguous :: r(:) + real, pointer, contiguous :: r2(:,:) + real, target :: x(45) + real, target :: x2(5,9) + integer :: i + integer :: n=1 + + x = (/ (real(i),i=1,45) /) + x2 = reshape(x,shape(x2)) + r => x(::46) + r => x(::3) ! { dg-error "Assignment to contiguous pointer from non-contiguous target" } + r2 => x2(2:,9:) + r2 => x2(2:,:) ! { dg-error "Assignment to contiguous pointer from non-contiguous target" } + r2 => x2(:,2:3) + r => x2(2:3,1) + r => x(::1) + r => x(::n) +end program diff --git a/Fortran/gfortran/regression/contiguous_5.f90 b/Fortran/gfortran/regression/contiguous_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/contiguous_5.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! PR 83012 - this was incorrectly rejected. +! Original test case by Neil Carlson. +module mod + type :: foo + integer, pointer, contiguous :: p(:) + contains + procedure :: dataptr + end type +contains + function dataptr(this) result(dp) + class(foo), intent(in) :: this + integer, pointer, contiguous :: dp(:) + dp => this%p + end function +end module + +subroutine bar(x) + use mod + class(foo) :: x + integer, pointer, contiguous :: p(:) + p => x%dataptr() +end subroutine diff --git a/Fortran/gfortran/regression/contiguous_6.f90 b/Fortran/gfortran/regression/contiguous_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/contiguous_6.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/83742 +! Contributed by Gerhard Steinmetz +program p + real, target :: a + real, pointer, contiguous :: b => a ! { dg-error "has the CONTIGUOUS attribute" } +end diff --git a/Fortran/gfortran/regression/contiguous_7.f90 b/Fortran/gfortran/regression/contiguous_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/contiguous_7.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! { dg-additional-options "-Wextra" } +! +! Ensure that contiguous pointers pointing to noncontiguous pointers +! to array results in a warning with -Wextra. + +program cont_01_neg + implicit none + real, pointer, contiguous :: r(:) + real, pointer, contiguous :: r2(:,:) + real, target, allocatable :: x(:) + real, target, allocatable :: x2(:,:) + real, target :: y(45) + real, target :: y2(5,9) + integer :: i + integer :: n=1 + + x = (/ (real(i),i=1,45) /) + x2 = reshape(x,shape(x2)) + y = x + y2 = x2 + + r => x(::3) ! { dg-warning "ssignment to contiguous pointer from non-contiguous target" } + r2 => x2(2:,:) ! { dg-warning "ssignment to contiguous pointer from non-contiguous target" } + r2 => x2(:,2:3) + r => x2(2:3,1) + r => x(::1) + r => x(::n) ! { dg-warning "ssignment to contiguous pointer from non-contiguous target" } + + r => y(::3) ! { dg-error "ssignment to contiguous pointer from non-contiguous target" } + r2 => y2(2:,:) ! { dg-error "ssignment to contiguous pointer from non-contiguous target" } + r2 => y2(:,2:3) + r => y2(2:3,1) + r => y(::1) + r => y(::n) ! { dg-warning "ssignment to contiguous pointer from non-contiguous target" } +end program diff --git a/Fortran/gfortran/regression/contiguous_8.f90 b/Fortran/gfortran/regression/contiguous_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/contiguous_8.f90 @@ -0,0 +1,65 @@ +! { dg-do run } +! PR 56789 - packing / unpacking of contiguous arguments +! did not happen. + +module my_module + implicit none +contains + subroutine cont_arg(a) + real, contiguous :: a(:,:) + integer :: i,j + do j=1,size(a,2) + do i=1,size(a,1) + a(i,j) = i+10*j + end do + end do + end subroutine cont_arg + subroutine cont_pointer_arg (a) + integer, pointer, contiguous :: a(:) + call assumed_size(a) + call assumed_size(a(::1)) + call assumed_size_2(a(::2)) + end subroutine cont_pointer_arg + + subroutine assumed_size(y) + integer, dimension(*) :: y + if (y(2) /= 2 .or. y(3) /= 3 .or. y(4) /= 4 .or. y(5) /= 5 .or. y(6) /= 6) & + stop 2 + end subroutine assumed_size + + subroutine assumed_size_2(y) + integer, dimension(*) :: y + if (y(1) /= 1 .or. y(2) /= 3 .or. y(3) /= 5) stop 3 + end subroutine assumed_size_2 + + subroutine cont_assumed_shape(x) + integer, dimension(:), contiguous :: x + if (size(x,1) == 8) then + if (any(x /= [1,2,3,4,5,6,7,8])) stop 4 + else + if (any(x /= [1,3,5,7])) stop 5 + end if + end subroutine cont_assumed_shape +end module my_module + +program main + use my_module + implicit none + real, dimension(5,5) :: a + real, dimension(5,5) :: res + integer, dimension(8), target :: t + integer, dimension(:), pointer, contiguous :: p + res = reshape([11., 1.,12., 1.,13.,& + 1., 1., 1., 1., 1.,& + 21., 1.,22., 1.,23.,& + 1., 1., 1., 1., 1.,& + 31., 1.,32., 1., 33.], shape(res)) + a = 1. + call cont_arg(a(1:5:2,1:5:2)) + if (any(a /= res)) stop 1 + t = [1,2,3,4,5,6,7,8] + p => t + call cont_pointer_arg(p) + call cont_assumed_shape (t) + call cont_assumed_shape (t(::2)) +end program main diff --git a/Fortran/gfortran/regression/contiguous_9.f90 b/Fortran/gfortran/regression/contiguous_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/contiguous_9.f90 @@ -0,0 +1,12 @@ +program contiguous_pointer + +type t +end type t + +type s + class(t), dimension(:), contiguous, pointer :: x ! OK + class(t), contiguous, allocatable :: y ! { dg-error "has the CONTIGUOUS attribute but is not an array pointer" } + class(t), contiguous, pointer :: z ! { dg-error "has the CONTIGUOUS attribute but is not an array pointer" } +end type s + +end program contiguous_pointer diff --git a/Fortran/gfortran/regression/continuation_1.f90 b/Fortran/gfortran/regression/continuation_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/continuation_1.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options -Wampersand } +! PR 19101 Test line continuations and spaces. Note: the missing ampersand +! before "world" is non standard default behavior. Use -std=f95, -std=f2003, +! -pedantic, -Wall, or -Wampersand to catch this error +! Submitted by Jerry DeLisle . +program main + character (len=40) & + c + c = "Hello, & + world!" ! { dg-warning "Missing '&' in continued character constant" } + if (c.ne.& + "Hello, world!")& + STOP 1;end program main + diff --git a/Fortran/gfortran/regression/continuation_10.f90 b/Fortran/gfortran/regression/continuation_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/continuation_10.f90 @@ -0,0 +1,55 @@ +! { dg-do compile } +! { dg-options -std=f95 } +! PR35882 Miscounted continuation lines when interspersed with data +program test_mod + implicit none + + integer, dimension(50) :: array + + array = 1 + + print "(a, i8)", & + "Line 1", & + array(2), & + "Line 3", & + array(4), & + "Line 5", & + array(6), & + "Line 7", & + array(8), & + "Line 9", & + array(10), & + "Line 11", & + array(12), & + "Line 13", & + array(14), & + "Line 15", & + array(16), & + "Line 17", & + array(18), & + "Line 19", & + array(20), & + "Line 21", & + array(22), & + "Line 23", & + array(24), & + "Line 25", & + array(26), & + "Line 27", & + array(28), & + "Line 29", & + array(30), & + "Line 31", & + array(32), & + "Line 33", & + array(34), & + "Line 35", & + array(36), & + "Line 37", & + array(38), & + "Line 39", & + array(40), & ! { dg-warning "Limit of 39 continuations exceeded" } + "Line 41", & + array(42), & + "Line 43" +end program diff --git a/Fortran/gfortran/regression/continuation_11.f90 b/Fortran/gfortran/regression/continuation_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/continuation_11.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-Wall -pedantic" } +! Before a bogus warning was printed +! +! PR fortran/39811 +! +implicit none +character(len=70) :: str +write(str,'(a)') 'Print rather a lot of ampersands &&&&& + &&&&& + &&&&&' +if (len(trim(str)) /= 44 & + .or. str /= 'Print rather a lot of ampersands &&&&&&&&&&&') & + STOP 1 +end diff --git a/Fortran/gfortran/regression/continuation_12.f90 b/Fortran/gfortran/regression/continuation_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/continuation_12.f90 @@ -0,0 +1,8 @@ +! { dg-do run } +! PR46705 Spurious "Missing '&' in continued character constant" warning occurs twice +character(15) :: astring +1 FORMAT (''& + ' abcdefg x') +write(astring, 1) +if (astring.ne."' abcdefg x") STOP 1 +END diff --git a/Fortran/gfortran/regression/continuation_13.f90 b/Fortran/gfortran/regression/continuation_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/continuation_13.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! { dg-options "-std=gnu" } +! PR64506 +character(25) :: astring + +100 format('This format is OK.'& + ) +200 format('This format now works.'&!comment + ) +300 format('This format now works.'& !comment + ) +400 format('This format is OK.' &!comment + ) +500 format('This format is OK.' & !comment + ) +600 format('This format now works.'''&!comment + ) +700 format('This format now works.'''& !comment + ) +! See PR65903 for the following cases. +800 format('This is actually ok.'& !comment + ' end' ) +900 format('This is actually ok.' & !comment + ' end' ) +write(astring,100) +if (astring.ne."This format is OK.") STOP 1 +write(astring,200) +if (astring.ne."This format now works.") STOP 2 +write(astring,300) +if (astring.ne."This format now works.") STOP 3 +write(astring,400) +if (astring.ne."This format is OK.") STOP 4 +write(astring,500) +if (astring.ne."This format is OK.") STOP 5 +write(astring,600) +if (astring.ne."This format now works.'") STOP 6 +write(astring,700) +if (astring.ne."This format now works.'") STOP 7 +write(astring,800) +if (astring.ne."This is actually ok.' end") STOP 8 +write(astring,900) +if (astring.ne."This is actually ok. end") STOP 9 + +end diff --git a/Fortran/gfortran/regression/continuation_14.f b/Fortran/gfortran/regression/continuation_14.f --- /dev/null +++ b/Fortran/gfortran/regression/continuation_14.f @@ -0,0 +1,30 @@ +! { dg-do run } +! { dg-options "-std=gnu" } +! PR64506 fixed form source + character(25) :: astring + + 100 format('This format is OK.' + &) + 200 format('This format works now.'!comment << FAILS + &) + 300 format('This format is OK.' !comment + &) + 400 format('This format is OK.' !comment + &) + 500 format('This format is now OK.'''!comment + & ) + 600 format('This format is OK.''' !comment + & ) + write(astring,100) + if (astring.ne."This format is OK.") STOP 1 + write(astring,200) + if (astring.ne."This format works now.") STOP 2 + write(astring,300) + if (astring.ne."This format is OK.") STOP 3 + write(astring,400) + if (astring.ne."This format is OK.") STOP 4 + write(astring,500) + if (astring.ne."This format is now OK.'") STOP 5 + write(astring,600) + if (astring.ne."This format is OK.'") STOP 6 + end diff --git a/Fortran/gfortran/regression/continuation_15.f90 b/Fortran/gfortran/regression/continuation_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/continuation_15.f90 @@ -0,0 +1,9 @@ +! PR fortran/89724 +! { dg-do compile } +! { dg-options "-std=f95" } + +include 'continuation_9.f90' + +! { dg-warning "not allowed by itself in line 3" "" { target *-*-* } 0 } +! { dg-warning "not allowed by itself in line 4" "" { target *-*-* } 0 } +! { dg-warning "not allowed by itself in line 5" "" { target *-*-* } 0 } diff --git a/Fortran/gfortran/regression/continuation_16.f90 b/Fortran/gfortran/regression/continuation_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/continuation_16.f90 @@ -0,0 +1,10 @@ +! PR fortran/89724 +! { dg-do compile } +! { dg-options "-std=f95 -nostdinc -fpre-include=simd-builtins-1.h" } + & +& + & +end +! { dg-warning "not allowed by itself in line 4" "" { target *-*-* } 0 } +! { dg-warning "not allowed by itself in line 5" "" { target *-*-* } 0 } +! { dg-warning "not allowed by itself in line 6" "" { target *-*-* } 0 } diff --git a/Fortran/gfortran/regression/continuation_2.f90 b/Fortran/gfortran/regression/continuation_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/continuation_2.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR 19260 Test line continuations and spaces. +! Submitted by Jerry DeLisle . +x = si& ! { dg-error "Unclassifiable statement" } +n(3.14159/2) +end diff --git a/Fortran/gfortran/regression/continuation_3.f90 b/Fortran/gfortran/regression/continuation_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/continuation_3.f90 @@ -0,0 +1,91 @@ +! { dg-do compile } +! { dg-options -std=f95 } +! PR 19262 Test limit on line continuations. Test case derived form case in PR +! by Steve Kargl. Submitted by Jerry DeLisle +print *, & + "1" // & ! 1 + "2" // & ! 2 + "3" // & ! 3 + "4" // & ! 4 + "5" // & ! 5 + "6" // & ! 6 + "7" // & ! 7 + "8" // & ! 8 + "9" // & ! 9 + "0" // & ! 10 + "1" // & ! 11 + "2" // & ! 12 + "3" // & ! 13 + "4" // & ! 14 + "5" // & ! 15 + "6" // & ! 16 + "7" // & ! 17 + "8" // & ! 18 + "9" // & ! 19 + "0" // & ! 20 + "1" // & ! 21 + "2" // & ! 22 + "3" // & ! 23 + "4" // & ! 24 + "5" // & ! 25 + "6" // & ! 26 + "7" // & ! 27 + "8" // & ! 28 + "9" // & ! 29 + "0" // & ! 30 + "1" // & ! 31 + "2" // & ! 32 + "3" // & ! 33 + "4" // & ! 34 + "5" // & ! 35 + "6" // & ! 36 + "7" // & ! 37 + "8" // & ! 38 + "9" +print *, & + "1" // & ! 1 + "2" // & ! 2 + "3" // & ! 3 + "4" // & ! 4 + "5" // & ! 5 + "6" // & ! 6 + "7" // & ! 7 + "8" // & ! 8 + "9" // & ! 9 + "0" // & ! 10 + "1" // & ! 11 + "2" // & ! 12 + "3" // & ! 13 + "4" // & ! 14 + "5" // & ! 15 + "6" // & ! 16 + "7" // & ! 17 + "8" // & ! 18 + "9" // & ! 19 + "0" // & ! 20 + "1" // & ! 21 + "2" // & ! 22 + "3" // & ! 23 + "4" // & ! 24 + "5" // & ! 25 + "6" // & ! 26 + "7" // & ! 27 + "8" // & ! 28 + "9" // & ! 29 +! + ! + "0" // & ! 30 + "1" // & ! 31 +! +! + "2" // & ! 32 + "3" // & ! 33 + "4" // & ! 34 + "5" // & ! 35 + "6" // & ! 36 + "7" // & ! 37 + "8" // & ! 38 + "9" // & ! 39 + "0" ! { dg-warning "Limit of 39 continuations exceeded" } + +end \ No newline at end of file diff --git a/Fortran/gfortran/regression/continuation_4.f90 b/Fortran/gfortran/regression/continuation_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/continuation_4.f90 @@ -0,0 +1,262 @@ +! { dg-do compile } +! { dg-options -std=f2003 } +! PR 19262 Test limit on line continuations. Test case derived form case in PR +! by Steve Kargl. Submitted by Jerry DeLisle +print *, & + "1" // & ! 1 Counting in groups of 40. + "2" // & ! 2 + "3" // & ! 3 + "4" // & ! 4 + "5" // & ! 5 + "6" // & ! 6 + "7" // & ! 7 + "8" // & ! 8 + "9" // & ! 9 + "0" // & ! 10 + "1" // & ! 11 + "2" // & ! 12 + "3" // & ! 13 + "4" // & ! 14 + "5" // & ! 15 + "6" // & ! 16 + "7" // & ! 17 + "8" // & ! 18 + "9" // & ! 19 + "0" // & ! 20 + "1" // & ! 21 + "2" // & ! 22 + "3" // & ! 23 + "4" // & ! 24 + "5" // & ! 25 + "6" // & ! 26 + "7" // & ! 27 + "8" // & ! 28 + "9" // & ! 29 + "0" // & ! 30 + "1" // & ! 31 + "2" // & ! 32 + "3" // & ! 33 + "4" // & ! 34 + "5" // & ! 35 + "6" // & ! 36 + "7" // & ! 37 + "8" // & ! 38 + "9" // & ! 39 + "0" // & ! 40 + "1" // & ! 1 + "2" // & ! 2 + "3" // & ! 3 + "4" // & ! 4 + "5" // & ! 5 + "6" // & ! 6 + "7" // & ! 7 + "8" // & ! 8 + "9" // & ! 9 + "0" // & ! 10 + "1" // & ! 11 + "2" // & ! 12 + "3" // & ! 13 + "4" // & ! 14 + "5" // & ! 15 + "6" // & ! 16 + "7" // & ! 17 + "8" // & ! 18 + "9" // & ! 19 + "0" // & ! 20 + "1" // & ! 21 + "2" // & ! 22 + "3" // & ! 23 + "4" // & ! 24 + "5" // & ! 25 + "6" // & ! 26 + "7" // & ! 27 + "8" // & ! 28 + "9" // & ! 29 + "0" // & ! 30 + "1" // & ! 31 + "2" // & ! 32 + "3" // & ! 33 + "4" // & ! 34 + "5" // & ! 35 + "6" // & ! 36 + "7" // & ! 37 + "8" // & ! 38 + "9" // & ! 39 + "0" // & ! 80 + "1" // & ! 1 + "2" // & ! 2 + "3" // & ! 3 + "4" // & ! 4 + "5" // & ! 5 + "6" // & ! 6 + "7" // & ! 7 + "8" // & ! 8 + "9" // & ! 9 + "0" // & ! 10 + "1" // & ! 11 + "2" // & ! 12 + "3" // & ! 13 + "4" // & ! 14 + "5" // & ! 15 + "6" // & ! 16 + "7" // & ! 17 + "8" // & ! 18 + "9" // & ! 19 + "0" // & ! 20 + "1" // & ! 21 + "2" // & ! 22 + "3" // & ! 23 + "4" // & ! 24 + "5" // & ! 25 + "6" // & ! 26 + "7" // & ! 27 + "8" // & ! 28 + "9" // & ! 29 + "0" // & ! 30 + "1" // & ! 31 + "2" // & ! 32 + "3" // & ! 33 + "4" // & ! 34 + "5" // & ! 35 + "6" // & ! 36 + "7" // & ! 37 + "8" // & ! 38 + "9" // & ! 39 + "0" // & ! 120 + "1" // & ! 1 + "2" // & ! 2 + "3" // & ! 3 + "4" // & ! 4 + "5" // & ! 5 + "6" // & ! 6 + "7" // & ! 7 + "8" // & ! 8 + "9" // & ! 9 + "0" // & ! 10 + "1" // & ! 11 + "2" // & ! 12 + "3" // & ! 13 + "4" // & ! 14 + "5" // & ! 15 + "6" // & ! 16 + "7" // & ! 17 + "8" // & ! 18 + "9" // & ! 19 + "0" // & ! 20 + "1" // & ! 21 + "2" // & ! 22 + "3" // & ! 23 + "4" // & ! 24 + "5" // & ! 25 + "6" // & ! 26 + "7" // & ! 27 + "8" // & ! 28 + "9" // & ! 29 + "0" // & ! 30 + "1" // & ! 31 + "2" // & ! 32 + "3" // & ! 33 + "4" // & ! 34 + "5" // & ! 35 + "6" // & ! 36 + "7" // & ! 37 + "8" // & ! 38 + "9" // & ! 39 + "0" // & ! 160 + "1" // & ! 1 + "2" // & ! 2 + "3" // & ! 3 + "4" // & ! 4 + "5" // & ! 5 + "6" // & ! 6 + "7" // & ! 7 + "8" // & ! 8 + "9" // & ! 9 + "0" // & ! 10 + "1" // & ! 11 + "2" // & ! 12 + "3" // & ! 13 + "4" // & ! 14 + "5" // & ! 15 + "6" // & ! 16 + "7" // & ! 17 + "8" // & ! 18 + "9" // & ! 19 + "0" // & ! 20 + "1" // & ! 21 + "2" // & ! 22 + "3" // & ! 23 + "4" // & ! 24 + "5" // & ! 25 + "6" // & ! 26 + "7" // & ! 27 + "8" // & ! 28 + "9" // & ! 29 + "0" // & ! 30 + "1" // & ! 31 + "2" // & ! 32 + "3" // & ! 33 + "4" // & ! 34 + "5" // & ! 35 + "6" // & ! 36 + "7" // & ! 37 + "8" // & ! 38 + "9" // & ! 39 + "0" // & ! 200 + "1" // & ! 1 + "2" // & ! 2 + "3" // & ! 3 + "4" // & ! 4 + "5" // & ! 5 + "6" // & ! 6 + "7" // & ! 7 + "8" // & ! 8 + "9" // & ! 9 + "0" // & ! 10 + "1" // & ! 11 + "2" // & ! 12 + "3" // & ! 13 + "4" // & ! 14 + "5" // & ! 15 + "6" // & ! 16 + "7" // & ! 17 + "8" // & ! 18 + "9" // & ! 19 + "0" // & ! 20 + "1" // & ! 21 + "2" // & ! 22 + "3" // & ! 23 + "4" // & ! 24 + "5" // & ! 25 + "6" // & ! 26 + "7" // & ! 27 + "8" // & ! 28 + "9" // & ! 29 + "0" // & ! 30 + "1" // & ! 31 + "2" // & ! 32 + "3" // & ! 33 + "4" // & ! 34 + "5" // & ! 35 + "6" // & ! 36 + "7" // & ! 37 + "8" // & ! 38 + "9" // & ! 39 + "0" // & ! 240 + "1" // & ! 1 + "2" // & ! 2 + "3" // & ! 3 + "4" // & ! 4 + "5" // & ! 5 + "6" // & ! 6 + "7" // & ! 7 + "8" // & ! 8 + "9" // & ! 9 + "0" // & ! 10 + "1" // & ! 11 + "2" // & ! 12 + "3" // & ! 13 + "4" // & ! 14 + "5" // & ! 255 + "0" ! { dg-warning "Limit of 255 continuations exceeded" } +end \ No newline at end of file diff --git a/Fortran/gfortran/regression/continuation_5.f b/Fortran/gfortran/regression/continuation_5.f --- /dev/null +++ b/Fortran/gfortran/regression/continuation_5.f @@ -0,0 +1,54 @@ +! { dg-do compile } +! { dg-options -std=f95 } +! PR 19262 Test limit on line continuations. Test case derived form case in PR +! by Steve Kargl. Submitted by Jerry DeLisle + print *, + c "1" // ! 1 + c "2" // ! 2 + c "3" // ! 3 + c "4" // ! 4 + c "5" // ! 5 + c "6" // ! 6 + c "7" // ! 7 + c "8" // ! 8 + c "9" // ! 9 + c "0" // ! 10 + c "1" // ! 11 + c "2" // ! 12 + c "3" // ! 13 + c "4" // ! 14 + c "5" // ! 15 + c "6" // ! 16 + c "7" // ! 17 + c "8" // ! 18 + c "9" ! 19 + print *, + c "1" // ! 1 + c "2" // ! 2 + c "3" // ! 3 + c "4" // ! 4 + c "5" // ! 5 + c "6" // ! 6 + c "7" // ! 7 + c "8" // ! 8 + c "9" // ! 9 +! +c +* +C + c "0" // ! 10 + c "1" // ! 11 + c "2" // ! 12 + c "3" // ! 13 + c "4" // ! 14 +c + + ! + ! + c "5" // ! 15 + c "6" // ! 16 + c "7" // ! 17 + c "8" // ! 18 + c "9" // ! 19 + c "0" ! { dg-warning "Limit of 19 continuations exceeded" } + end \ No newline at end of file diff --git a/Fortran/gfortran/regression/continuation_6.f b/Fortran/gfortran/regression/continuation_6.f --- /dev/null +++ b/Fortran/gfortran/regression/continuation_6.f @@ -0,0 +1,264 @@ +! { dg-do compile } +! { dg-options -std=f2003 } +! PR 19262 Test limit on line continuations. Test case derived form case in PR +! by Steve Kargl. Submitted by Jerry DeLisle + print *, + c "1" // ! 1 Counting by 40. + c "2" // ! 2 + c "3" // ! 3 + c "4" // ! 4 + c "5" // ! 5 + c "6" // ! 6 + c "7" // ! 7 + c "8" // ! 8 + c "9" // ! 9 + c "0" // ! 10 + c "1" // ! 11 + c "2" // ! 12 + c "3" // ! 13 + c "4" // ! 14 + c "5" // ! 15 + c "6" // ! 16 + c "7" // ! 17 + c "8" // ! 18 + c "9" // ! 19 + c "0" // ! 20 + c "1" // ! 21 + c "2" // ! 22 + c "3" // ! 23 + c "4" // ! 24 + c "5" // ! 25 + c "6" // ! 26 + c "7" // ! 27 + c "8" // ! 28 + c "9" // ! 29 + c "0" // ! 30 + c "1" // ! 31 + c "2" // ! 32 + c "3" // ! 33 + c "4" // ! 34 + c "5" // ! 35 + c "6" // ! 36 + c "7" // ! 37 + c "8" // ! 38 + c "9" // ! 39 + c "0" // ! 40 + c "1" // ! 1 + c "2" // ! 2 + c "3" // ! 3 + c "4" // ! 4 + c "5" // ! 5 + c "6" // ! 6 + c "7" // ! 7 + c "8" // ! 8 + c "9" // ! 9 + c "0" // ! 10 + c "1" // ! 11 + c "2" // ! 12 + c "3" // ! 13 + c "4" // ! 14 + c "5" // ! 15 + c "6" // ! 16 + c "7" // ! 17 + c "8" // ! 18 + c "9" // ! 19 + c "0" // ! 20 + c "1" // ! 21 + c "2" // ! 22 + c "3" // ! 23 + c "4" // ! 24 + c "5" // ! 25 + c "6" // ! 26 + c "7" // ! 27 + c "8" // ! 28 + c "9" // ! 29 + c "0" // ! 30 + c "1" // ! 31 + c "2" // ! 32 + c "3" // ! 33 + c "4" // ! 34 + c "5" // ! 35 + c "6" // ! 36 + c "7" // ! 37 + c "8" // ! 38 + c "9" // ! 39 + c "0" // ! 80 + c "1" // ! 1 + c "2" // ! 2 + c "3" // ! 3 + c "4" // ! 4 + c "5" // ! 5 + c "6" // ! 6 + c "7" // ! 7 + c "8" // ! 8 + c "9" // ! 9 + c "0" // ! 10 + c "1" // ! 11 + c "2" // ! 12 + c "3" // ! 13 + c "4" // ! 14 + c "5" // ! 15 + c "6" // ! 16 + c "7" // ! 17 + c "8" // ! 18 + c "9" // ! 19 + c "0" // ! 20 + c "1" // ! 21 + c "2" // ! 22 + c "3" // ! 23 + c "4" // ! 24 + c "5" // ! 25 + c "6" // ! 26 + c "7" // ! 27 + c "8" // ! 28 + c "9" // ! 29 + c "0" // ! 30 + c "1" // ! 31 + c "2" // ! 32 + c "3" // ! 33 + c "4" // ! 34 + c "5" // ! 35 + c "6" // ! 36 + c "7" // ! 37 + c "8" // ! 38 + c "9" // ! 39 + c "0" // ! 120 + c "1" // ! 1 + c "2" // ! 2 + c "3" // ! 3 + c "4" // ! 4 + c "5" // ! 5 + c "6" // ! 6 + c "7" // ! 7 + c "8" // ! 8 + c "9" // ! 9 + c "0" // ! 10 + c "1" // ! 11 + c "2" // ! 12 + c "3" // ! 13 + c "4" // ! 14 + c "5" // ! 15 + c "6" // ! 16 + c "7" // ! 17 + c "8" // ! 18 + c "9" // ! 19 + c "0" // ! 20 + c "1" // ! 21 + c "2" // ! 22 + c "3" // ! 23 + c "4" // ! 24 + c "5" // ! 25 + c "6" // ! 26 + c "7" // ! 27 + c "8" // ! 28 + c "9" // ! 29 + c "0" // ! 30 + c "1" // ! 31 + c "2" // ! 32 + c "3" // ! 33 + c "4" // ! 34 + c "5" // ! 35 + c "6" // ! 36 + c "7" // ! 37 + c "8" // ! 38 + c "9" // ! 39 + c "0" // ! 160 + c "1" // ! 1 + c "2" // ! 2 + c "3" // ! 3 + c "4" // ! 4 + c "5" // ! 5 + c "6" // ! 6 + c "7" // ! 7 + c "8" // ! 8 + c "9" // ! 9 + c "0" // ! 10 + c "1" // ! 11 + c "2" // ! 12 + c "3" // ! 13 + c "4" // ! 14 + c "5" // ! 15 + c "6" // ! 16 + c "7" // ! 17 + c "8" // ! 18 + c "9" // ! 19 + c "0" // ! 20 + c "1" // ! 21 + c "2" // ! 22 + c "3" // ! 23 + c "4" // ! 24 + c "5" // ! 25 + c "6" // ! 26 + c "7" // ! 27 + c "8" // ! 28 + c "9" // ! 29 + c "0" // ! 30 + c "1" // ! 31 + c "2" // ! 32 + c "3" // ! 33 + c "4" // ! 34 + c "5" // ! 35 + c "6" // ! 36 + c "7" // ! 37 + c "8" // ! 38 + c "9" // ! 39 + c "0" // ! 200 + c "1" // ! 1 + c "2" // ! 2 + c "3" // ! 3 + c "4" // ! 4 + c "5" // ! 5 + c "6" // ! 6 + c "7" // ! 7 + c "8" // ! 8 + c "9" // ! 9 + c "0" // ! 10 + c "1" // ! 11 + c "2" // ! 12 + c "3" // ! 13 + c "4" // ! 14 + c "5" // ! 15 + c "6" // ! 16 + c "7" // ! 17 + c "8" // ! 18 + c "9" // ! 19 + c "0" // ! 20 + c "1" // ! 21 + c "2" // ! 22 + c "3" // ! 23 + c "4" // ! 24 + c "5" // ! 25 + c "6" // ! 26 + c "7" // ! 27 + c "8" // ! 28 + c "9" // ! 29 + c "0" // ! 30 + c "1" // ! 31 + c "2" // ! 32 + c "3" // ! 33 + c "4" // ! 34 + c "5" // ! 35 + c "6" // ! 36 + c "7" // ! 37 + c "8" // ! 38 + c "9" // ! 39 + c "0" // ! 240 + c "1" // ! 1 + c "2" // ! 2 + c "3" // ! 3 + c "4" // ! 4 + c "5" // ! 5 + c "6" // ! 6 + c "7" // ! 7 + c "8" // ! 8 + c "9" // ! 9 + c "0" // ! 10 + c "1" // ! 11 + c "2" // ! 12 + c "3" // ! 13 + c "4" // ! 14 + c "5" // ! 255 + c "6" ! { dg-warning "Limit of 255 continuations exceeded" } + + end + \ No newline at end of file diff --git a/Fortran/gfortran/regression/continuation_7.f90 b/Fortran/gfortran/regression/continuation_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/continuation_7.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-Wall -std=f95" } +! There should only two warnings be printed. +! PR fortran/30968 +print *, "Foo bar& + &Bar foo" +print *, "Foo bar& + Bar foo" ! { dg-warning "Missing '&' in continued character constant" } +print *, "Foo bar"& + &, "Bar foo" +print *, "Foo bar"& + , "Bar foo" + +print '(& + a)', 'Hello' ! { dg-warning "Missing '&' in continued character constant" } +print '(& + &a)', 'Hello' +print '('& + &//'a)', 'Hello' +print '('& + // "a)", 'Hello' +end diff --git a/Fortran/gfortran/regression/continuation_8.f90 b/Fortran/gfortran/regression/continuation_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/continuation_8.f90 @@ -0,0 +1,9 @@ +! { dg-do run } +! PR31495 Is this continuation legal? +program print_ascertain +character (len=50) :: str +str = "hello world & +& & +&!" +if (str.ne."hello world !") STOP 1 +end program print_ascertain diff --git a/Fortran/gfortran/regression/continuation_9.f90 b/Fortran/gfortran/regression/continuation_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/continuation_9.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-std=f95" } + & +& + & +end +! { dg-warning "not allowed by itself in line 3" "" { target *-*-* } 0 } +! { dg-warning "not allowed by itself in line 4" "" { target *-*-* } 0 } +! { dg-warning "not allowed by itself in line 5" "" { target *-*-* } 0 } diff --git a/Fortran/gfortran/regression/convert_1.f90 b/Fortran/gfortran/regression/convert_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/convert_1.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! PR 26201: Check that the __convert_*_* functions are treated as intrinsics +! rather than module functions. +! Testcase contributed by Philippe Schaffnit and François-Xavier Coudert. +MODULE MODULE_A + REAL :: a = 0 +END MODULE MODULE_A + +MODULE MODULE_B + REAL :: b = 0 +END MODULE MODULE_B + +USE MODULE_A +USE MODULE_B +a = 0 +END diff --git a/Fortran/gfortran/regression/convert_2.f90 b/Fortran/gfortran/regression/convert_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/convert_2.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! Check for correct ordering of character variables with CONVERT + +program main + implicit none + integer, parameter :: two_swap = 2**25 + integer(kind=4) i,j + character(len=2) :: c,d + open(20,file="convert.dat",form="unformatted",convert="swap") ! { dg-warning "CONVERT" } + write (20) "ab" + close (20) + open(20,file="convert.dat",form="unformatted",access="stream") + read(20) i,c,j + if (i .ne. two_swap .or. j .ne. two_swap .or. c .ne. "ab") STOP 1 + close (20) + open(20,file="convert.dat",form="unformatted",convert="swap") ! { dg-warning "CONVERT" } + read (20) d + close (20,status="delete") + if (d .ne. "ab") STOP 2 +end program main diff --git a/Fortran/gfortran/regression/convert_implied_open.f90 b/Fortran/gfortran/regression/convert_implied_open.f90 --- /dev/null +++ b/Fortran/gfortran/regression/convert_implied_open.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-fconvert=swap" } +! PR 26735 - implied open didn't use to honor -fconvert +program main + implicit none + integer (kind=4) :: i1, i2, i3 + write (10) 1_4 + close (10) + open (10, form="unformatted", access="direct", recl=4) + read (10,rec=1) i1 + read (10,rec=2) i2 + read (10,rec=3) i3 + if (i1 /= 4 .or. i2 /= 1 .or. i3 /= 4) STOP 1 + close (10,status="delete") +end program main diff --git a/Fortran/gfortran/regression/count_init_expr.f03 b/Fortran/gfortran/regression/count_init_expr.f03 --- /dev/null +++ b/Fortran/gfortran/regression/count_init_expr.f03 @@ -0,0 +1,15 @@ +! { dg-do run } + + INTEGER :: i + INTEGER, PARAMETER :: m(4,4) = RESHAPE([ (i, i=1, 16) ], [4, 4] ) + INTEGER, PARAMETER :: sevens = COUNT (m == 7) + INTEGER, PARAMETER :: odd(4) = COUNT (MOD(m, 2) == 1, dim=1) + INTEGER, PARAMETER :: even = COUNT (MOD(m, 2) == 0) + + IF (sevens /= 1) STOP 1 + IF (ANY(odd /= [ 2,2,2,2 ])) STOP 2 + IF (even /= 8) STOP 3 + + ! check the kind parameter + IF (KIND(COUNT (m == 7, KIND=2)) /= 2) STOP 4 +END diff --git a/Fortran/gfortran/regression/count_mask_1.f90 b/Fortran/gfortran/regression/count_mask_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/count_mask_1.f90 @@ -0,0 +1,8 @@ +! { dg-do run } +! PR 36590, PR 36681 +program test + logical(kind=1),parameter :: t=.true.,f=.false. + logical(kind=1),dimension(9) :: hexa,hexb + data hexa/f,f,t,t,f,f,f,t,f/,hexb/f,t,f,f,f,t,t,f,f/ + isum=count(hexa(1:9).eqv.hexb(1:9)) +end program diff --git a/Fortran/gfortran/regression/coverage.f90 b/Fortran/gfortran/regression/coverage.f90 --- /dev/null +++ b/Fortran/gfortran/regression/coverage.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-additional-options "-fprofile-arcs -ftest-coverage" } +! +! PR fortran/95847 +! +module foo +contains + subroutine sbr() + end subroutine sbr +end module foo + +function foo_suite() result(suite) + use foo + integer :: bar + integer :: res + res = bar(sbr) +end function foo_suite diff --git a/Fortran/gfortran/regression/cr_lf.f90 b/Fortran/gfortran/regression/cr_lf.f90 --- /dev/null +++ b/Fortran/gfortran/regression/cr_lf.f90 @@ -0,0 +1,64 @@ +! { dg-do run } +! { dg-options "-fbackslash" } +! PR41328 and PR41168 Improper read of CR-LF sequences. +! Test case prepared by Jerry DeLisle +program main + implicit none + integer :: iostat, n_chars_read, k + character(len=1) :: buffer(64) = "" + character (len=80) :: u + + ! Set up the test file with normal file end. + open(unit=10, file="crlftest", form="unformatted", access="stream",& + & status="replace") + write(10) "a\rb\rc\r" ! CR at the end of each record. + close(10, status="keep") + + open(unit=10, file="crlftest", form="formatted", status="old") + + read( unit=10, fmt='(64A)', advance='NO', iostat=iostat, & + size=n_chars_read ) buffer + if (n_chars_read.ne.1) STOP 1 + if (any(buffer(1:n_chars_read).ne."a")) STOP 2 + if (.not.is_iostat_eor(iostat)) STOP 3 + + read( unit=10, fmt='(64A)', advance='NO', iostat=iostat, & + size=n_chars_read ) buffer + if (n_chars_read.ne.1) STOP 4 + if (any(buffer(1:n_chars_read).ne."b")) STOP 5 + if (.not.is_iostat_eor(iostat)) STOP 6 + + read( unit=10, fmt='(64A)', advance='NO', iostat=iostat, & + size=n_chars_read ) buffer + if (n_chars_read.ne.1) STOP 7 + if (any(buffer(1:n_chars_read).ne."c")) STOP 8 + if (.not.is_iostat_eor(iostat)) STOP 9 + + read( unit=10, fmt='(64A)', advance='NO', iostat=iostat, & + size=n_chars_read ) buffer + if (n_chars_read.ne.0) STOP 10 + if (any(buffer(1:n_chars_read).ne."a")) STOP 11 + if (.not.is_iostat_end(iostat)) STOP 12 + close(10, status="delete") + + ! Set up the test file with normal file end. + open(unit=10, file="crlftest", form="unformatted", access="stream",& + & status="replace") + write(10) "a\rb\rc\rno end of line marker" ! Note, no CR at end of file. + close(10, status="keep") + + open(unit=10, file="crlftest", status='old') + + do k = 1, 10 + read(10,'(a80)',end=101,err=100) u + !print *,k,' : ',u(1:len_trim(u)) + enddo + +100 continue + close(10, status="delete") + STOP 13 + +101 continue + close(10, status="delete") + if (u(1:len_trim(u)).ne."no end of line marker") STOP 14 +end program main diff --git a/Fortran/gfortran/regression/cray_pointers_1.f90 b/Fortran/gfortran/regression/cray_pointers_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/cray_pointers_1.f90 @@ -0,0 +1,68 @@ +! { dg-do compile } +! { dg-options "-fcray-pointer" } + +! Bad type for pointer +subroutine err1 + real ipt + real array(10) + pointer (ipt, array) ! { dg-error "integer" } +end subroutine err1 + +! Multiple declarations for the same pointee +subroutine err2 + real array(10) + pointer (ipt1, array) + pointer (ipt2, array) ! { dg-error "multiple" } +end subroutine err2 + +! Vector assignment to an assumed size array +subroutine err3 + real target(10) + real array(*) + pointer (ipt, array) + ipt = loc (target) + array = 0 ! { dg-error "upper bound in the last dimension" } +end subroutine err3 + +subroutine err4 + pointer (ipt, ipt) ! { dg-error "POINTER attribute" } +end subroutine err4 + +! duplicate array specs +subroutine err5 + pointer (ipt, array(7)) + real array(10) ! { dg-error "Duplicate array" } +end subroutine err5 + +subroutine err6 + real array(10) + pointer (ipt, array(7)) ! { dg-error "Duplicate array" } +end subroutine err6 + +! parsing stuff +subroutine err7 + pointer ( ! { dg-error "variable name" } + pointer (ipt ! { dg-error "Expected" } + pointer (ipt, ! { dg-error "variable name" } + pointer (ipt,a1 ! { dg-error "Expected" } + pointer (ipt,a2), ! { dg-error "Expected" } + pointer (ipt,a3),( ! { dg-error "variable name" } + pointer (ipt,a4),(ipt2 ! { dg-error "Expected" } + pointer (ipt,a5),(ipt2, ! { dg-error "variable name" } + pointer (ipt,a6),(ipt2,a7 ! { dg-error "Expected" } +end subroutine err7 + +! more attributes +subroutine err8(array) + real array(10) + integer dim(2) + integer, pointer :: f90ptr + integer, target :: f90targ + pointer (ipt, array) ! { dg-error "DUMMY" } + pointer (dim, elt1) ! { dg-error "DIMENSION" } + pointer (f90ptr, elt2) ! { dg-error "POINTER" } + pointer (ipt, f90ptr) ! { dg-error "POINTER" } + pointer (f90targ, elt3) ! { dg-error "TARGET" } + pointer (ipt, f90targ) ! { dg-error "TARGET" } +end subroutine err8 + diff --git a/Fortran/gfortran/regression/cray_pointers_10.f90 b/Fortran/gfortran/regression/cray_pointers_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/cray_pointers_10.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-options "-fcray-pointer" } +! +! PR fortran/45187 +! +module foo + implicit none + real :: a + pointer(c_a, a) +end module foo + +program test + use foo + real :: z + c_a = loc(z) + a = 42 + if (z /= 42) STOP 1 +end program test diff --git a/Fortran/gfortran/regression/cray_pointers_11.f90 b/Fortran/gfortran/regression/cray_pointers_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/cray_pointers_11.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-fcray-pointer" } +! +! PR fortran/62174 +! Component declarations within derived types would overwrite the typespec of +! variables with the same name who were Cray pointees. +implicit none + +type t1 + integer i +end type t1 +type(t1) x + +pointer (x_ptr, x) + +type t2 + real x ! should not overwrite x's type +end type t2 + +x%i = 0 ! should see no error here + +end diff --git a/Fortran/gfortran/regression/cray_pointers_12.f90 b/Fortran/gfortran/regression/cray_pointers_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/cray_pointers_12.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-fcray-pointer" } +! +! Test the fix for PR36497 in which there was no error for the second +! declaration of 'x'. +! +! Contributed by Tobias Burnus +! +module test + integer(8) ipt + integer z(2), x + pointer (ipt, x) +end module + +program bar + use test ! { dg-error "conflicts with symbol" } + integer x ! { dg-error "conflicts with symbol" } + ipt = loc(z(1)) + x = 1 + ipt = loc(z(2)) + x = 3 + if (any (z .ne. [1,3])) stop 1 +end diff --git a/Fortran/gfortran/regression/cray_pointers_2.f90 b/Fortran/gfortran/regression/cray_pointers_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/cray_pointers_2.f90 @@ -0,0 +1,3614 @@ +! Using two spaces between dg-do and run is a hack to keep gfortran-dg-runtest +! from cycling through optimization options for this expensive test. +! { dg-do run } +! { dg-options "-O3 -fcray-pointer -fbounds-check -fno-inline" } +! { dg-timeout-factor 4 } +! +! Series of routines for testing a Cray pointer implementation +! +! Note: Some of the test cases violate Fortran's alias rules; +! the "-fno-inline option" for now prevents failures. +! +program craytest + common /errors/errors(400) + common /foo/foo ! To prevent optimizations + integer foo + integer i + logical errors + errors = .false. + foo = 0 + call ptr1 + call ptr2 + call ptr3 + call ptr4 + call ptr5 + call ptr6 + call ptr7 + call ptr8 + call ptr9(9,10,11) + call ptr10(9,10,11) + call ptr11(9,10,11) + call ptr12(9,10,11) + call ptr13(9,10) + call parmtest +! NOTE: Tests 1 through 12 were removed from this file +! and placed in loc_1.f90, so we start at 13 + do i=13,400 + if (errors(i)) then +! print *,"Test",i,"failed." + STOP 1 + endif + end do + if (foo.eq.0) then +! print *,"Test did not run correctly." + STOP 2 + endif +end program craytest + +! ptr1 through ptr13 that Cray pointees are correctly used with +! a variety of declaration styles +subroutine ptr1 + common /errors/errors(400) + logical :: errors, intne, realne, chne, ch8ne + integer :: i,j,k + integer, parameter :: n = 9 + integer, parameter :: m = 10 + integer, parameter :: o = 11 + integer itarg1 (n) + integer itarg2 (m,n) + integer itarg3 (o,m,n) + real rtarg1(n) + real rtarg2(m,n) + real rtarg3(o,m,n) + character chtarg1(n) + character chtarg2(m,n) + character chtarg3(o,m,n) + character*8 ch8targ1(n) + character*8 ch8targ2(m,n) + character*8 ch8targ3(o,m,n) + type drvd + real r1 + integer i1 + integer i2(5) + end type drvd + type(drvd) dtarg1(n) + type(drvd) dtarg2(m,n) + type(drvd) dtarg3(o,m,n) + + type(drvd) dpte1(n) + type(drvd) dpte2(m,n) + type(drvd) dpte3(o,m,n) + integer ipte1 (n) + integer ipte2 (m,n) + integer ipte3 (o,m,n) + real rpte1(n) + real rpte2(m,n) + real rpte3(o,m,n) + character chpte1(n) + character chpte2(m,n) + character chpte3(o,m,n) + character*8 ch8pte1(n) + character*8 ch8pte2(m,n) + character*8 ch8pte3(o,m,n) + + pointer(iptr1,dpte1) + pointer(iptr2,dpte2) + pointer(iptr3,dpte3) + pointer(iptr4,ipte1) + pointer(iptr5,ipte2) + pointer(iptr6,ipte3) + pointer(iptr7,rpte1) + pointer(iptr8,rpte2) + pointer(iptr9,rpte3) + pointer(iptr10,chpte1) + pointer(iptr11,chpte2) + pointer(iptr12,chpte3) + pointer(iptr13,ch8pte1) + pointer(iptr14,ch8pte2) + pointer(iptr15,ch8pte3) + + iptr1 = loc(dtarg1) + iptr2 = loc(dtarg2) + iptr3 = loc(dtarg3) + iptr4 = loc(itarg1) + iptr5 = loc(itarg2) + iptr6 = loc(itarg3) + iptr7 = loc(rtarg1) + iptr8 = loc(rtarg2) + iptr9 = loc(rtarg3) + iptr10= loc(chtarg1) + iptr11= loc(chtarg2) + iptr12= loc(chtarg3) + iptr13= loc(ch8targ1) + iptr14= loc(ch8targ2) + iptr15= loc(ch8targ3) + + + do, i=1,n + dpte1(i)%i1=i + if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then + ! Error #13 + errors(13) = .true. + endif + + dtarg1(i)%i1=2*dpte1(i)%i1 + if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then + ! Error #14 + errors(14) = .true. + endif + + ipte1(i) = i + if (intne(ipte1(i), itarg1(i))) then + ! Error #15 + errors(15) = .true. + endif + + itarg1(i) = -ipte1(i) + if (intne(ipte1(i), itarg1(i))) then + ! Error #16 + errors(16) = .true. + endif + + rpte1(i) = i * 5.0 + if (realne(rpte1(i), rtarg1(i))) then + ! Error #17 + errors(17) = .true. + endif + + rtarg1(i) = i * (-5.0) + if (realne(rpte1(i), rtarg1(i))) then + ! Error #18 + errors(18) = .true. + endif + + chpte1(i) = 'a' + if (chne(chpte1(i), chtarg1(i))) then + ! Error #19 + errors(19) = .true. + endif + + chtarg1(i) = 'z' + if (chne(chpte1(i), chtarg1(i))) then + ! Error #20 + errors(20) = .true. + endif + + ch8pte1(i) = 'aaaaaaaa' + if (ch8ne(ch8pte1(i), ch8targ1(i))) then + ! Error #21 + errors(21) = .true. + endif + + ch8targ1(i) = 'zzzzzzzz' + if (ch8ne(ch8pte1(i), ch8targ1(i))) then + ! Error #22 + errors(22) = .true. + endif + + do, j=1,m + dpte2(j,i)%r1=1.0 + if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then + ! Error #23 + errors(23) = .true. + endif + + dtarg2(j,i)%r1=2*dpte2(j,i)%r1 + if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then + ! Error #24 + errors(24) = .true. + endif + + ipte2(j,i) = i + if (intne(ipte2(j,i), itarg2(j,i))) then + ! Error #25 + errors(25) = .true. + endif + + itarg2(j,i) = -ipte2(j,i) + if (intne(ipte2(j,i), itarg2(j,i))) then + ! Error #26 + errors(26) = .true. + endif + + rpte2(j,i) = i * (-2.0) + if (realne(rpte2(j,i), rtarg2(j,i))) then + ! Error #27 + errors(27) = .true. + endif + + rtarg2(j,i) = i * (-3.0) + if (realne(rpte2(j,i), rtarg2(j,i))) then + ! Error #28 + errors(28) = .true. + endif + + chpte2(j,i) = 'a' + if (chne(chpte2(j,i), chtarg2(j,i))) then + ! Error #29 + errors(29) = .true. + endif + + chtarg2(j,i) = 'z' + if (chne(chpte2(j,i), chtarg2(j,i))) then + ! Error #30 + errors(30) = .true. + endif + + ch8pte2(j,i) = 'aaaaaaaa' + if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then + ! Error #31 + errors(31) = .true. + endif + + ch8targ2(j,i) = 'zzzzzzzz' + if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then + ! Error #32 + errors(32) = .true. + endif + do k=1,o + dpte3(k,j,i)%i2(1+mod(i,5))=i + if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), & + dtarg3(k,j,i)%i2(1+mod(i,5)))) then + ! Error #33 + errors(33) = .true. + endif + + dtarg3(k,j,i)%i2(1+mod(i,5))=2*dpte3(k,j,i)%i2(1+mod(i,5)) + if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), & + dtarg3(k,j,i)%i2(1+mod(i,5)))) then + ! Error #34 + errors(34) = .true. + endif + + ipte3(k,j,i) = i + if (intne(ipte3(k,j,i), itarg3(k,j,i))) then + ! Error #35 + errors(35) = .true. + endif + + itarg3(k,j,i) = -ipte3(k,j,i) + if (intne(ipte3(k,j,i), itarg3(k,j,i))) then + ! Error #36 + errors(36) = .true. + endif + + rpte3(k,j,i) = i * 2.0 + if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then + ! Error #37 + errors(37) = .true. + endif + + rtarg3(k,j,i) = i * 3.0 + if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then + ! Error #38 + errors(38) = .true. + endif + + chpte3(k,j,i) = 'a' + if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then + ! Error #39 + errors(39) = .true. + endif + + chtarg3(k,j,i) = 'z' + if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then + ! Error #40 + errors(40) = .true. + endif + + ch8pte3(k,j,i) = 'aaaaaaaa' + if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then + ! Error #41 + errors(41) = .true. + endif + + ch8targ3(k,j,i) = 'zzzzzzzz' + if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then + ! Error #42 + errors(42) = .true. + endif + end do + end do + end do + + rtarg3 = .5 + ! Vector syntax + do, i=1,n + ipte3 = i + rpte3 = rpte3+1 + do, j=1,m + do k=1,o + if (intne(itarg3(k,j,i), i)) then + ! Error #43 + errors(43) = .true. + endif + + if (realne(rtarg3(k,j,i), i+.5)) then + ! Error #44 + errors(44) = .true. + endif + end do + end do + end do + +end subroutine ptr1 + + +subroutine ptr2 + common /errors/errors(400) + logical :: errors, intne, realne, chne, ch8ne + integer :: i,j,k + integer, parameter :: n = 9 + integer, parameter :: m = 10 + integer, parameter :: o = 11 + integer itarg1 (n) + integer itarg2 (m,n) + integer itarg3 (o,m,n) + real rtarg1(n) + real rtarg2(m,n) + real rtarg3(o,m,n) + character chtarg1(n) + character chtarg2(m,n) + character chtarg3(o,m,n) + character*8 ch8targ1(n) + character*8 ch8targ2(m,n) + character*8 ch8targ3(o,m,n) + type drvd + real r1 + integer i1 + integer i2(5) + end type drvd + type(drvd) dtarg1(n) + type(drvd) dtarg2(m,n) + type(drvd) dtarg3(o,m,n) + + type(drvd) dpte1 + type(drvd) dpte2 + type(drvd) dpte3 + integer ipte1 + integer ipte2 + integer ipte3 + real rpte1 + real rpte2 + real rpte3 + character chpte1 + character chpte2 + character chpte3 + character*8 ch8pte1 + character*8 ch8pte2 + character*8 ch8pte3 + + pointer(iptr1,dpte1(n)) + pointer(iptr2,dpte2(m,n)) + pointer(iptr3,dpte3(o,m,n)) + pointer(iptr4,ipte1(n)) + pointer(iptr5,ipte2 (m,n)) + pointer(iptr6,ipte3(o,m,n)) + pointer(iptr7,rpte1(n)) + pointer(iptr8,rpte2(m,n)) + pointer(iptr9,rpte3(o,m,n)) + pointer(iptr10,chpte1(n)) + pointer(iptr11,chpte2(m,n)) + pointer(iptr12,chpte3(o,m,n)) + pointer(iptr13,ch8pte1(n)) + pointer(iptr14,ch8pte2(m,n)) + pointer(iptr15,ch8pte3(o,m,n)) + + iptr1 = loc(dtarg1) + iptr2 = loc(dtarg2) + iptr3 = loc(dtarg3) + iptr4 = loc(itarg1) + iptr5 = loc(itarg2) + iptr6 = loc(itarg3) + iptr7 = loc(rtarg1) + iptr8 = loc(rtarg2) + iptr9 = loc(rtarg3) + iptr10= loc(chtarg1) + iptr11= loc(chtarg2) + iptr12= loc(chtarg3) + iptr13= loc(ch8targ1) + iptr14= loc(ch8targ2) + iptr15= loc(ch8targ3) + + do, i=1,n + dpte1(i)%i1=i + if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then + ! Error #45 + errors(45) = .true. + endif + + dtarg1(i)%i1=2*dpte1(i)%i1 + if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then + ! Error #46 + errors(46) = .true. + endif + + ipte1(i) = i + if (intne(ipte1(i), itarg1(i))) then + ! Error #47 + errors(47) = .true. + endif + + itarg1(i) = -ipte1(i) + if (intne(ipte1(i), itarg1(i))) then + ! Error #48 + errors(48) = .true. + endif + + rpte1(i) = i * 5.0 + if (realne(rpte1(i), rtarg1(i))) then + ! Error #49 + errors(49) = .true. + endif + + rtarg1(i) = i * (-5.0) + if (realne(rpte1(i), rtarg1(i))) then + ! Error #50 + errors(50) = .true. + endif + + chpte1(i) = 'a' + if (chne(chpte1(i), chtarg1(i))) then + ! Error #51 + errors(51) = .true. + endif + + chtarg1(i) = 'z' + if (chne(chpte1(i), chtarg1(i))) then + ! Error #52 + errors(52) = .true. + endif + + ch8pte1(i) = 'aaaaaaaa' + if (ch8ne(ch8pte1(i), ch8targ1(i))) then + ! Error #53 + errors(53) = .true. + endif + + ch8targ1(i) = 'zzzzzzzz' + if (ch8ne(ch8pte1(i), ch8targ1(i))) then + ! Error #54 + errors(54) = .true. + endif + + do, j=1,m + dpte2(j,i)%r1=1.0 + if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then + ! Error #55 + errors(55) = .true. + endif + + dtarg2(j,i)%r1=2*dpte2(j,i)%r1 + if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then + ! Error #56 + errors(56) = .true. + endif + + ipte2(j,i) = i + if (intne(ipte2(j,i), itarg2(j,i))) then + ! Error #57 + errors(57) = .true. + endif + + itarg2(j,i) = -ipte2(j,i) + if (intne(ipte2(j,i), itarg2(j,i))) then + ! Error #58 + errors(58) = .true. + endif + + rpte2(j,i) = i * (-2.0) + if (realne(rpte2(j,i), rtarg2(j,i))) then + ! Error #59 + errors(59) = .true. + endif + + rtarg2(j,i) = i * (-3.0) + if (realne(rpte2(j,i), rtarg2(j,i))) then + ! Error #60 + errors(60) = .true. + endif + + chpte2(j,i) = 'a' + if (chne(chpte2(j,i), chtarg2(j,i))) then + ! Error #61 + errors(61) = .true. + endif + + chtarg2(j,i) = 'z' + if (chne(chpte2(j,i), chtarg2(j,i))) then + ! Error #62 + errors(62) = .true. + endif + + ch8pte2(j,i) = 'aaaaaaaa' + if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then + ! Error #63 + errors(63) = .true. + endif + + ch8targ2(j,i) = 'zzzzzzzz' + if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then + ! Error #64 + errors(64) = .true. + endif + do k=1,o + dpte3(k,j,i)%i2(1+mod(i,5))=i + if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), dtarg3(k,j,i)%i2(1+mod(i,5)))) then + ! Error #65 + errors(65) = .true. + endif + + dtarg3(k,j,i)%i2(1+mod(i,5))=2*dpte3(k,j,i)%i2(1+mod(i,5)) + if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), dtarg3(k,j,i)%i2(1+mod(i,5)))) then + ! Error #66 + errors(66) = .true. + endif + + ipte3(k,j,i) = i + if (intne(ipte3(k,j,i), itarg3(k,j,i))) then + ! Error #67 + errors(67) = .true. + endif + + itarg3(k,j,i) = -ipte3(k,j,i) + if (intne(ipte3(k,j,i), itarg3(k,j,i))) then + ! Error #68 + errors(68) = .true. + endif + + rpte3(k,j,i) = i * 2.0 + if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then + ! Error #69 + errors(69) = .true. + endif + + rtarg3(k,j,i) = i * 3.0 + if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then + ! Error #70 + errors(70) = .true. + endif + + chpte3(k,j,i) = 'a' + if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then + ! Error #71 + errors(71) = .true. + endif + + chtarg3(k,j,i) = 'z' + if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then + ! Error #72 + errors(72) = .true. + endif + + ch8pte3(k,j,i) = 'aaaaaaaa' + if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then + ! Error #73 + errors(73) = .true. + endif + + ch8targ3(k,j,i) = 'zzzzzzzz' + if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then + ! Error #74 + errors(74) = .true. + endif + end do + end do + end do + + rtarg3 = .5 + ! Vector syntax + do, i=1,n + ipte3 = i + rpte3 = rpte3+1 + do, j=1,m + do k=1,o + if (intne(itarg3(k,j,i), i)) then + ! Error #75 + errors(75) = .true. + endif + + if (realne(rtarg3(k,j,i), i+.5)) then + ! Error #76 + errors(76) = .true. + endif + end do + end do + end do +end subroutine ptr2 + +subroutine ptr3 + common /errors/errors(400) + logical :: errors, intne, realne, chne, ch8ne + integer :: i,j,k + integer, parameter :: n = 9 + integer, parameter :: m = 10 + integer, parameter :: o = 11 + integer itarg1 (n) + integer itarg2 (m,n) + integer itarg3 (o,m,n) + real rtarg1(n) + real rtarg2(m,n) + real rtarg3(o,m,n) + character chtarg1(n) + character chtarg2(m,n) + character chtarg3(o,m,n) + character*8 ch8targ1(n) + character*8 ch8targ2(m,n) + character*8 ch8targ3(o,m,n) + type drvd + real r1 + integer i1 + integer i2(5) + end type drvd + type(drvd) dtarg1(n) + type(drvd) dtarg2(m,n) + type(drvd) dtarg3(o,m,n) + + pointer(iptr1,dpte1(n)) + pointer(iptr2,dpte2(m,n)) + pointer(iptr3,dpte3(o,m,n)) + pointer(iptr4,ipte1(n)) + pointer(iptr5,ipte2 (m,n)) + pointer(iptr6,ipte3(o,m,n)) + pointer(iptr7,rpte1(n)) + pointer(iptr8,rpte2(m,n)) + pointer(iptr9,rpte3(o,m,n)) + pointer(iptr10,chpte1(n)) + pointer(iptr11,chpte2(m,n)) + pointer(iptr12,chpte3(o,m,n)) + pointer(iptr13,ch8pte1(n)) + pointer(iptr14,ch8pte2(m,n)) + pointer(iptr15,ch8pte3(o,m,n)) + + type(drvd) dpte1 + type(drvd) dpte2 + type(drvd) dpte3 + integer ipte1 + integer ipte2 + integer ipte3 + real rpte1 + real rpte2 + real rpte3 + character chpte1 + character chpte2 + character chpte3 + character*8 ch8pte1 + character*8 ch8pte2 + character*8 ch8pte3 + + iptr1 = loc(dtarg1) + iptr2 = loc(dtarg2) + iptr3 = loc(dtarg3) + iptr4 = loc(itarg1) + iptr5 = loc(itarg2) + iptr6 = loc(itarg3) + iptr7 = loc(rtarg1) + iptr8 = loc(rtarg2) + iptr9 = loc(rtarg3) + iptr10= loc(chtarg1) + iptr11= loc(chtarg2) + iptr12= loc(chtarg3) + iptr13= loc(ch8targ1) + iptr14= loc(ch8targ2) + iptr15= loc(ch8targ3) + + do, i=1,n + dpte1(i)%i1=i + if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then + ! Error #77 + errors(77) = .true. + endif + + dtarg1(i)%i1=2*dpte1(i)%i1 + if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then + ! Error #78 + errors(78) = .true. + endif + + ipte1(i) = i + if (intne(ipte1(i), itarg1(i))) then + ! Error #79 + errors(79) = .true. + endif + + itarg1(i) = -ipte1(i) + if (intne(ipte1(i), itarg1(i))) then + ! Error #80 + errors(80) = .true. + endif + + rpte1(i) = i * 5.0 + if (realne(rpte1(i), rtarg1(i))) then + ! Error #81 + errors(81) = .true. + endif + + rtarg1(i) = i * (-5.0) + if (realne(rpte1(i), rtarg1(i))) then + ! Error #82 + errors(82) = .true. + endif + + chpte1(i) = 'a' + if (chne(chpte1(i), chtarg1(i))) then + ! Error #83 + errors(83) = .true. + endif + + chtarg1(i) = 'z' + if (chne(chpte1(i), chtarg1(i))) then + ! Error #84 + errors(84) = .true. + endif + + ch8pte1(i) = 'aaaaaaaa' + if (ch8ne(ch8pte1(i), ch8targ1(i))) then + ! Error #85 + errors(85) = .true. + endif + + ch8targ1(i) = 'zzzzzzzz' + if (ch8ne(ch8pte1(i), ch8targ1(i))) then + ! Error #86 + errors(86) = .true. + endif + + do, j=1,m + dpte2(j,i)%r1=1.0 + if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then + ! Error #87 + errors(87) = .true. + endif + + dtarg2(j,i)%r1=2*dpte2(j,i)%r1 + if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then + ! Error #88 + errors(88) = .true. + endif + + ipte2(j,i) = i + if (intne(ipte2(j,i), itarg2(j,i))) then + ! Error #89 + errors(89) = .true. + endif + + itarg2(j,i) = -ipte2(j,i) + if (intne(ipte2(j,i), itarg2(j,i))) then + ! Error #90 + errors(90) = .true. + endif + + rpte2(j,i) = i * (-2.0) + if (realne(rpte2(j,i), rtarg2(j,i))) then + ! Error #91 + errors(91) = .true. + endif + + rtarg2(j,i) = i * (-3.0) + if (realne(rpte2(j,i), rtarg2(j,i))) then + ! Error #92 + errors(92) = .true. + endif + + chpte2(j,i) = 'a' + if (chne(chpte2(j,i), chtarg2(j,i))) then + ! Error #93 + errors(93) = .true. + endif + + chtarg2(j,i) = 'z' + if (chne(chpte2(j,i), chtarg2(j,i))) then + ! Error #94 + errors(94) = .true. + endif + + ch8pte2(j,i) = 'aaaaaaaa' + if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then + ! Error #95 + errors(95) = .true. + endif + + ch8targ2(j,i) = 'zzzzzzzz' + if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then + ! Error #96 + errors(96) = .true. + endif + do k=1,o + dpte3(k,j,i)%i2(1+mod(i,5))=i + if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), & + dtarg3(k,j,i)%i2(1+mod(i,5)))) then + ! Error #97 + errors(97) = .true. + endif + + dtarg3(k,j,i)%i2(1+mod(i,5))=2*dpte3(k,j,i)%i2(1+mod(i,5)) + if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), & + dtarg3(k,j,i)%i2(1+mod(i,5)))) then + ! Error #98 + errors(98) = .true. + endif + + ipte3(k,j,i) = i + if (intne(ipte3(k,j,i), itarg3(k,j,i))) then + ! Error #99 + errors(99) = .true. + endif + + itarg3(k,j,i) = -ipte3(k,j,i) + if (intne(ipte3(k,j,i), itarg3(k,j,i))) then + ! Error #100 + errors(100) = .true. + endif + + rpte3(k,j,i) = i * 2.0 + if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then + ! Error #101 + errors(101) = .true. + endif + + rtarg3(k,j,i) = i * 3.0 + if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then + ! Error #102 + errors(102) = .true. + endif + + chpte3(k,j,i) = 'a' + if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then + ! Error #103 + errors(103) = .true. + endif + + chtarg3(k,j,i) = 'z' + if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then + ! Error #104 + errors(104) = .true. + endif + + ch8pte3(k,j,i) = 'aaaaaaaa' + if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then + ! Error #105 + errors(105) = .true. + endif + + ch8targ3(k,j,i) = 'zzzzzzzz' + if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then + ! Error #106 + errors(106) = .true. + endif + end do + end do + end do + + rtarg3 = .5 + ! Vector syntax + do, i=1,n + ipte3 = i + rpte3 = rpte3+1 + do, j=1,m + do k=1,o + if (intne(itarg3(k,j,i), i)) then + ! Error #107 + errors(107) = .true. + endif + + if (realne(rtarg3(k,j,i), i+.5)) then + ! Error #108 + errors(108) = .true. + endif + end do + end do + end do +end subroutine ptr3 + +subroutine ptr4 + common /errors/errors(400) + logical :: errors, intne, realne, chne, ch8ne + integer :: i,j,k + integer, parameter :: n = 9 + integer, parameter :: m = 10 + integer, parameter :: o = 11 + integer itarg1 (n) + integer itarg2 (m,n) + integer itarg3 (o,m,n) + real rtarg1(n) + real rtarg2(m,n) + real rtarg3(o,m,n) + character chtarg1(n) + character chtarg2(m,n) + character chtarg3(o,m,n) + character*8 ch8targ1(n) + character*8 ch8targ2(m,n) + character*8 ch8targ3(o,m,n) + type drvd + real r1 + integer i1 + integer i2(5) + end type drvd + type(drvd) dtarg1(n) + type(drvd) dtarg2(m,n) + type(drvd) dtarg3(o,m,n) + + pointer(iptr1,dpte1),(iptr2,dpte2),(iptr3,dpte3) + pointer (iptr4,ipte1), (iptr5,ipte2) ,(iptr6,ipte3),(iptr7,rpte1) + pointer(iptr8,rpte2) + pointer(iptr9,rpte3),(iptr10,chpte1) + pointer(iptr11,chpte2),(iptr12,chpte3),(iptr13,ch8pte1) + pointer(iptr14,ch8pte2) + pointer(iptr15,ch8pte3) + + type(drvd) dpte1(n) + type(drvd) dpte2(m,n) + type(drvd) dpte3(o,m,n) + integer ipte1 (n) + integer ipte2 (m,n) + integer ipte3 (o,m,n) + real rpte1(n) + real rpte2(m,n) + real rpte3(o,m,n) + character chpte1(n) + character chpte2(m,n) + character chpte3(o,m,n) + character*8 ch8pte1(n) + character*8 ch8pte2(m,n) + character*8 ch8pte3(o,m,n) + + iptr1 = loc(dtarg1) + iptr2 = loc(dtarg2) + iptr3 = loc(dtarg3) + iptr4 = loc(itarg1) + iptr5 = loc(itarg2) + iptr6 = loc(itarg3) + iptr7 = loc(rtarg1) + iptr8 = loc(rtarg2) + iptr9 = loc(rtarg3) + iptr10= loc(chtarg1) + iptr11= loc(chtarg2) + iptr12= loc(chtarg3) + iptr13= loc(ch8targ1) + iptr14= loc(ch8targ2) + iptr15= loc(ch8targ3) + + + do, i=1,n + dpte1(i)%i1=i + if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then + ! Error #109 + errors(109) = .true. + endif + + dtarg1(i)%i1=2*dpte1(i)%i1 + if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then + ! Error #110 + errors(110) = .true. + endif + + ipte1(i) = i + if (intne(ipte1(i), itarg1(i))) then + ! Error #111 + errors(111) = .true. + endif + + itarg1(i) = -ipte1(i) + if (intne(ipte1(i), itarg1(i))) then + ! Error #112 + errors(112) = .true. + endif + + rpte1(i) = i * 5.0 + if (realne(rpte1(i), rtarg1(i))) then + ! Error #113 + errors(113) = .true. + endif + + rtarg1(i) = i * (-5.0) + if (realne(rpte1(i), rtarg1(i))) then + ! Error #114 + errors(114) = .true. + endif + + chpte1(i) = 'a' + if (chne(chpte1(i), chtarg1(i))) then + ! Error #115 + errors(115) = .true. + endif + + chtarg1(i) = 'z' + if (chne(chpte1(i), chtarg1(i))) then + ! Error #116 + errors(116) = .true. + endif + + ch8pte1(i) = 'aaaaaaaa' + if (ch8ne(ch8pte1(i), ch8targ1(i))) then + ! Error #117 + errors(117) = .true. + endif + + ch8targ1(i) = 'zzzzzzzz' + if (ch8ne(ch8pte1(i), ch8targ1(i))) then + ! Error #118 + errors(118) = .true. + endif + + do, j=1,m + dpte2(j,i)%r1=1.0 + if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then + ! Error #119 + errors(119) = .true. + endif + + dtarg2(j,i)%r1=2*dpte2(j,i)%r1 + if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then + ! Error #120 + errors(120) = .true. + endif + + ipte2(j,i) = i + if (intne(ipte2(j,i), itarg2(j,i))) then + ! Error #121 + errors(121) = .true. + endif + + itarg2(j,i) = -ipte2(j,i) + if (intne(ipte2(j,i), itarg2(j,i))) then + ! Error #122 + errors(122) = .true. + endif + + rpte2(j,i) = i * (-2.0) + if (realne(rpte2(j,i), rtarg2(j,i))) then + ! Error #123 + errors(123) = .true. + endif + + rtarg2(j,i) = i * (-3.0) + if (realne(rpte2(j,i), rtarg2(j,i))) then + ! Error #124 + errors(124) = .true. + endif + + chpte2(j,i) = 'a' + if (chne(chpte2(j,i), chtarg2(j,i))) then + ! Error #125 + errors(125) = .true. + endif + + chtarg2(j,i) = 'z' + if (chne(chpte2(j,i), chtarg2(j,i))) then + ! Error #126 + errors(126) = .true. + endif + + ch8pte2(j,i) = 'aaaaaaaa' + if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then + ! Error #127 + errors(127) = .true. + endif + + ch8targ2(j,i) = 'zzzzzzzz' + if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then + ! Error #128 + errors(128) = .true. + endif + do k=1,o + dpte3(k,j,i)%i2(1+mod(i,5))=i + if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), & + dtarg3(k,j,i)%i2(1+mod(i,5)))) then + ! Error #129 + errors(129) = .true. + endif + + dtarg3(k,j,i)%i2(1+mod(i,5))=2*dpte3(k,j,i)%i2(1+mod(i,5)) + if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), & + dtarg3(k,j,i)%i2(1+mod(i,5)))) then + ! Error #130 + errors(130) = .true. + endif + + ipte3(k,j,i) = i + if (intne(ipte3(k,j,i), itarg3(k,j,i))) then + ! Error #131 + errors(131) = .true. + endif + + itarg3(k,j,i) = -ipte3(k,j,i) + if (intne(ipte3(k,j,i), itarg3(k,j,i))) then + ! Error #132 + errors(132) = .true. + endif + + rpte3(k,j,i) = i * 2.0 + if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then + ! Error #133 + errors(133) = .true. + endif + + rtarg3(k,j,i) = i * 3.0 + if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then + ! Error #134 + errors(134) = .true. + endif + + chpte3(k,j,i) = 'a' + if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then + ! Error #135 + errors(135) = .true. + endif + + chtarg3(k,j,i) = 'z' + if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then + ! Error #136 + errors(136) = .true. + endif + + ch8pte3(k,j,i) = 'aaaaaaaa' + if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then + ! Error #137 + errors(137) = .true. + endif + + ch8targ3(k,j,i) = 'zzzzzzzz' + if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then + ! Error #138 + errors(138) = .true. + endif + end do + end do + end do + + rtarg3 = .5 + ! Vector syntax + do, i=1,n + ipte3 = i + rpte3 = rpte3+1 + do, j=1,m + do k=1,o + if (intne(itarg3(k,j,i), i)) then + ! Error #139 + errors(139) = .true. + endif + + if (realne(rtarg3(k,j,i), i+.5)) then + ! Error #140 + errors(140) = .true. + endif + end do + end do + end do + +end subroutine ptr4 + +subroutine ptr5 + common /errors/errors(400) + logical :: errors, intne, realne, chne, ch8ne + integer :: i,j,k + integer, parameter :: n = 9 + integer, parameter :: m = 10 + integer, parameter :: o = 11 + integer itarg1 (n) + integer itarg2 (m,n) + integer itarg3 (o,m,n) + real rtarg1(n) + real rtarg2(m,n) + real rtarg3(o,m,n) + character chtarg1(n) + character chtarg2(m,n) + character chtarg3(o,m,n) + character*8 ch8targ1(n) + character*8 ch8targ2(m,n) + character*8 ch8targ3(o,m,n) + type drvd + real r1 + integer i1 + integer i2(5) + end type drvd + type(drvd) dtarg1(n) + type(drvd) dtarg2(m,n) + type(drvd) dtarg3(o,m,n) + + type(drvd) dpte1(*) + type(drvd) dpte2(m,*) + type(drvd) dpte3(o,m,*) + integer ipte1 (*) + integer ipte2 (m,*) + integer ipte3 (o,m,*) + real rpte1(*) + real rpte2(m,*) + real rpte3(o,m,*) + character chpte1(*) + character chpte2(m,*) + character chpte3(o,m,*) + character*8 ch8pte1(*) + character*8 ch8pte2(m,*) + character*8 ch8pte3(o,m,*) + + pointer(iptr1,dpte1) + pointer(iptr2,dpte2) + pointer(iptr3,dpte3) + pointer(iptr4,ipte1) + pointer(iptr5,ipte2) + pointer(iptr6,ipte3) + pointer(iptr7,rpte1) + pointer(iptr8,rpte2) + pointer(iptr9,rpte3) + pointer(iptr10,chpte1) + pointer(iptr11,chpte2) + pointer(iptr12,chpte3) + pointer(iptr13,ch8pte1) + pointer(iptr14,ch8pte2) + pointer(iptr15,ch8pte3) + + iptr1 = loc(dtarg1) + iptr2 = loc(dtarg2) + iptr3 = loc(dtarg3) + iptr4 = loc(itarg1) + iptr5 = loc(itarg2) + iptr6 = loc(itarg3) + iptr7 = loc(rtarg1) + iptr8 = loc(rtarg2) + iptr9 = loc(rtarg3) + iptr10= loc(chtarg1) + iptr11= loc(chtarg2) + iptr12= loc(chtarg3) + iptr13= loc(ch8targ1) + iptr14= loc(ch8targ2) + iptr15= loc(ch8targ3) + + + do, i=1,n + dpte1(i)%i1=i + if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then + ! Error #141 + errors(141) = .true. + endif + + dtarg1(i)%i1=2*dpte1(i)%i1 + if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then + ! Error #142 + errors(142) = .true. + endif + + ipte1(i) = i + if (intne(ipte1(i), itarg1(i))) then + ! Error #143 + errors(143) = .true. + endif + + itarg1(i) = -ipte1(i) + if (intne(ipte1(i), itarg1(i))) then + ! Error #144 + errors(144) = .true. + endif + + rpte1(i) = i * 5.0 + if (realne(rpte1(i), rtarg1(i))) then + ! Error #145 + errors(145) = .true. + endif + + rtarg1(i) = i * (-5.0) + if (realne(rpte1(i), rtarg1(i))) then + ! Error #146 + errors(146) = .true. + endif + + chpte1(i) = 'a' + if (chne(chpte1(i), chtarg1(i))) then + ! Error #147 + errors(147) = .true. + endif + + chtarg1(i) = 'z' + if (chne(chpte1(i), chtarg1(i))) then + ! Error #148 + errors(148) = .true. + endif + + ch8pte1(i) = 'aaaaaaaa' + if (ch8ne(ch8pte1(i), ch8targ1(i))) then + ! Error #149 + errors(149) = .true. + endif + + ch8targ1(i) = 'zzzzzzzz' + if (ch8ne(ch8pte1(i), ch8targ1(i))) then + ! Error #150 + errors(150) = .true. + endif + + do, j=1,m + dpte2(j,i)%r1=1.0 + if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then + ! Error #151 + errors(151) = .true. + endif + + dtarg2(j,i)%r1=2*dpte2(j,i)%r1 + if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then + ! Error #152 + errors(152) = .true. + endif + + ipte2(j,i) = i + if (intne(ipte2(j,i), itarg2(j,i))) then + ! Error #153 + errors(153) = .true. + endif + + itarg2(j,i) = -ipte2(j,i) + if (intne(ipte2(j,i), itarg2(j,i))) then + ! Error #154 + errors(154) = .true. + endif + + rpte2(j,i) = i * (-2.0) + if (realne(rpte2(j,i), rtarg2(j,i))) then + ! Error #155 + errors(155) = .true. + endif + + rtarg2(j,i) = i * (-3.0) + if (realne(rpte2(j,i), rtarg2(j,i))) then + ! Error #156 + errors(156) = .true. + endif + + chpte2(j,i) = 'a' + if (chne(chpte2(j,i), chtarg2(j,i))) then + ! Error #157 + errors(157) = .true. + endif + + chtarg2(j,i) = 'z' + if (chne(chpte2(j,i), chtarg2(j,i))) then + ! Error #158 + errors(158) = .true. + endif + + ch8pte2(j,i) = 'aaaaaaaa' + if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then + ! Error #159 + errors(159) = .true. + endif + + ch8targ2(j,i) = 'zzzzzzzz' + if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then + ! Error #160 + errors(160) = .true. + endif + do k=1,o + dpte3(k,j,i)%i2(1+mod(i,5))=i + if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), & + dtarg3(k,j,i)%i2(1+mod(i,5)))) then + ! Error #161 + errors(161) = .true. + endif + + dtarg3(k,j,i)%i2(1+mod(i,5))=2*dpte3(k,j,i)%i2(1+mod(i,5)) + if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), & + dtarg3(k,j,i)%i2(1+mod(i,5)))) then + ! Error #162 + errors(162) = .true. + endif + + ipte3(k,j,i) = i + if (intne(ipte3(k,j,i), itarg3(k,j,i))) then + ! Error #163 + errors(163) = .true. + endif + + itarg3(k,j,i) = -ipte3(k,j,i) + if (intne(ipte3(k,j,i), itarg3(k,j,i))) then + ! Error #164 + errors(164) = .true. + endif + + rpte3(k,j,i) = i * 2.0 + if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then + ! Error #165 + errors(165) = .true. + endif + + rtarg3(k,j,i) = i * 3.0 + if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then + ! Error #166 + errors(166) = .true. + endif + + chpte3(k,j,i) = 'a' + if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then + ! Error #167 + errors(167) = .true. + endif + + chtarg3(k,j,i) = 'z' + if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then + ! Error #168 + errors(168) = .true. + endif + + ch8pte3(k,j,i) = 'aaaaaaaa' + if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then + ! Error #169 + errors(169) = .true. + endif + + ch8targ3(k,j,i) = 'zzzzzzzz' + if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then + ! Error #170 + errors(170) = .true. + endif + end do + end do + end do + +end subroutine ptr5 + + +subroutine ptr6 + common /errors/errors(400) + logical :: errors, intne, realne, chne, ch8ne + integer :: i,j,k + integer, parameter :: n = 9 + integer, parameter :: m = 10 + integer, parameter :: o = 11 + integer itarg1 (n) + integer itarg2 (m,n) + integer itarg3 (o,m,n) + real rtarg1(n) + real rtarg2(m,n) + real rtarg3(o,m,n) + character chtarg1(n) + character chtarg2(m,n) + character chtarg3(o,m,n) + character*8 ch8targ1(n) + character*8 ch8targ2(m,n) + character*8 ch8targ3(o,m,n) + type drvd + real r1 + integer i1 + integer i2(5) + end type drvd + type(drvd) dtarg1(n) + type(drvd) dtarg2(m,n) + type(drvd) dtarg3(o,m,n) + + type(drvd) dpte1 + type(drvd) dpte2 + type(drvd) dpte3 + integer ipte1 + integer ipte2 + integer ipte3 + real rpte1 + real rpte2 + real rpte3 + character chpte1 + character chpte2 + character chpte3 + character*8 ch8pte1 + character*8 ch8pte2 + character*8 ch8pte3 + + pointer(iptr1,dpte1(*)) + pointer(iptr2,dpte2(m,*)) + pointer(iptr3,dpte3(o,m,*)) + pointer(iptr4,ipte1(*)) + pointer(iptr5,ipte2 (m,*)) + pointer(iptr6,ipte3(o,m,*)) + pointer(iptr7,rpte1(*)) + pointer(iptr8,rpte2(m,*)) + pointer(iptr9,rpte3(o,m,*)) + pointer(iptr10,chpte1(*)) + pointer(iptr11,chpte2(m,*)) + pointer(iptr12,chpte3(o,m,*)) + pointer(iptr13,ch8pte1(*)) + pointer(iptr14,ch8pte2(m,*)) + pointer(iptr15,ch8pte3(o,m,*)) + + iptr1 = loc(dtarg1) + iptr2 = loc(dtarg2) + iptr3 = loc(dtarg3) + iptr4 = loc(itarg1) + iptr5 = loc(itarg2) + iptr6 = loc(itarg3) + iptr7 = loc(rtarg1) + iptr8 = loc(rtarg2) + iptr9 = loc(rtarg3) + iptr10= loc(chtarg1) + iptr11= loc(chtarg2) + iptr12= loc(chtarg3) + iptr13= loc(ch8targ1) + iptr14= loc(ch8targ2) + iptr15= loc(ch8targ3) + + do, i=1,n + dpte1(i)%i1=i + if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then + ! Error #171 + errors(171) = .true. + endif + + dtarg1(i)%i1=2*dpte1(i)%i1 + if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then + ! Error #172 + errors(172) = .true. + endif + + ipte1(i) = i + if (intne(ipte1(i), itarg1(i))) then + ! Error #173 + errors(173) = .true. + endif + + itarg1(i) = -ipte1(i) + if (intne(ipte1(i), itarg1(i))) then + ! Error #174 + errors(174) = .true. + endif + + rpte1(i) = i * 5.0 + if (realne(rpte1(i), rtarg1(i))) then + ! Error #175 + errors(175) = .true. + endif + + rtarg1(i) = i * (-5.0) + if (realne(rpte1(i), rtarg1(i))) then + ! Error #176 + errors(176) = .true. + endif + + chpte1(i) = 'a' + if (chne(chpte1(i), chtarg1(i))) then + ! Error #177 + errors(177) = .true. + endif + + chtarg1(i) = 'z' + if (chne(chpte1(i), chtarg1(i))) then + ! Error #178 + errors(178) = .true. + endif + + ch8pte1(i) = 'aaaaaaaa' + if (ch8ne(ch8pte1(i), ch8targ1(i))) then + ! Error #179 + errors(179) = .true. + endif + + ch8targ1(i) = 'zzzzzzzz' + if (ch8ne(ch8pte1(i), ch8targ1(i))) then + ! Error #180 + errors(180) = .true. + endif + + do, j=1,m + dpte2(j,i)%r1=1.0 + if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then + ! Error #181 + errors(181) = .true. + endif + + dtarg2(j,i)%r1=2*dpte2(j,i)%r1 + if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then + ! Error #182 + errors(182) = .true. + endif + + ipte2(j,i) = i + if (intne(ipte2(j,i), itarg2(j,i))) then + ! Error #183 + errors(183) = .true. + endif + + itarg2(j,i) = -ipte2(j,i) + if (intne(ipte2(j,i), itarg2(j,i))) then + ! Error #184 + errors(184) = .true. + endif + + rpte2(j,i) = i * (-2.0) + if (realne(rpte2(j,i), rtarg2(j,i))) then + ! Error #185 + errors(185) = .true. + endif + + rtarg2(j,i) = i * (-3.0) + if (realne(rpte2(j,i), rtarg2(j,i))) then + ! Error #186 + errors(186) = .true. + endif + + chpte2(j,i) = 'a' + if (chne(chpte2(j,i), chtarg2(j,i))) then + ! Error #187 + errors(187) = .true. + endif + + chtarg2(j,i) = 'z' + if (chne(chpte2(j,i), chtarg2(j,i))) then + ! Error #188 + errors(188) = .true. + endif + + ch8pte2(j,i) = 'aaaaaaaa' + if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then + ! Error #189 + errors(189) = .true. + endif + + ch8targ2(j,i) = 'zzzzzzzz' + if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then + ! Error #190 + errors(190) = .true. + endif + do k=1,o + dpte3(k,j,i)%i2(1+mod(i,5))=i + if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), & + dtarg3(k,j,i)%i2(1+mod(i,5)))) then + ! Error #191 + errors(191) = .true. + endif + + dtarg3(k,j,i)%i2(1+mod(i,5))=2*dpte3(k,j,i)%i2(1+mod(i,5)) + if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), & + dtarg3(k,j,i)%i2(1+mod(i,5)))) then + ! Error #192 + errors(192) = .true. + endif + + ipte3(k,j,i) = i + if (intne(ipte3(k,j,i), itarg3(k,j,i))) then + ! Error #193 + errors(193) = .true. + endif + + itarg3(k,j,i) = -ipte3(k,j,i) + if (intne(ipte3(k,j,i), itarg3(k,j,i))) then + ! Error #194 + errors(194) = .true. + endif + + rpte3(k,j,i) = i * 2.0 + if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then + ! Error #195 + errors(195) = .true. + endif + + rtarg3(k,j,i) = i * 3.0 + if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then + ! Error #196 + errors(196) = .true. + endif + + chpte3(k,j,i) = 'a' + if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then + ! Error #197 + errors(197) = .true. + endif + + chtarg3(k,j,i) = 'z' + if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then + ! Error #198 + errors(198) = .true. + endif + + ch8pte3(k,j,i) = 'aaaaaaaa' + if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then + ! Error #199 + errors(199) = .true. + endif + + ch8targ3(k,j,i) = 'zzzzzzzz' + if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then + ! Error #200 + errors(200) = .true. + endif + end do + end do + end do + +end subroutine ptr6 + +subroutine ptr7 + common /errors/errors(400) + logical :: errors, intne, realne, chne, ch8ne + integer :: i,j,k + integer, parameter :: n = 9 + integer, parameter :: m = 10 + integer, parameter :: o = 11 + integer itarg1 (n) + integer itarg2 (m,n) + integer itarg3 (o,m,n) + real rtarg1(n) + real rtarg2(m,n) + real rtarg3(o,m,n) + character chtarg1(n) + character chtarg2(m,n) + character chtarg3(o,m,n) + character*8 ch8targ1(n) + character*8 ch8targ2(m,n) + character*8 ch8targ3(o,m,n) + type drvd + real r1 + integer i1 + integer i2(5) + end type drvd + type(drvd) dtarg1(n) + type(drvd) dtarg2(m,n) + type(drvd) dtarg3(o,m,n) + + pointer(iptr1,dpte1(*)) + pointer(iptr2,dpte2(m,*)) + pointer(iptr3,dpte3(o,m,*)) + pointer(iptr4,ipte1(*)) + pointer(iptr5,ipte2 (m,*)) + pointer(iptr6,ipte3(o,m,*)) + pointer(iptr7,rpte1(*)) + pointer(iptr8,rpte2(m,*)) + pointer(iptr9,rpte3(o,m,*)) + pointer(iptr10,chpte1(*)) + pointer(iptr11,chpte2(m,*)) + pointer(iptr12,chpte3(o,m,*)) + pointer(iptr13,ch8pte1(*)) + pointer(iptr14,ch8pte2(m,*)) + pointer(iptr15,ch8pte3(o,m,*)) + + type(drvd) dpte1 + type(drvd) dpte2 + type(drvd) dpte3 + integer ipte1 + integer ipte2 + integer ipte3 + real rpte1 + real rpte2 + real rpte3 + character chpte1 + character chpte2 + character chpte3 + character*8 ch8pte1 + character*8 ch8pte2 + character*8 ch8pte3 + + iptr1 = loc(dtarg1) + iptr2 = loc(dtarg2) + iptr3 = loc(dtarg3) + iptr4 = loc(itarg1) + iptr5 = loc(itarg2) + iptr6 = loc(itarg3) + iptr7 = loc(rtarg1) + iptr8 = loc(rtarg2) + iptr9 = loc(rtarg3) + iptr10= loc(chtarg1) + iptr11= loc(chtarg2) + iptr12= loc(chtarg3) + iptr13= loc(ch8targ1) + iptr14= loc(ch8targ2) + iptr15= loc(ch8targ3) + + do, i=1,n + dpte1(i)%i1=i + if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then + ! Error #201 + errors(201) = .true. + endif + + dtarg1(i)%i1=2*dpte1(i)%i1 + if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then + ! Error #202 + errors(202) = .true. + endif + + ipte1(i) = i + if (intne(ipte1(i), itarg1(i))) then + ! Error #203 + errors(203) = .true. + endif + + itarg1(i) = -ipte1(i) + if (intne(ipte1(i), itarg1(i))) then + ! Error #204 + errors(204) = .true. + endif + + rpte1(i) = i * 5.0 + if (realne(rpte1(i), rtarg1(i))) then + ! Error #205 + errors(205) = .true. + endif + + rtarg1(i) = i * (-5.0) + if (realne(rpte1(i), rtarg1(i))) then + ! Error #206 + errors(206) = .true. + endif + + chpte1(i) = 'a' + if (chne(chpte1(i), chtarg1(i))) then + ! Error #207 + errors(207) = .true. + endif + + chtarg1(i) = 'z' + if (chne(chpte1(i), chtarg1(i))) then + ! Error #208 + errors(208) = .true. + endif + + ch8pte1(i) = 'aaaaaaaa' + if (ch8ne(ch8pte1(i), ch8targ1(i))) then + ! Error #209 + errors(209) = .true. + endif + + ch8targ1(i) = 'zzzzzzzz' + if (ch8ne(ch8pte1(i), ch8targ1(i))) then + ! Error #210 + errors(210) = .true. + endif + + do, j=1,m + dpte2(j,i)%r1=1.0 + if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then + ! Error #211 + errors(211) = .true. + endif + + dtarg2(j,i)%r1=2*dpte2(j,i)%r1 + if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then + ! Error #212 + errors(212) = .true. + endif + + ipte2(j,i) = i + if (intne(ipte2(j,i), itarg2(j,i))) then + ! Error #213 + errors(213) = .true. + endif + + itarg2(j,i) = -ipte2(j,i) + if (intne(ipte2(j,i), itarg2(j,i))) then + ! Error #214 + errors(214) = .true. + endif + + rpte2(j,i) = i * (-2.0) + if (realne(rpte2(j,i), rtarg2(j,i))) then + ! Error #215 + errors(215) = .true. + endif + + rtarg2(j,i) = i * (-3.0) + if (realne(rpte2(j,i), rtarg2(j,i))) then + ! Error #216 + errors(216) = .true. + endif + + chpte2(j,i) = 'a' + if (chne(chpte2(j,i), chtarg2(j,i))) then + ! Error #217 + errors(217) = .true. + endif + + chtarg2(j,i) = 'z' + if (chne(chpte2(j,i), chtarg2(j,i))) then + ! Error #218 + errors(218) = .true. + endif + + ch8pte2(j,i) = 'aaaaaaaa' + if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then + ! Error #219 + errors(219) = .true. + endif + + ch8targ2(j,i) = 'zzzzzzzz' + if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then + ! Error #220 + errors(220) = .true. + endif + do k=1,o + dpte3(k,j,i)%i2(1+mod(i,5))=i + if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), & + dtarg3(k,j,i)%i2(1+mod(i,5)))) then + ! Error #221 + errors(221) = .true. + endif + + dtarg3(k,j,i)%i2(1+mod(i,5))=2*dpte3(k,j,i)%i2(1+mod(i,5)) + if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), & + dtarg3(k,j,i)%i2(1+mod(i,5)))) then + ! Error #222 + errors(222) = .true. + endif + + ipte3(k,j,i) = i + if (intne(ipte3(k,j,i), itarg3(k,j,i))) then + ! Error #223 + errors(223) = .true. + endif + + itarg3(k,j,i) = -ipte3(k,j,i) + if (intne(ipte3(k,j,i), itarg3(k,j,i))) then + ! Error #224 + errors(224) = .true. + endif + + rpte3(k,j,i) = i * 2.0 + if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then + ! Error #225 + errors(225) = .true. + endif + + rtarg3(k,j,i) = i * 3.0 + if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then + ! Error #226 + errors(226) = .true. + endif + + chpte3(k,j,i) = 'a' + if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then + ! Error #227 + errors(227) = .true. + endif + + chtarg3(k,j,i) = 'z' + if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then + ! Error #228 + errors(228) = .true. + endif + + ch8pte3(k,j,i) = 'aaaaaaaa' + if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then + ! Error #229 + errors(229) = .true. + endif + + ch8targ3(k,j,i) = 'zzzzzzzz' + if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then + ! Error #230 + errors(230) = .true. + endif + end do + end do + end do + +end subroutine ptr7 + +subroutine ptr8 + common /errors/errors(400) + logical :: errors, intne, realne, chne, ch8ne + integer :: i,j,k + integer, parameter :: n = 9 + integer, parameter :: m = 10 + integer, parameter :: o = 11 + integer itarg1 (n) + integer itarg2 (m,n) + integer itarg3 (o,m,n) + real rtarg1(n) + real rtarg2(m,n) + real rtarg3(o,m,n) + character chtarg1(n) + character chtarg2(m,n) + character chtarg3(o,m,n) + character*8 ch8targ1(n) + character*8 ch8targ2(m,n) + character*8 ch8targ3(o,m,n) + type drvd + real r1 + integer i1 + integer i2(5) + end type drvd + type(drvd) dtarg1(n) + type(drvd) dtarg2(m,n) + type(drvd) dtarg3(o,m,n) + + pointer(iptr1,dpte1) + pointer(iptr2,dpte2) + pointer(iptr3,dpte3) + pointer(iptr4,ipte1) + pointer(iptr5,ipte2) + pointer(iptr6,ipte3) + pointer(iptr7,rpte1) + pointer(iptr8,rpte2) + pointer(iptr9,rpte3) + pointer(iptr10,chpte1) + pointer(iptr11,chpte2) + pointer(iptr12,chpte3) + pointer(iptr13,ch8pte1) + pointer(iptr14,ch8pte2) + pointer(iptr15,ch8pte3) + + type(drvd) dpte1(*) + type(drvd) dpte2(m,*) + type(drvd) dpte3(o,m,*) + integer ipte1 (*) + integer ipte2 (m,*) + integer ipte3 (o,m,*) + real rpte1(*) + real rpte2(m,*) + real rpte3(o,m,*) + character chpte1(*) + character chpte2(m,*) + character chpte3(o,m,*) + character*8 ch8pte1(*) + character*8 ch8pte2(m,*) + character*8 ch8pte3(o,m,*) + + iptr1 = loc(dtarg1) + iptr2 = loc(dtarg2) + iptr3 = loc(dtarg3) + iptr4 = loc(itarg1) + iptr5 = loc(itarg2) + iptr6 = loc(itarg3) + iptr7 = loc(rtarg1) + iptr8 = loc(rtarg2) + iptr9 = loc(rtarg3) + iptr10= loc(chtarg1) + iptr11= loc(chtarg2) + iptr12= loc(chtarg3) + iptr13= loc(ch8targ1) + iptr14= loc(ch8targ2) + iptr15= loc(ch8targ3) + + + do, i=1,n + dpte1(i)%i1=i + if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then + ! Error #231 + errors(231) = .true. + endif + + dtarg1(i)%i1=2*dpte1(i)%i1 + if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then + ! Error #232 + errors(232) = .true. + endif + + ipte1(i) = i + if (intne(ipte1(i), itarg1(i))) then + ! Error #233 + errors(233) = .true. + endif + + itarg1(i) = -ipte1(i) + if (intne(ipte1(i), itarg1(i))) then + ! Error #234 + errors(234) = .true. + endif + + rpte1(i) = i * 5.0 + if (realne(rpte1(i), rtarg1(i))) then + ! Error #235 + errors(235) = .true. + endif + + rtarg1(i) = i * (-5.0) + if (realne(rpte1(i), rtarg1(i))) then + ! Error #236 + errors(236) = .true. + endif + + chpte1(i) = 'a' + if (chne(chpte1(i), chtarg1(i))) then + ! Error #237 + errors(237) = .true. + endif + + chtarg1(i) = 'z' + if (chne(chpte1(i), chtarg1(i))) then + ! Error #238 + errors(238) = .true. + endif + + ch8pte1(i) = 'aaaaaaaa' + if (ch8ne(ch8pte1(i), ch8targ1(i))) then + ! Error #239 + errors(239) = .true. + endif + + ch8targ1(i) = 'zzzzzzzz' + if (ch8ne(ch8pte1(i), ch8targ1(i))) then + ! Error #240 + errors(240) = .true. + endif + + do, j=1,m + dpte2(j,i)%r1=1.0 + if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then + ! Error #241 + errors(241) = .true. + endif + + dtarg2(j,i)%r1=2*dpte2(j,i)%r1 + if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then + ! Error #242 + errors(242) = .true. + endif + + ipte2(j,i) = i + if (intne(ipte2(j,i), itarg2(j,i))) then + ! Error #243 + errors(243) = .true. + endif + + itarg2(j,i) = -ipte2(j,i) + if (intne(ipte2(j,i), itarg2(j,i))) then + ! Error #244 + errors(244) = .true. + endif + + rpte2(j,i) = i * (-2.0) + if (realne(rpte2(j,i), rtarg2(j,i))) then + ! Error #245 + errors(245) = .true. + endif + + rtarg2(j,i) = i * (-3.0) + if (realne(rpte2(j,i), rtarg2(j,i))) then + ! Error #246 + errors(246) = .true. + endif + + chpte2(j,i) = 'a' + if (chne(chpte2(j,i), chtarg2(j,i))) then + ! Error #247 + errors(247) = .true. + endif + + chtarg2(j,i) = 'z' + if (chne(chpte2(j,i), chtarg2(j,i))) then + ! Error #248 + errors(248) = .true. + endif + + ch8pte2(j,i) = 'aaaaaaaa' + if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then + ! Error #249 + errors(249) = .true. + endif + + ch8targ2(j,i) = 'zzzzzzzz' + if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then + ! Error #250 + errors(250) = .true. + endif + do k=1,o + dpte3(k,j,i)%i2(1+mod(i,5))=i + if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), & + dtarg3(k,j,i)%i2(1+mod(i,5)))) then + ! Error #251 + errors(251) = .true. + endif + + dtarg3(k,j,i)%i2(1+mod(i,5))=2*dpte3(k,j,i)%i2(1+mod(i,5)) + if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), & + dtarg3(k,j,i)%i2(1+mod(i,5)))) then + ! Error #252 + errors(252) = .true. + endif + + ipte3(k,j,i) = i + if (intne(ipte3(k,j,i), itarg3(k,j,i))) then + ! Error #253 + errors(253) = .true. + endif + + itarg3(k,j,i) = -ipte3(k,j,i) + if (intne(ipte3(k,j,i), itarg3(k,j,i))) then + ! Error #254 + errors(254) = .true. + endif + + rpte3(k,j,i) = i * 2.0 + if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then + ! Error #255 + errors(255) = .true. + endif + + rtarg3(k,j,i) = i * 3.0 + if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then + ! Error #256 + errors(256) = .true. + endif + + chpte3(k,j,i) = 'a' + if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then + ! Error #257 + errors(257) = .true. + endif + + chtarg3(k,j,i) = 'z' + if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then + ! Error #258 + errors(258) = .true. + endif + + ch8pte3(k,j,i) = 'aaaaaaaa' + if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then + ! Error #259 + errors(259) = .true. + endif + + ch8targ3(k,j,i) = 'zzzzzzzz' + if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then + ! Error #260 + errors(260) = .true. + endif + end do + end do + end do +end subroutine ptr8 + + +subroutine ptr9(nnn,mmm,ooo) + common /errors/errors(400) + logical :: errors, intne, realne, chne, ch8ne + integer :: i,j,k + integer :: nnn,mmm,ooo + integer, parameter :: n = 9 + integer, parameter :: m = 10 + integer, parameter :: o = 11 + integer itarg1 (n) + integer itarg2 (m,n) + integer itarg3 (o,m,n) + real rtarg1(n) + real rtarg2(m,n) + real rtarg3(o,m,n) + character chtarg1(n) + character chtarg2(m,n) + character chtarg3(o,m,n) + character*8 ch8targ1(n) + character*8 ch8targ2(m,n) + character*8 ch8targ3(o,m,n) + type drvd + real r1 + integer i1 + integer i2(5) + end type drvd + type(drvd) dtarg1(n) + type(drvd) dtarg2(m,n) + type(drvd) dtarg3(o,m,n) + + type(drvd) dpte1(nnn) + type(drvd) dpte2(mmm,nnn) + type(drvd) dpte3(ooo,mmm,nnn) + integer ipte1 (nnn) + integer ipte2 (mmm,nnn) + integer ipte3 (ooo,mmm,nnn) + real rpte1(nnn) + real rpte2(mmm,nnn) + real rpte3(ooo,mmm,nnn) + character chpte1(nnn) + character chpte2(mmm,nnn) + character chpte3(ooo,mmm,nnn) + character*8 ch8pte1(nnn) + character*8 ch8pte2(mmm,nnn) + character*8 ch8pte3(ooo,mmm,nnn) + + pointer(iptr1,dpte1) + pointer(iptr2,dpte2) + pointer(iptr3,dpte3) + pointer(iptr4,ipte1) + pointer(iptr5,ipte2) + pointer(iptr6,ipte3) + pointer(iptr7,rpte1) + pointer(iptr8,rpte2) + pointer(iptr9,rpte3) + pointer(iptr10,chpte1) + pointer(iptr11,chpte2) + pointer(iptr12,chpte3) + pointer(iptr13,ch8pte1) + pointer(iptr14,ch8pte2) + pointer(iptr15,ch8pte3) + + iptr1 = loc(dtarg1) + iptr2 = loc(dtarg2) + iptr3 = loc(dtarg3) + iptr4 = loc(itarg1) + iptr5 = loc(itarg2) + iptr6 = loc(itarg3) + iptr7 = loc(rtarg1) + iptr8 = loc(rtarg2) + iptr9 = loc(rtarg3) + iptr10= loc(chtarg1) + iptr11= loc(chtarg2) + iptr12= loc(chtarg3) + iptr13= loc(ch8targ1) + iptr14= loc(ch8targ2) + iptr15= loc(ch8targ3) + + + do, i=1,n + dpte1(i)%i1=i + if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then + ! Error #261 + errors(261) = .true. + endif + + dtarg1(i)%i1=2*dpte1(i)%i1 + if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then + ! Error #262 + errors(262) = .true. + endif + + ipte1(i) = i + if (intne(ipte1(i), itarg1(i))) then + ! Error #263 + errors(263) = .true. + endif + + itarg1(i) = -ipte1(i) + if (intne(ipte1(i), itarg1(i))) then + ! Error #264 + errors(264) = .true. + endif + + rpte1(i) = i * 5.0 + if (realne(rpte1(i), rtarg1(i))) then + ! Error #265 + errors(265) = .true. + endif + + rtarg1(i) = i * (-5.0) + if (realne(rpte1(i), rtarg1(i))) then + ! Error #266 + errors(266) = .true. + endif + + chpte1(i) = 'a' + if (chne(chpte1(i), chtarg1(i))) then + ! Error #267 + errors(267) = .true. + endif + + chtarg1(i) = 'z' + if (chne(chpte1(i), chtarg1(i))) then + ! Error #268 + errors(268) = .true. + endif + + ch8pte1(i) = 'aaaaaaaa' + if (ch8ne(ch8pte1(i), ch8targ1(i))) then + ! Error #269 + errors(269) = .true. + endif + + ch8targ1(i) = 'zzzzzzzz' + if (ch8ne(ch8pte1(i), ch8targ1(i))) then + ! Error #270 + errors(270) = .true. + endif + + do, j=1,m + dpte2(j,i)%r1=1.0 + if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then + ! Error #271 + errors(271) = .true. + endif + + dtarg2(j,i)%r1=2*dpte2(j,i)%r1 + if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then + ! Error #272 + errors(272) = .true. + endif + + ipte2(j,i) = i + if (intne(ipte2(j,i), itarg2(j,i))) then + ! Error #273 + errors(273) = .true. + endif + + itarg2(j,i) = -ipte2(j,i) + if (intne(ipte2(j,i), itarg2(j,i))) then + ! Error #274 + errors(274) = .true. + endif + + rpte2(j,i) = i * (-2.0) + if (realne(rpte2(j,i), rtarg2(j,i))) then + ! Error #275 + errors(275) = .true. + endif + + rtarg2(j,i) = i * (-3.0) + if (realne(rpte2(j,i), rtarg2(j,i))) then + ! Error #276 + errors(276) = .true. + endif + + chpte2(j,i) = 'a' + if (chne(chpte2(j,i), chtarg2(j,i))) then + ! Error #277 + errors(277) = .true. + endif + + chtarg2(j,i) = 'z' + if (chne(chpte2(j,i), chtarg2(j,i))) then + ! Error #278 + errors(278) = .true. + endif + + ch8pte2(j,i) = 'aaaaaaaa' + if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then + ! Error #279 + errors(279) = .true. + endif + + ch8targ2(j,i) = 'zzzzzzzz' + if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then + ! Error #280 + errors(280) = .true. + endif + do k=1,o + dpte3(k,j,i)%i2(1+mod(i,5))=i + if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), & + dtarg3(k,j,i)%i2(1+mod(i,5)))) then + ! Error #281 + errors(281) = .true. + endif + + dtarg3(k,j,i)%i2(1+mod(i,5))=2*dpte3(k,j,i)%i2(1+mod(i,5)) + if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), & + dtarg3(k,j,i)%i2(1+mod(i,5)))) then + ! Error #282 + errors(282) = .true. + endif + + ipte3(k,j,i) = i + if (intne(ipte3(k,j,i), itarg3(k,j,i))) then + ! Error #283 + errors(283) = .true. + endif + + itarg3(k,j,i) = -ipte3(k,j,i) + if (intne(ipte3(k,j,i), itarg3(k,j,i))) then + ! Error #284 + errors(284) = .true. + endif + + rpte3(k,j,i) = i * 2.0 + if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then + ! Error #285 + errors(285) = .true. + endif + + rtarg3(k,j,i) = i * 3.0 + if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then + ! Error #286 + errors(286) = .true. + endif + + chpte3(k,j,i) = 'a' + if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then + ! Error #287 + errors(287) = .true. + endif + + chtarg3(k,j,i) = 'z' + if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then + ! Error #288 + errors(288) = .true. + endif + + ch8pte3(k,j,i) = 'aaaaaaaa' + if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then + ! Error #289 + errors(289) = .true. + endif + + ch8targ3(k,j,i) = 'zzzzzzzz' + if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then + ! Error #290 + errors(290) = .true. + endif + end do + end do + end do + + rtarg3 = .5 + ! Vector syntax + do, i=1,n + ipte3 = i + rpte3 = rpte3+1 + do, j=1,m + do k=1,o + if (intne(itarg3(k,j,i), i)) then + ! Error #291 + errors(291) = .true. + endif + + if (realne(rtarg3(k,j,i), i+.5)) then + ! Error #292 + errors(292) = .true. + endif + end do + end do + end do + +end subroutine ptr9 + +subroutine ptr10(nnn,mmm,ooo) + common /errors/errors(400) + logical :: errors, intne, realne, chne, ch8ne + integer :: i,j,k + integer :: nnn,mmm,ooo + integer, parameter :: n = 9 + integer, parameter :: m = 10 + integer, parameter :: o = 11 + integer itarg1 (n) + integer itarg2 (m,n) + integer itarg3 (o,m,n) + real rtarg1(n) + real rtarg2(m,n) + real rtarg3(o,m,n) + character chtarg1(n) + character chtarg2(m,n) + character chtarg3(o,m,n) + character*8 ch8targ1(n) + character*8 ch8targ2(m,n) + character*8 ch8targ3(o,m,n) + type drvd + real r1 + integer i1 + integer i2(5) + end type drvd + type(drvd) dtarg1(n) + type(drvd) dtarg2(m,n) + type(drvd) dtarg3(o,m,n) + + type(drvd) dpte1 + type(drvd) dpte2 + type(drvd) dpte3 + integer ipte1 + integer ipte2 + integer ipte3 + real rpte1 + real rpte2 + real rpte3 + character chpte1 + character chpte2 + character chpte3 + character*8 ch8pte1 + character*8 ch8pte2 + character*8 ch8pte3 + + pointer(iptr1,dpte1(nnn)) + pointer(iptr2,dpte2(mmm,nnn)) + pointer(iptr3,dpte3(ooo,mmm,nnn)) + pointer(iptr4,ipte1(nnn)) + pointer(iptr5,ipte2 (mmm,nnn)) + pointer(iptr6,ipte3(ooo,mmm,nnn)) + pointer(iptr7,rpte1(nnn)) + pointer(iptr8,rpte2(mmm,nnn)) + pointer(iptr9,rpte3(ooo,mmm,nnn)) + pointer(iptr10,chpte1(nnn)) + pointer(iptr11,chpte2(mmm,nnn)) + pointer(iptr12,chpte3(ooo,mmm,nnn)) + pointer(iptr13,ch8pte1(nnn)) + pointer(iptr14,ch8pte2(mmm,nnn)) + pointer(iptr15,ch8pte3(ooo,mmm,nnn)) + + iptr1 = loc(dtarg1) + iptr2 = loc(dtarg2) + iptr3 = loc(dtarg3) + iptr4 = loc(itarg1) + iptr5 = loc(itarg2) + iptr6 = loc(itarg3) + iptr7 = loc(rtarg1) + iptr8 = loc(rtarg2) + iptr9 = loc(rtarg3) + iptr10= loc(chtarg1) + iptr11= loc(chtarg2) + iptr12= loc(chtarg3) + iptr13= loc(ch8targ1) + iptr14= loc(ch8targ2) + iptr15= loc(ch8targ3) + + do, i=1,n + dpte1(i)%i1=i + if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then + ! Error #293 + errors(293) = .true. + endif + + dtarg1(i)%i1=2*dpte1(i)%i1 + if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then + ! Error #294 + errors(294) = .true. + endif + + ipte1(i) = i + if (intne(ipte1(i), itarg1(i))) then + ! Error #295 + errors(295) = .true. + endif + + itarg1(i) = -ipte1(i) + if (intne(ipte1(i), itarg1(i))) then + ! Error #296 + errors(296) = .true. + endif + + rpte1(i) = i * 5.0 + if (realne(rpte1(i), rtarg1(i))) then + ! Error #297 + errors(297) = .true. + endif + + rtarg1(i) = i * (-5.0) + if (realne(rpte1(i), rtarg1(i))) then + ! Error #298 + errors(298) = .true. + endif + + chpte1(i) = 'a' + if (chne(chpte1(i), chtarg1(i))) then + ! Error #299 + errors(299) = .true. + endif + + chtarg1(i) = 'z' + if (chne(chpte1(i), chtarg1(i))) then + ! Error #300 + errors(300) = .true. + endif + + ch8pte1(i) = 'aaaaaaaa' + if (ch8ne(ch8pte1(i), ch8targ1(i))) then + ! Error #301 + errors(301) = .true. + endif + + ch8targ1(i) = 'zzzzzzzz' + if (ch8ne(ch8pte1(i), ch8targ1(i))) then + ! Error #302 + errors(302) = .true. + endif + + do, j=1,m + dpte2(j,i)%r1=1.0 + if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then + ! Error #303 + errors(303) = .true. + endif + + dtarg2(j,i)%r1=2*dpte2(j,i)%r1 + if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then + ! Error #304 + errors(304) = .true. + endif + + ipte2(j,i) = i + if (intne(ipte2(j,i), itarg2(j,i))) then + ! Error #305 + errors(305) = .true. + endif + + itarg2(j,i) = -ipte2(j,i) + if (intne(ipte2(j,i), itarg2(j,i))) then + ! Error #306 + errors(306) = .true. + endif + + rpte2(j,i) = i * (-2.0) + if (realne(rpte2(j,i), rtarg2(j,i))) then + ! Error #307 + errors(307) = .true. + endif + + rtarg2(j,i) = i * (-3.0) + if (realne(rpte2(j,i), rtarg2(j,i))) then + ! Error #308 + errors(308) = .true. + endif + + chpte2(j,i) = 'a' + if (chne(chpte2(j,i), chtarg2(j,i))) then + ! Error #309 + errors(309) = .true. + endif + + chtarg2(j,i) = 'z' + if (chne(chpte2(j,i), chtarg2(j,i))) then + ! Error #310 + errors(310) = .true. + endif + + ch8pte2(j,i) = 'aaaaaaaa' + if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then + ! Error #311 + errors(311) = .true. + endif + + ch8targ2(j,i) = 'zzzzzzzz' + if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then + ! Error #312 + errors(312) = .true. + endif + do k=1,o + dpte3(k,j,i)%i2(1+mod(i,5))=i + if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), & + dtarg3(k,j,i)%i2(1+mod(i,5)))) then + ! Error #313 + errors(313) = .true. + endif + + dtarg3(k,j,i)%i2(1+mod(i,5))=2*dpte3(k,j,i)%i2(1+mod(i,5)) + if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), & + dtarg3(k,j,i)%i2(1+mod(i,5)))) then + ! Error #314 + errors(314) = .true. + endif + + ipte3(k,j,i) = i + if (intne(ipte3(k,j,i), itarg3(k,j,i))) then + ! Error #315 + errors(315) = .true. + endif + + itarg3(k,j,i) = -ipte3(k,j,i) + if (intne(ipte3(k,j,i), itarg3(k,j,i))) then + ! Error #316 + errors(316) = .true. + endif + + rpte3(k,j,i) = i * 2.0 + if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then + ! Error #317 + errors(317) = .true. + endif + + rtarg3(k,j,i) = i * 3.0 + if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then + ! Error #318 + errors(318) = .true. + endif + + chpte3(k,j,i) = 'a' + if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then + ! Error #319 + errors(319) = .true. + endif + + chtarg3(k,j,i) = 'z' + if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then + ! Error #320 + errors(320) = .true. + endif + + ch8pte3(k,j,i) = 'aaaaaaaa' + if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then + ! Error #321 + errors(321) = .true. + endif + + ch8targ3(k,j,i) = 'zzzzzzzz' + if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then + ! Error #322 + errors(322) = .true. + endif + end do + end do + end do + + rtarg3 = .5 + ! Vector syntax + do, i=1,n + ipte3 = i + rpte3 = rpte3+1 + do, j=1,m + do k=1,o + if (intne(itarg3(k,j,i), i)) then + ! Error #323 + errors(323) = .true. + endif + + if (realne(rtarg3(k,j,i), i+.5)) then + ! Error #324 + errors(324) = .true. + endif + end do + end do + end do +end subroutine ptr10 + +subroutine ptr11(nnn,mmm,ooo) + common /errors/errors(400) + logical :: errors, intne, realne, chne, ch8ne + integer :: i,j,k + integer :: nnn,mmm,ooo + integer, parameter :: n = 9 + integer, parameter :: m = 10 + integer, parameter :: o = 11 + integer itarg1 (n) + integer itarg2 (m,n) + integer itarg3 (o,m,n) + real rtarg1(n) + real rtarg2(m,n) + real rtarg3(o,m,n) + character chtarg1(n) + character chtarg2(m,n) + character chtarg3(o,m,n) + character*8 ch8targ1(n) + character*8 ch8targ2(m,n) + character*8 ch8targ3(o,m,n) + type drvd + real r1 + integer i1 + integer i2(5) + end type drvd + type(drvd) dtarg1(n) + type(drvd) dtarg2(m,n) + type(drvd) dtarg3(o,m,n) + + pointer(iptr1,dpte1(nnn)) + pointer(iptr2,dpte2(mmm,nnn)) + pointer(iptr3,dpte3(ooo,mmm,nnn)) + pointer(iptr4,ipte1(nnn)) + pointer(iptr5,ipte2 (mmm,nnn)) + pointer(iptr6,ipte3(ooo,mmm,nnn)) + pointer(iptr7,rpte1(nnn)) + pointer(iptr8,rpte2(mmm,nnn)) + pointer(iptr9,rpte3(ooo,mmm,nnn)) + pointer(iptr10,chpte1(nnn)) + pointer(iptr11,chpte2(mmm,nnn)) + pointer(iptr12,chpte3(ooo,mmm,nnn)) + pointer(iptr13,ch8pte1(nnn)) + pointer(iptr14,ch8pte2(mmm,nnn)) + pointer(iptr15,ch8pte3(ooo,mmm,nnn)) + + type(drvd) dpte1 + type(drvd) dpte2 + type(drvd) dpte3 + integer ipte1 + integer ipte2 + integer ipte3 + real rpte1 + real rpte2 + real rpte3 + character chpte1 + character chpte2 + character chpte3 + character*8 ch8pte1 + character*8 ch8pte2 + character*8 ch8pte3 + + iptr1 = loc(dtarg1) + iptr2 = loc(dtarg2) + iptr3 = loc(dtarg3) + iptr4 = loc(itarg1) + iptr5 = loc(itarg2) + iptr6 = loc(itarg3) + iptr7 = loc(rtarg1) + iptr8 = loc(rtarg2) + iptr9 = loc(rtarg3) + iptr10= loc(chtarg1) + iptr11= loc(chtarg2) + iptr12= loc(chtarg3) + iptr13= loc(ch8targ1) + iptr14= loc(ch8targ2) + iptr15= loc(ch8targ3) + + do, i=1,n + dpte1(i)%i1=i + if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then + ! Error #325 + errors(325) = .true. + endif + + dtarg1(i)%i1=2*dpte1(i)%i1 + if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then + ! Error #326 + errors(326) = .true. + endif + + ipte1(i) = i + if (intne(ipte1(i), itarg1(i))) then + ! Error #327 + errors(327) = .true. + endif + + itarg1(i) = -ipte1(i) + if (intne(ipte1(i), itarg1(i))) then + ! Error #328 + errors(328) = .true. + endif + + rpte1(i) = i * 5.0 + if (realne(rpte1(i), rtarg1(i))) then + ! Error #329 + errors(329) = .true. + endif + + rtarg1(i) = i * (-5.0) + if (realne(rpte1(i), rtarg1(i))) then + ! Error #330 + errors(330) = .true. + endif + + chpte1(i) = 'a' + if (chne(chpte1(i), chtarg1(i))) then + ! Error #331 + errors(331) = .true. + endif + + chtarg1(i) = 'z' + if (chne(chpte1(i), chtarg1(i))) then + ! Error #332 + errors(332) = .true. + endif + + ch8pte1(i) = 'aaaaaaaa' + if (ch8ne(ch8pte1(i), ch8targ1(i))) then + ! Error #333 + errors(333) = .true. + endif + + ch8targ1(i) = 'zzzzzzzz' + if (ch8ne(ch8pte1(i), ch8targ1(i))) then + ! Error #334 + errors(334) = .true. + endif + + do, j=1,m + dpte2(j,i)%r1=1.0 + if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then + ! Error #335 + errors(335) = .true. + endif + + dtarg2(j,i)%r1=2*dpte2(j,i)%r1 + if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then + ! Error #336 + errors(336) = .true. + endif + + ipte2(j,i) = i + if (intne(ipte2(j,i), itarg2(j,i))) then + ! Error #337 + errors(337) = .true. + endif + + itarg2(j,i) = -ipte2(j,i) + if (intne(ipte2(j,i), itarg2(j,i))) then + ! Error #338 + errors(338) = .true. + endif + + rpte2(j,i) = i * (-2.0) + if (realne(rpte2(j,i), rtarg2(j,i))) then + ! Error #339 + errors(339) = .true. + endif + + rtarg2(j,i) = i * (-3.0) + if (realne(rpte2(j,i), rtarg2(j,i))) then + ! Error #340 + errors(340) = .true. + endif + + chpte2(j,i) = 'a' + if (chne(chpte2(j,i), chtarg2(j,i))) then + ! Error #341 + errors(341) = .true. + endif + + chtarg2(j,i) = 'z' + if (chne(chpte2(j,i), chtarg2(j,i))) then + ! Error #342 + errors(342) = .true. + endif + + ch8pte2(j,i) = 'aaaaaaaa' + if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then + ! Error #343 + errors(343) = .true. + endif + + ch8targ2(j,i) = 'zzzzzzzz' + if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then + ! Error #344 + errors(344) = .true. + endif + do k=1,o + dpte3(k,j,i)%i2(1+mod(i,5))=i + if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), & + dtarg3(k,j,i)%i2(1+mod(i,5)))) then + ! Error #345 + errors(345) = .true. + endif + + dtarg3(k,j,i)%i2(1+mod(i,5))=2*dpte3(k,j,i)%i2(1+mod(i,5)) + if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), & + dtarg3(k,j,i)%i2(1+mod(i,5)))) then + ! Error #346 + errors(346) = .true. + endif + + ipte3(k,j,i) = i + if (intne(ipte3(k,j,i), itarg3(k,j,i))) then + ! Error #347 + errors(347) = .true. + endif + + itarg3(k,j,i) = -ipte3(k,j,i) + if (intne(ipte3(k,j,i), itarg3(k,j,i))) then + ! Error #348 + errors(348) = .true. + endif + + rpte3(k,j,i) = i * 2.0 + if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then + ! Error #349 + errors(349) = .true. + endif + + rtarg3(k,j,i) = i * 3.0 + if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then + ! Error #350 + errors(350) = .true. + endif + + chpte3(k,j,i) = 'a' + if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then + ! Error #351 + errors(351) = .true. + endif + + chtarg3(k,j,i) = 'z' + if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then + ! Error #352 + errors(352) = .true. + endif + + ch8pte3(k,j,i) = 'aaaaaaaa' + if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then + ! Error #353 + errors(353) = .true. + endif + + ch8targ3(k,j,i) = 'zzzzzzzz' + if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then + ! Error #354 + errors(354) = .true. + endif + end do + end do + end do + + rtarg3 = .5 + ! Vector syntax + do, i=1,n + ipte3 = i + rpte3 = rpte3+1 + do, j=1,m + do k=1,o + if (intne(itarg3(k,j,i), i)) then + ! Error #355 + errors(355) = .true. + endif + + if (realne(rtarg3(k,j,i), i+.5)) then + ! Error #356 + errors(356) = .true. + endif + end do + end do + end do +end subroutine ptr11 + +subroutine ptr12(nnn,mmm,ooo) + common /errors/errors(400) + logical :: errors, intne, realne, chne, ch8ne + integer :: i,j,k + integer :: nnn,mmm,ooo + integer, parameter :: n = 9 + integer, parameter :: m = 10 + integer, parameter :: o = 11 + integer itarg1 (n) + integer itarg2 (m,n) + integer itarg3 (o,m,n) + real rtarg1(n) + real rtarg2(m,n) + real rtarg3(o,m,n) + character chtarg1(n) + character chtarg2(m,n) + character chtarg3(o,m,n) + character*8 ch8targ1(n) + character*8 ch8targ2(m,n) + character*8 ch8targ3(o,m,n) + type drvd + real r1 + integer i1 + integer i2(5) + end type drvd + type(drvd) dtarg1(n) + type(drvd) dtarg2(m,n) + type(drvd) dtarg3(o,m,n) + + pointer(iptr1,dpte1) + pointer(iptr2,dpte2) + pointer(iptr3,dpte3) + pointer(iptr4,ipte1) + pointer(iptr5,ipte2) + pointer(iptr6,ipte3) + pointer(iptr7,rpte1) + pointer(iptr8,rpte2) + pointer(iptr9,rpte3) + pointer(iptr10,chpte1) + pointer(iptr11,chpte2) + pointer(iptr12,chpte3) + pointer(iptr13,ch8pte1) + pointer(iptr14,ch8pte2) + pointer(iptr15,ch8pte3) + + type(drvd) dpte1(nnn) + type(drvd) dpte2(mmm,nnn) + type(drvd) dpte3(ooo,mmm,nnn) + integer ipte1 (nnn) + integer ipte2 (mmm,nnn) + integer ipte3 (ooo,mmm,nnn) + real rpte1(nnn) + real rpte2(mmm,nnn) + real rpte3(ooo,mmm,nnn) + character chpte1(nnn) + character chpte2(mmm,nnn) + character chpte3(ooo,mmm,nnn) + character*8 ch8pte1(nnn) + character*8 ch8pte2(mmm,nnn) + character*8 ch8pte3(ooo,mmm,nnn) + + iptr1 = loc(dtarg1) + iptr2 = loc(dtarg2) + iptr3 = loc(dtarg3) + iptr4 = loc(itarg1) + iptr5 = loc(itarg2) + iptr6 = loc(itarg3) + iptr7 = loc(rtarg1) + iptr8 = loc(rtarg2) + iptr9 = loc(rtarg3) + iptr10= loc(chtarg1) + iptr11= loc(chtarg2) + iptr12= loc(chtarg3) + iptr13= loc(ch8targ1) + iptr14= loc(ch8targ2) + iptr15= loc(ch8targ3) + + + do, i=1,n + dpte1(i)%i1=i + if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then + ! Error #357 + errors(357) = .true. + endif + + dtarg1(i)%i1=2*dpte1(i)%i1 + if (intne(dpte1(i)%i1, dtarg1(i)%i1)) then + ! Error #358 + errors(358) = .true. + endif + + ipte1(i) = i + if (intne(ipte1(i), itarg1(i))) then + ! Error #359 + errors(359) = .true. + endif + + itarg1(i) = -ipte1(i) + if (intne(ipte1(i), itarg1(i))) then + ! Error #360 + errors(360) = .true. + endif + + rpte1(i) = i * 5.0 + if (realne(rpte1(i), rtarg1(i))) then + ! Error #361 + errors(361) = .true. + endif + + rtarg1(i) = i * (-5.0) + if (realne(rpte1(i), rtarg1(i))) then + ! Error #362 + errors(362) = .true. + endif + + chpte1(i) = 'a' + if (chne(chpte1(i), chtarg1(i))) then + ! Error #363 + errors(363) = .true. + endif + + chtarg1(i) = 'z' + if (chne(chpte1(i), chtarg1(i))) then + ! Error #364 + errors(364) = .true. + endif + + ch8pte1(i) = 'aaaaaaaa' + if (ch8ne(ch8pte1(i), ch8targ1(i))) then + ! Error #365 + errors(365) = .true. + endif + + ch8targ1(i) = 'zzzzzzzz' + if (ch8ne(ch8pte1(i), ch8targ1(i))) then + ! Error #366 + errors(366) = .true. + endif + + do, j=1,m + dpte2(j,i)%r1=1.0 + if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then + ! Error #367 + errors(367) = .true. + endif + + dtarg2(j,i)%r1=2*dpte2(j,i)%r1 + if (realne(dpte2(j,i)%r1, dtarg2(j,i)%r1)) then + ! Error #368 + errors(368) = .true. + endif + + ipte2(j,i) = i + if (intne(ipte2(j,i), itarg2(j,i))) then + ! Error #369 + errors(369) = .true. + endif + + itarg2(j,i) = -ipte2(j,i) + if (intne(ipte2(j,i), itarg2(j,i))) then + ! Error #370 + errors(370) = .true. + endif + + rpte2(j,i) = i * (-2.0) + if (realne(rpte2(j,i), rtarg2(j,i))) then + ! Error #371 + errors(371) = .true. + endif + + rtarg2(j,i) = i * (-3.0) + if (realne(rpte2(j,i), rtarg2(j,i))) then + ! Error #372 + errors(372) = .true. + endif + + chpte2(j,i) = 'a' + if (chne(chpte2(j,i), chtarg2(j,i))) then + ! Error #373 + errors(373) = .true. + endif + + chtarg2(j,i) = 'z' + if (chne(chpte2(j,i), chtarg2(j,i))) then + ! Error #374 + errors(374) = .true. + endif + + ch8pte2(j,i) = 'aaaaaaaa' + if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then + ! Error #375 + errors(375) = .true. + endif + + ch8targ2(j,i) = 'zzzzzzzz' + if (ch8ne(ch8pte2(j,i), ch8targ2(j,i))) then + ! Error #376 + errors(376) = .true. + endif + do k=1,o + dpte3(k,j,i)%i2(1+mod(i,5))=i + if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), & + dtarg3(k,j,i)%i2(1+mod(i,5)))) then + ! Error #377 + errors(377) = .true. + endif + + dtarg3(k,j,i)%i2(1+mod(i,5))=2*dpte3(k,j,i)%i2(1+mod(i,5)) + if (intne(dpte3(k,j,i)%i2(1+mod(i,5)), & + dtarg3(k,j,i)%i2(1+mod(i,5)))) then + ! Error #378 + errors(378) = .true. + endif + + ipte3(k,j,i) = i + if (intne(ipte3(k,j,i), itarg3(k,j,i))) then + ! Error #379 + errors(379) = .true. + endif + + itarg3(k,j,i) = -ipte3(k,j,i) + if (intne(ipte3(k,j,i), itarg3(k,j,i))) then + ! Error #380 + errors(380) = .true. + endif + + rpte3(k,j,i) = i * 2.0 + if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then + ! Error #381 + errors(381) = .true. + endif + + rtarg3(k,j,i) = i * 3.0 + if (realne(rpte3(k,j,i), rtarg3(k,j,i))) then + ! Error #382 + errors(382) = .true. + endif + + chpte3(k,j,i) = 'a' + if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then + ! Error #383 + errors(383) = .true. + endif + + chtarg3(k,j,i) = 'z' + if (chne(chpte3(k,j,i), chtarg3(k,j,i))) then + ! Error #384 + errors(384) = .true. + endif + + ch8pte3(k,j,i) = 'aaaaaaaa' + if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then + ! Error #385 + errors(385) = .true. + endif + + ch8targ3(k,j,i) = 'zzzzzzzz' + if (ch8ne(ch8pte3(k,j,i), ch8targ3(k,j,i))) then + ! Error #386 + errors(386) = .true. + endif + end do + end do + end do + + rtarg3 = .5 + ! Vector syntax + do, i=1,n + ipte3 = i + rpte3 = rpte3+1 + do, j=1,m + do k=1,o + if (intne(itarg3(k,j,i), i)) then + ! Error #387 + errors(387) = .true. + endif + + if (realne(rtarg3(k,j,i), i+.5)) then + ! Error #388 + errors(388) = .true. + endif + end do + end do + end do + +end subroutine ptr12 + +! Misc +subroutine ptr13(nnn,mmm) + common /errors/errors(400) + logical :: errors, intne, realne, chne, ch8ne + integer :: nnn,mmm + integer :: i,j + integer, parameter :: n = 9 + integer, parameter :: m = 10 + integer itarg1 (n) + integer itarg2 (m,n) + real rtarg1(n) + real rtarg2(m,n) + + integer ipte1 + integer ipte2 + real rpte1 + real rpte2 + + dimension ipte1(n) + dimension rpte2(mmm,nnn) + + pointer(iptr4,ipte1) + pointer(iptr5,ipte2) + pointer(iptr7,rpte1) + pointer(iptr8,rpte2) + + dimension ipte2(mmm,nnn) + dimension rpte1(n) + + iptr4 = loc(itarg1) + iptr5 = loc(itarg2) + iptr7 = loc(rtarg1) + iptr8 = loc(rtarg2) + + do, i=1,n + ipte1(i) = i + if (intne(ipte1(i), itarg1(i))) then + ! Error #389 + errors(389) = .true. + endif + + itarg1(i) = -ipte1(i) + if (intne(ipte1(i), itarg1(i))) then + ! Error #390 + errors(390) = .true. + endif + + rpte1(i) = i * 5.0 + if (realne(rpte1(i), rtarg1(i))) then + ! Error #391 + errors(391) = .true. + endif + + rtarg1(i) = i * (-5.0) + if (realne(rpte1(i), rtarg1(i))) then + ! Error #392 + errors(392) = .true. + endif + + do, j=1,m + ipte2(j,i) = i + if (intne(ipte2(j,i), itarg2(j,i))) then + ! Error #393 + errors(393) = .true. + endif + + itarg2(j,i) = -ipte2(j,i) + if (intne(ipte2(j,i), itarg2(j,i))) then + ! Error #394 + errors(394) = .true. + endif + + rpte2(j,i) = i * (-2.0) + if (realne(rpte2(j,i), rtarg2(j,i))) then + ! Error #395 + errors(395) = .true. + endif + + rtarg2(j,i) = i * (-3.0) + if (realne(rpte2(j,i), rtarg2(j,i))) then + ! Error #396 + errors(396) = .true. + endif + + end do + end do +end subroutine ptr13 + + +! Test the passing of pointers and pointees as parameters +subroutine parmtest + integer, parameter :: n = 12 + integer, parameter :: m = 13 + integer iarray(m,n) + pointer (ipt,iptee) + integer iptee (m,n) + + ipt = loc(iarray) + ! write(*,*) "loc(iarray)",loc(iarray) + call parmptr(ipt,iarray,n,m) + ! write(*,*) "loc(iptee)",loc(iptee) + call parmpte(iptee,iarray,n,m) +end subroutine parmtest + +subroutine parmptr(ipointer,intarr,n,m) + common /errors/errors(400) + logical :: errors, intne + integer :: n,m,i,j + integer intarr(m,n) + pointer (ipointer,newpte) + integer newpte(m,n) + ! write(*,*) "loc(newpte)",loc(newpte) + ! write(*,*) "loc(intarr)",loc(intarr) + ! write(*,*) "loc(newpte(1,1))",loc(newpte(1,1)) + ! newpte(1,1) = 101 + ! write(*,*) "newpte(1,1)=",newpte(1,1) + ! write(*,*) "intarr(1,1)=",intarr(1,1) + do, i=1,n + do, j=1,m + newpte(j,i) = i + if (intne(newpte(j,i),intarr(j,i))) then + ! Error #397 + errors(397) = .true. + endif + + call donothing(newpte(j,i),intarr(j,i)) + intarr(j,i) = -newpte(j,i) + if (intne(newpte(j,i),intarr(j,i))) then + ! Error #398 + errors(398) = .true. + endif + end do + end do +end subroutine parmptr + +subroutine parmpte(pointee,intarr,n,m) + common /errors/errors(400) + logical :: errors, intne + integer :: n,m,i,j + integer pointee (m,n) + integer intarr (m,n) + ! write(*,*) "loc(pointee)",loc(pointee) + ! write(*,*) "loc(intarr)",loc(intarr) + ! write(*,*) "loc(pointee(1,1))",loc(pointee(1,1)) + ! pointee(1,1) = 99 + ! write(*,*) "pointee(1,1)=",pointee(1,1) + ! write(*,*) "intarr(1,1)=",intarr(1,1) + + do, i=1,n + do, j=1,m + pointee(j,i) = i + if (intne(pointee(j,i),intarr(j,i))) then + ! Error #399 + errors(399) = .true. + endif + + intarr(j,i) = 2*pointee(j,i) + call donothing(pointee(j,i),intarr(j,i)) + if (intne(pointee(j,i),intarr(j,i))) then + ! Error #400 + errors(400) = .true. + endif + end do + end do +end subroutine parmpte + +! Separate function calls to break Cray pointer-indifferent optimization +logical function intne(ii,jj) + integer :: i,j + common /foo/foo + integer foo + foo = foo + 1 + intne = ii.ne.jj + if (intne) then + write (*,*) ii," doesn't equal ",jj + endif +end function intne + +logical function realne(r1,r2) + real :: r1, r2 + common /foo/foo + integer foo + foo = foo + 1 + realne = r1.ne.r2 + if (realne) then + write (*,*) r1," doesn't equal ",r2 + endif +end function realne + +logical function chne(ch1,ch2) + character :: ch1, ch2 + common /foo/foo + integer foo + foo = foo + 1 + chne = ch1.ne.ch2 + if (chne) then + write (*,*) ch1," doesn't equal ",ch2 + endif +end function chne + +logical function ch8ne(ch1,ch2) + character*8 :: ch1, ch2 + common /foo/foo + integer foo + foo = foo + 1 + ch8ne = ch1.ne.ch2 + if (ch8ne) then + write (*,*) ch1," doesn't equal ",ch2 + endif +end function ch8ne + +subroutine donothing(ii,jj) + common/foo/foo + integer :: ii,jj,foo + if (foo.le.1) then + foo = 1 + else + foo = foo - 1 + endif + if (foo.eq.0) then + ii = -1 + jj = 1 +! print *,"Test did not run correctly" + STOP 3 + endif +end subroutine donothing + diff --git a/Fortran/gfortran/regression/cray_pointers_3.f90 b/Fortran/gfortran/regression/cray_pointers_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/cray_pointers_3.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +program crayerr + real dpte1(10) + pointer (iptr1,dpte1) ! { dg-error "fcray-pointer" } +end program crayerr diff --git a/Fortran/gfortran/regression/cray_pointers_4.f90 b/Fortran/gfortran/regression/cray_pointers_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/cray_pointers_4.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-fcray-pointer" } + +subroutine err1 + integer :: in_common1, in_common2, v, w, equiv1, equiv2 + common /in_common1/ in_common1 + pointer (ipt1, in_common1) ! { dg-error "conflicts with COMMON" } + pointer (ipt2, in_common2) + common /in_common2/ in_common2 ! { dg-error "conflicts with COMMON" } + equivalence (v, equiv1) + pointer (ipt3, equiv1) ! { dg-error "conflicts with EQUIVALENCE" } + pointer (ipt4, equiv2) + equivalence (w, equiv2) ! { dg-error "conflicts with EQUIVALENCE" } +end subroutine err1 diff --git a/Fortran/gfortran/regression/cray_pointers_5.f90 b/Fortran/gfortran/regression/cray_pointers_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/cray_pointers_5.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-fcray-pointer -fno-strict-aliasing" } + +module cray_pointers_5 + integer :: var (10), arr(100) + pointer (ipt, var) +end module cray_pointers_5 + + use cray_pointers_5 + integer :: i + + forall (i = 1:100) arr(i) = i + ipt = loc (arr) + if (any (var .ne. (/1, 2, 3, 4, 5, 6, 7, 8, 9, 10/))) STOP 1 +end diff --git a/Fortran/gfortran/regression/cray_pointers_6.f90 b/Fortran/gfortran/regression/cray_pointers_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/cray_pointers_6.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-fcray-pointer" } +! PR fortran/25358 +subroutine adw_set + implicit none + real*8 Adw_xabcd_8(*) + pointer(Adw_xabcd_8_ , Adw_xabcd_8) + common/ Adw / Adw_xabcd_8_ + integer n + Adw_xabcd_8(1:n) = 1 + return +end subroutine adw_set diff --git a/Fortran/gfortran/regression/cray_pointers_7.f90 b/Fortran/gfortran/regression/cray_pointers_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/cray_pointers_7.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! { dg-options "-fcray-pointer" } + +! Test the implementation of Cray pointers to procedures. +program cray_pointers_7 + implicit none + integer tmp + integer, external :: fn + external sub + + ! We can't mix function and subroutine pointers. + pointer (subptr,subpte) + pointer (fnptr,fnpte) + + ! Declare pointee types. + external subpte + integer, external :: fnpte + + tmp = 0 + + ! Check pointers to subroutines. + subptr = loc(sub) + call subpte(tmp) + if (tmp .ne. 17) STOP 1 + + ! Check pointers to functions. + fnptr = loc(fn) + tmp = fnpte(7) + if (tmp .ne. 14) STOP 2 + +end program cray_pointers_7 + +! Trivial subroutine to be called through a Cray pointer. +subroutine sub(i) + integer i + i = 17 +end subroutine sub + +! Trivial function to be called through a Cray pointer. +function fn(i) + integer fn,i + fn = 2*i +end function fn diff --git a/Fortran/gfortran/regression/cray_pointers_8.f90 b/Fortran/gfortran/regression/cray_pointers_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/cray_pointers_8.f90 @@ -0,0 +1,63 @@ +! { dg-do run } +! { dg-options "-fcray-pointer -ffloat-store" } +! +! Test the fix for PR36528 in which the Cray pointer was not passed +! correctly to 'euler' so that an undefined reference to fcn was +! generated by the linker. +! +! Reported by Tobias Burnus +! from http://groups.google.com/group/comp.lang.fortran/msg/86b65bad78e6af78 +! +real function p1(x) + real, intent(in) :: x + p1 = x +end + +real function euler(xp,xk,dx,f) + real, intent(in) :: xp, xk, dx + interface + real function f(x) + real, intent(in) :: x + end function + end interface + real x, y + y = 0.0 + x = xp + do while (x .le. xk) + y = y + f(x)*dx + x = x + dx + end do + euler = y +end +program main + interface + real function p1 (x) + real, intent(in) :: x + end function + real function fcn (x) + real, intent(in) :: x + end function + real function euler (xp,xk,dx,f) + real, intent(in) :: xp, xk ,dx + interface + real function f(x) + real, intent(in) :: x + end function + end interface + end function + end interface + real x, xp, xk, dx, y, z + pointer (pfcn, fcn) + pfcn = loc(p1) + xp = 0.0 + xk = 1.0 + dx = 0.0005 + y = 0.0 + x = xp + do while (x .le. xk) + y = y + fcn(x)*dx + x = x + dx + end do + z = euler(0.0,1.0,0.0005,fcn) + if (abs (y - z) .gt. 1e-6) STOP 1 +end diff --git a/Fortran/gfortran/regression/cray_pointers_9.f90 b/Fortran/gfortran/regression/cray_pointers_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/cray_pointers_9.f90 @@ -0,0 +1,103 @@ +! { dg-do compile } +! { dg-options "-fcray-pointer" } +! +! Test the fix for PR36703 in which the Cray pointer was not passed +! correctly so that the call to 'fun' at line 102 caused an ICE. +! +! Contributed by James van Buskirk on com.lang.fortran +! http://groups.google.com/group/comp.lang.fortran/msg/b600c081a3654936 +! Reported by Tobias Burnus +! +module funcs + use ISO_C_BINDING ! Added this USE statement + implicit none +! Interface block for function program fptr will invoke +! to get the C_FUNPTR + interface + function get_proc(mess) bind(C,name='BlAh') + use ISO_C_BINDING + implicit none + character(kind=C_CHAR) mess(*) + type(C_FUNPTR) get_proc + end function get_proc + end interface +end module funcs + +module other_fun + use ISO_C_BINDING + implicit none + private +! Message to be returned by procedure pointed to +! by the C_FUNPTR + character, allocatable, save :: my_message(:) +! Interface block for the procedure pointed to +! by the C_FUNPTR + public abstract_fun + abstract interface + function abstract_fun(x) + use ISO_C_BINDING + import my_message + implicit none + integer(C_INT) x(:) + character(size(my_message),C_CHAR) abstract_fun(size(x)) + end function abstract_fun + end interface + contains +! Procedure to store the message and get the C_FUNPTR + function gp(message) bind(C,name='BlAh') + character(kind=C_CHAR) message(*) + type(C_FUNPTR) gp + integer(C_INT64_T) i + + i = 1 + do while(message(i) /= C_NULL_CHAR) + i = i+1 + end do + allocate (my_message(i+1)) ! Added this allocation + my_message = message(int(1,kind(i)):i-1) + gp = get_funloc(make_mess,aux) + end function gp + +! Intermediate procedure to pass the function and get +! back the C_FUNPTR + function get_funloc(x,y) + procedure(abstract_fun) x + type(C_FUNPTR) y + external y + type(C_FUNPTR) get_funloc + + get_funloc = y(x) + end function get_funloc + +! Procedure to convert the function to C_FUNPTR + function aux(x) + interface + subroutine x() bind(C) + end subroutine x + end interface + type(C_FUNPTR) aux + + aux = C_FUNLOC(x) + end function aux + +! Procedure pointed to by the C_FUNPTR + function make_mess(x) + integer(C_INT) x(:) + character(size(my_message),C_CHAR) make_mess(size(x)) + + make_mess = transfer(my_message,make_mess(1)) + end function make_mess +end module other_fun + +program fptr + use funcs + use other_fun + implicit none + procedure(abstract_fun) fun ! Removed INTERFACE + pointer(p,fun) + type(C_FUNPTR) fp + + fp = get_proc('Hello, world'//achar(0)) + p = transfer(fp,p) + write(*,'(a)') fun([1,2,3]) +end program fptr diff --git a/Fortran/gfortran/regression/cshift_1.f90 b/Fortran/gfortran/regression/cshift_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/cshift_1.f90 @@ -0,0 +1,108 @@ +! { dg-do run } +! Take cshift through its paces to make sure no boundary +! cases are wrong. + +module kinds + integer, parameter :: sp = selected_real_kind(6) ! Single precision +end module kinds + +module replacements + use kinds +contains + subroutine cshift_sp_3_v1 (array, shift, dim, res) + integer, parameter :: wp = sp + real(kind=wp), dimension(:,:,:), intent(in) :: array + integer, intent(in) :: shift, dim + real(kind=wp), dimension(:,:,:), intent(out) :: res + integer :: i,j,k + integer :: sh, rsh + integer :: n + integer :: n2, n3 + res = 0 + n3 = size(array,3) + n2 = size(array,2) + n1 = size(array,1) + if (dim == 1) then + n = n1 + sh = modulo(shift, n) + rsh = n - sh + do k=1, n3 + do j=1, n2 + do i=1, rsh + res(i,j,k) = array(i+sh,j,k) + end do + do i=rsh+1,n + res(i,j,k) = array(i-rsh,j,k) + end do + end do + end do + else if (dim == 2) then + n = n2 + sh = modulo(shift,n) + rsh = n - sh + do k=1, n3 + do j=1, rsh + do i=1, n1 + res(i,j,k) = array(i,j+sh, k) + end do + end do + do j=rsh+1, n + do i=1, n1 + res(i,j,k) = array(i,j-rsh, k) + end do + end do + end do + else if (dim == 3) then + n = n3 + sh = modulo(shift, n) + rsh = n - sh + do k=1, rsh + do j=1, n2 + do i=1, n1 + res(i,j,k) = array(i, j, k+sh) + end do + end do + end do + do k=rsh+1, n + do j=1, n2 + do i=1, n1 + res(i,j, k) = array(i, j, k-rsh) + end do + end do + end do + else + stop "Wrong argument to dim" + end if + end subroutine cshift_sp_3_v1 +end module replacements + +program testme + use kinds + use replacements + implicit none + integer, parameter :: wp = sp ! Working precision + INTEGER, PARAMETER :: n = 7 + real(kind=wp), dimension(:,:,:), allocatable :: a,b,c + integer i, j, k + real:: t1, t2 + integer, parameter :: nrep = 20 + + allocate (a(n,n,n), b(n,n,n),c(n,n,n)) + call random_number(a) + do k = 1,3 + do i=-3,3,2 + call cshift_sp_3_v1 (a, i, k, b) + c = cshift(a,i,k) + if (any (c /= b)) STOP 1 + end do + end do + deallocate (b,c) + allocate (b(n-1,n-1,n-1),c(n-1,n-1,n-1)) + do k=1,3 + do i=-3,3,2 + call cshift_sp_3_v1 (a(1:n-1,1:n-1,1:n-1), i, k, b) + c = cshift(a(1:n-1,1:n-1,1:n-1), i, k) + if (any (c /= b)) STOP 2 + end do + end do +end program testme diff --git a/Fortran/gfortran/regression/cshift_2.f90 b/Fortran/gfortran/regression/cshift_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/cshift_2.f90 @@ -0,0 +1,152 @@ +! { dg-do run } +! Test CSHIFT with array argument for shift +module rnd + implicit none +contains + subroutine fill(a,n) + integer, intent(out), dimension(:,:) :: a + integer, intent(in) :: n + real, dimension(size(a,1),size(a,2)) :: r + call random_number(r) + a = int(2*n*r-n) + end subroutine fill +end module rnd + +module csh + implicit none +contains + subroutine emul_cshift(a,sh_in,dim, c) + integer, dimension(:,:,:), intent(in) :: a + integer, dimension(:,:,:), intent(out) :: c + integer, dimension(:,:), intent(in) :: sh_in + integer, intent(in) :: dim + integer :: sh, rsh + integer :: s1, s2, s3, n, i + integer :: n1, n2, n3 + n1 = size(a,1) + n2 = size(a,2) + n3 = size(a,3) + if (dim == 1) then + n = n1 + do s2=1,n2 + do s3=1,n3 + sh = modulo(sh_in(s2,s3), n) + rsh = n - sh + do i=1,rsh + c(i,s2,s3) = a(i+sh,s2,s3) + end do + do i=rsh+1,n + c(i,s2,s3) = a(i-rsh,s2,s3) + end do + end do + end do + else if (dim == 2) then + n = n2 + do s3=1,n3 + do s1=1,n1 + sh = modulo(sh_in(s1,s3),n) + rsh = n - sh + do i=1,rsh + c(s1,i,s3) = a(s1,i+sh,s3) + end do + do i=rsh+1,n + c(s1,i,s3) = a(s1,i-rsh,s3) + end do + end do + end do + + else if (dim == 3) then + n = n3 + do s2=1,n2 + do s1=1,n1 + sh = modulo(sh_in(s1,s2),n) + rsh = n - sh + do i=1,rsh + c(s1,s2,i) = a(s1,s2,i+sh) + end do + do i=rsh+1,n + c(s1,s2,i) = a(s1,s2,i-rsh) + end do + end do + end do + else + stop "Illegal dim" + end if + end subroutine emul_cshift +end module csh +program main + use csh + use rnd + implicit none + integer, parameter :: n1=30,n2=40,n3=50 + integer, dimension(n1,n2,n3) :: a, b,c + integer :: s1, s2, s3 + integer :: dim + integer, dimension(:,:), allocatable :: sh1, sh2, sh3 + integer, dimension(:), allocatable :: sh_shift + integer :: sh, rsh + integer :: i,j,k,v + type t + integer :: i1, i2, i3 + end type t + type(t), dimension(n1,n2,n3) :: ta, tb + + v = 1 + do k=1,n3 + do j=1,n2 + do i=1,n1 + a(i,j,k) = v + v = v + 1 + end do + end do + end do + + ta%i1 = a + ta%i2 = a+a + ta%i3 = a+a+a + allocate(sh1(n2,n3)) + allocate(sh2(n1,n3)) + allocate(sh3(n1,n2)) + + call fill(sh1,10) + call fill(sh2,10) + call fill(sh3,10) + + b = cshift(a,sh1,1) + call emul_cshift(a,sh1,1,c) + if (any(b /= c)) then + print *,b + print *,c + STOP 1 + end if + tb = cshift(ta,sh1,1) + if (any(tb%i1 /= c)) STOP 2 + + b = cshift(a,sh2,2) + call emul_cshift(a,sh2,2,c) + if (any(b /= c)) STOP 3 + tb = cshift(ta,sh2,2) + if (any (tb%i2 /= c*2)) STOP 4 + + b = cshift(a,sh3,3) + call emul_cshift(a,sh3,3,c) + if (any(b /= c)) STOP 5 + tb = cshift(ta,sh3,3) + if (any(tb%i3 /= c*3)) STOP 6 + + b = -42 + c = -42 + b(1:n1:2,:,:) = cshift(a(1:n1/2,:,:),sh1,1) + call emul_cshift(a(1:n1/2,:,:), sh1, 1, c(1:n1:2,:,:)) + if (any(b /= c)) STOP 7 + + tb%i1 = -42 + tb%i2 = -2*42 + tb%i3 = -3*42 + tb(1:n1:2,:,:) = cshift(ta(1:n1/2,:,:),sh1,1) + if (any(tb%i1 /= b)) STOP 8 + if (any(tb%i2 /= 2*b)) STOP 9 + if (any(tb%i3 /= 3*b)) STOP 10 + +9000 format (99(3(I3,1X),2X)) +end program main diff --git a/Fortran/gfortran/regression/cshift_bounds_1.f90 b/Fortran/gfortran/regression/cshift_bounds_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/cshift_bounds_1.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! Check that empty arrays are handled correctly in +! cshift and eoshift +program main + character(len=50) :: line + character(len=3), dimension(2,2) :: a, b + integer :: n1, n2 + line = '-1-2' + read (line,'(2I2)') n1, n2 + call foo(a, b, n1, n2) + a = 'abc' + write (line,'(4A)') eoshift(a, 3) + write (line,'(4A)') cshift(a, 3) + write (line,'(4A)') cshift(a(:,1:n1), 3) + write (line,'(4A)') eoshift(a(1:n2,:), 3) +end program main + +subroutine foo(a, b, n1, n2) + character(len=3), dimension(2, n1) :: a + character(len=3), dimension(n2, 2) :: b + a = cshift(b,1) + a = eoshift(b,1) +end subroutine foo diff --git a/Fortran/gfortran/regression/cshift_bounds_2.f90 b/Fortran/gfortran/regression/cshift_bounds_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/cshift_bounds_2.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! { dg-options "-fbounds-check -fno-realloc-lhs" } +! { dg-shouldfail "Incorrect extent in return value of CSHIFT intrinsic in dimension 2: is 3, should be 2" } +program main + integer, dimension(:,:), allocatable :: a, b + allocate (a(2,2)) + allocate (b(2,3)) + a = 1 + b = cshift(a,1) +end program main +! { dg-output "Fortran runtime error: Incorrect extent in return value of CSHIFT intrinsic in dimension 2: is 3, should be 2" } diff --git a/Fortran/gfortran/regression/cshift_bounds_3.f90 b/Fortran/gfortran/regression/cshift_bounds_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/cshift_bounds_3.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Incorrect size in SHIFT argument of CSHIFT intrinsic: should not be zero-sized" } +program main + real, dimension(1,0) :: a, b, c + integer :: sp(3), i + a = 4.0 + sp = 1 + i = 1 + b = cshift (a,sp(1:i)) ! Invalid +end program main +! { dg-output "Fortran runtime error: Incorrect size in SHIFT argument of CSHIFT intrinsic: should not be zero-sized" } diff --git a/Fortran/gfortran/regression/cshift_bounds_4.f90 b/Fortran/gfortran/regression/cshift_bounds_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/cshift_bounds_4.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! { dg-shouldfail "Incorrect extent in SHIFT argument of CSHIFT intrinsic in dimension 1: is 3, should be 2" } +! { dg-options "-fbounds-check" } +program main + integer, dimension(:,:), allocatable :: a, b + integer, dimension(:), allocatable :: sh + allocate (a(2,2)) + allocate (b(2,2)) + allocate (sh(3)) + a = 1 + b = cshift(a,sh) +end program main +! { dg-output "Fortran runtime error: Incorrect extent in SHIFT argument of CSHIFT intrinsic in dimension 1: is 3, should be 2" } diff --git a/Fortran/gfortran/regression/cshift_large_1.f90 b/Fortran/gfortran/regression/cshift_large_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/cshift_large_1.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_int } +! Program to test the cshift intrinsic for kind=16 integers +program intrinsic_cshift + integer, parameter :: k=16 + integer(kind=k), dimension(3_k, 3_k) :: a + integer(kind=k), dimension(3_k, 3_k, 2_k) :: b + + ! Scalar shift + a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/)) + a = cshift (a, 1_k, 1_k) + if (any (a .ne. reshape ((/2_k, 3_k, 1_k, 5_k, 6_k, 4_k, 8_k, 9_k, 7_k/), (/3_k, 3_k/)))) & + STOP 1 + + a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/)) + a = cshift (a, -2_k, dim = 2_k) + if (any (a .ne. reshape ((/4_k, 5_k, 6_k, 7_k, 8_k, 9_k, 1_k, 2_k, 3_k/), (/3_k, 3_k/)))) & + STOP 2 + + ! Array shift + a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/)) + a = cshift (a, (/1_k, 0_k, -1_k/)) + if (any (a .ne. reshape ((/2_k, 3_k, 1_k, 4_k, 5_k, 6_k, 9_k, 7_k, 8_k/), (/3_k, 3_k/)))) & + STOP 3 + + a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/)) + a = cshift (a, (/2_k, -2_k, 0_k/), dim = 2_k) + if (any (a .ne. reshape ((/7_k, 5_k, 3_k, 1_k, 8_k, 6_k, 4_k, 2_k, 9_k/), (/3_k, 3_k/)))) & + STOP 4 + + ! Test arrays > rank 2 + b = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k, 11_k, 12_k, 13_k, 14_k, 15_k, 16_k, 17_k,& + 18_k, 19_k/), (/3_k, 3_k, 2_k/)) + b = cshift (b, 1_k) + if (any (b .ne. reshape ((/2_k, 3_k, 1_k, 5_k, 6_k, 4_k, 8_k, 9_k, 7_k, 12_k, 13_k, 11_k, 15_k,& + 16_k, 14_k, 18_k, 19_k, 17_k/), (/3_k, 3_k, 2_k/)))) & + STOP 5 + + b = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k, 11_k, 12_k, 13_k, 14_k, 15_k, 16_k, 17_k,& + 18_k, 19_k/), (/3_k, 3_k, 2_k/)) + b = cshift (b, reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/)), 3_k) + if (any (b .ne. reshape ((/11_k, 2_k, 13_k, 4_k, 15_k, 6_k, 17_k, 8_k, 19_k, 1_k, 12_k, 3_k,& + 14_k, 5_k, 16_k, 7_k, 18_k, 9_k/), (/3_k, 3_k, 2_k/)))) & + STOP 6 + +end program diff --git a/Fortran/gfortran/regression/cshift_nan_1.f90 b/Fortran/gfortran/regression/cshift_nan_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/cshift_nan_1.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! Test cshift where the values are eight bytes, +! but are aligned on a four-byte boundary. The +! integers correspond to NaN values. +program main + implicit none + integer :: i + type t + sequence + integer :: a,b + end type t + type(t), dimension(4) :: u,v + common /foo/ u, i, v + + u(1)%a = 2142240768 + u(2)%a = 2144337920 + u(3)%a = -5242880 + u(4)%a = -3145728 + u%b = (/(i,i=-1,-4,-1)/) + v(1:3:2) = cshift(u(1:3:2),1) + v(2:4:2) = cshift(u(2:4:2),-1) + if (any(v%a /= (/-5242880, -3145728, 2142240768, 2144337920 /))) STOP 1 + if (any(v%b /= (/-3, -4, -1, -2/))) STOP 2 +end program main diff --git a/Fortran/gfortran/regression/cshift_shift_real_1.f90 b/Fortran/gfortran/regression/cshift_shift_real_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/cshift_shift_real_1.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR 34549 - a real value was accepted for shift. +program main + implicit none + real, dimension(2,2) :: r + data r /1.0, 2.0, 3.0, 4.0/ + print *,cshift(r,shift=2.3,dim=1) ! { dg-error "must be INTEGER" } +end program main diff --git a/Fortran/gfortran/regression/cshift_shift_real_2.f90 b/Fortran/gfortran/regression/cshift_shift_real_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/cshift_shift_real_2.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR35724 Compile time segmentation fault for CSHIFT with negative third arg + SUBROUTINE RA0072(DDA,LDA,nf10,nf1,mf1,nf2) + REAL DDA(10,10) + LOGICAL LDA(10,10) + WHERE (LDA) DDA = CSHIFT(DDA,1,-MF1) ! MF1 works, -1 works + END SUBROUTINE + diff --git a/Fortran/gfortran/regression/csqrt_2.f b/Fortran/gfortran/regression/csqrt_2.f --- /dev/null +++ b/Fortran/gfortran/regression/csqrt_2.f @@ -0,0 +1,19 @@ +c { dg-do run } +c Fix PR libgfortran/24313 + complex x, y + complex z + z = cmplx(0.707106, -0.707106) + x = cmplx(0.0,-1.0) + y = sqrt(x) + if (abs(y - z) / abs(z) > 1.e-4) STOP 1 + + x = cmplx(tiny(1.),-1.0) + y = sqrt(x) + if (abs(y - z) / abs(z) > 1.e-4) STOP 2 + + x = cmplx(-tiny(1.),-1.0) + y = sqrt(x) + if (abs(y - z) / abs(z) > 1.e-4) STOP 3 + + end + diff --git a/Fortran/gfortran/regression/ctrl-z.f90 b/Fortran/gfortran/regression/ctrl-z.f90 --- /dev/null +++ b/Fortran/gfortran/regression/ctrl-z.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +! PR 30532 Ctrl-Z in source file +! Test case from PR. Submitted by Jerry DeLisle + print *,"" + end diff --git a/Fortran/gfortran/regression/d_lines_1.f b/Fortran/gfortran/regression/d_lines_1.f --- /dev/null +++ b/Fortran/gfortran/regression/d_lines_1.f @@ -0,0 +1,5 @@ +! { dg-do compile } +! { dg-options "-fd-lines-as-comments" } +d This is a comment. +D This line, too. + end diff --git a/Fortran/gfortran/regression/d_lines_2.f b/Fortran/gfortran/regression/d_lines_2.f --- /dev/null +++ b/Fortran/gfortran/regression/d_lines_2.f @@ -0,0 +1,6 @@ +! { dg-do compile } +c { dg-options "-fd-lines-as-code" } + i = 0 +d end + subroutine s +D end diff --git a/Fortran/gfortran/regression/d_lines_3.f b/Fortran/gfortran/regression/d_lines_3.f --- /dev/null +++ b/Fortran/gfortran/regression/d_lines_3.f @@ -0,0 +1,10 @@ +C { dg-do compile } +C { dg-options "-fd-lines-as-code" } +C Verifies that column numbers are dealt with correctly when handling D lines. +C234567890 +d i = 0 ! this may not move to the left +d 1 + 1 ! this should be a continuation line + goto 2345 +d23450continue ! statement labels are correctly identified + end + diff --git a/Fortran/gfortran/regression/d_lines_4.f b/Fortran/gfortran/regression/d_lines_4.f --- /dev/null +++ b/Fortran/gfortran/regression/d_lines_4.f @@ -0,0 +1,3 @@ +! { dg-do compile } +c verify that debug lines are rejected if none of -fd-lines-as-* are given. +d ! { dg-error "Non-numeric character" } diff --git a/Fortran/gfortran/regression/d_lines_5.f b/Fortran/gfortran/regression/d_lines_5.f --- /dev/null +++ b/Fortran/gfortran/regression/d_lines_5.f @@ -0,0 +1,3 @@ +! { dg-do compile } +c { dg-options "-fd-lines-as-code" } +d ! This didn't work in an early version of the support for -fd-lines* diff --git a/Fortran/gfortran/regression/data_array_1.f90 b/Fortran/gfortran/regression/data_array_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_array_1.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! PR32928 DATA statement with array element as initializer is rejected +! Test case by Jerry DeLisle +program chkdata + integer, parameter,dimension(4) :: myint = [ 4,3,2,1 ] + character(3), parameter, dimension(3) :: mychar = [ "abc", "def", "ghi" ] + character(50) :: buffer + integer :: a(5) + character(5) :: c(5) + data a(1:2) / myint(4), myint(2) / + data a(3:5) / myint(1), myint(3), myint(1) / + data c / mychar(1), mychar(2), mychar(3), mychar(1), mychar(2) / + buffer = "" + if (any(a.ne.[1,3,4,2,4])) STOP 1 + write(buffer,'(5(a))')c + if (buffer.ne."abc def ghi abc def ") STOP 2 +end program chkdata diff --git a/Fortran/gfortran/regression/data_array_2.f90 b/Fortran/gfortran/regression/data_array_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_array_2.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR32928 DATA statement with array element as initializer is rejected +integer, parameter,dimension(4) :: myint = [ 4,3,2,1 ] +integer :: a(5) +data a(1:2) / myint(a(1)), myint(2) / ! { dg-error "Invalid initializer" } +end diff --git a/Fortran/gfortran/regression/data_array_3.f90 b/Fortran/gfortran/regression/data_array_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_array_3.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR32928 DATA statement with array element as initializer is rejected +integer, parameter,dimension(4) :: myint = [ 4,3,2,1 ] +integer :: a(5),b +data a(1:2) / myint(b), myint(2) / ! { dg-error "Invalid initializer" } +end diff --git a/Fortran/gfortran/regression/data_array_4.f90 b/Fortran/gfortran/regression/data_array_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_array_4.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR32928 DATA statement with array element as initializer is rejected +IMPLICIT NONE +INTEGER , PARAMETER :: NTAB = 3 +REAL :: SR(NTAB) , SR3(NTAB) +DATA SR/NTAB*0.0/ , SR3/NTAB*0.0/ +end diff --git a/Fortran/gfortran/regression/data_array_5.f90 b/Fortran/gfortran/regression/data_array_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_array_5.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! Tests the fix for PR36371, in which the locus for the errors pointed to +! the parameter declaration rather than the data statement. +! +! Contributed by Dominique d'Humieres +! +program chkdata + character(len=3), parameter :: mychar(3) = [ "abc", "def", "ghi" ] + integer, parameter :: myint(3) = [1, 2, 3] + integer :: c(2) + character(4) :: i(2) + data c / mychar(1), mychar(3) / ! { dg-error "Incompatible types in DATA" } + data i / myint(3), myint(2) / ! { dg-error "Incompatible types in DATA" } +end program chkdata diff --git a/Fortran/gfortran/regression/data_array_6.f b/Fortran/gfortran/regression/data_array_6.f --- /dev/null +++ b/Fortran/gfortran/regression/data_array_6.f @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! PR fortran/38404 - location marker in wrong line +! Testcase contributed by Steve Chapel +! + + CHARACTER(len=72) TEXT(3) + DATA (TEXT(I),I=1,3)/ + &'a string without issues', + &'a string with too many characters properly broken into the next + &line but too long to fit the variable', + & ' + &a string that started just at the end of the last line -- some + &may not be helped'/ + + ! { dg-warning "truncated" "" { target *-*-* } 10 } + ! { dg-warning "truncated" "" { target *-*-* } 12 } + + END diff --git a/Fortran/gfortran/regression/data_bounds_1.f90 b/Fortran/gfortran/regression/data_bounds_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_bounds_1.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-std=gnu" } +! Checks the fix for PR32315, in which the bounds checks below were not being done. +! +! Contributed by Tobias Burnus +! +program chkdata + character(len=20), dimension(4) :: string + character(len=20), dimension(0:1,3:4) :: string2 + + data (string(i) ,i = 4, 5) /'D', 'E'/ ! { dg-error "above array upper bound" } + data (string(i) ,i = 0, 1) /'A', 'B'/ ! { dg-error "below array lower bound" } + data (string(i) ,i = 1, 4) /'A', 'B', 'C', 'D'/ + + data ((string2(i, j) ,i = 1, 2), j = 3, 4) /'A', 'B', 'C', 'D'/ ! { dg-error "above array upper bound" } + data ((string2(i, j) ,i = 0, 1), j = 2, 3) /'A', 'B', 'C', 'D'/ ! { dg-error "below array lower bound" } + data ((string2(i, j) ,i = 0, 1), j = 3, 4) /'A', 'B', 'C', 'D'/ +end program chkdata diff --git a/Fortran/gfortran/regression/data_char_1.f90 b/Fortran/gfortran/regression/data_char_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_char_1.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-std=gnu" } +! Test character variables in data statements +! Also substrings of character variables. +! PR14976 PR16228 +program data_char_1 + character(len=5) :: a(2) + character(len=5) :: b(2) + data a /'Hellow', 'orld'/ ! { dg-warning "truncated" } + data b(:)(1:4), b(1)(5:5), b(2)(5:5) & + /'abcdefg', 'hi', 'j', 'k'/ ! { dg-warning "truncated" } + + if ((a(1) .ne. 'Hello') .or. (a(2) .ne. 'orld ')) STOP 1 + if ((b(1) .ne. 'abcdj') .or. (b(2) .ne. 'hi k')) STOP 2 +end program diff --git a/Fortran/gfortran/regression/data_char_2.f90 b/Fortran/gfortran/regression/data_char_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_char_2.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! Test that getting a character from a +! string data works. + +CHARACTER*10 INTSTR +CHARACTER C1 +DATA INTSTR / '0123456789' / + +C1 = INTSTR(1:1) +if(C1 .ne. '0') STOP 1 + +end diff --git a/Fortran/gfortran/regression/data_char_3.f90 b/Fortran/gfortran/regression/data_char_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_char_3.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! { dg-options "-O2" } +! Tests the fix PR29392, in which the iterator valued substring +! reference would cause a segfault. +! +! Contributed by Francois-Xavier Coudert +! + character(LEN=2) :: a(2) + data ((a(I)(k:k),I=1,2),k=1,2) /2*'a',2*'z'/ + IF (ANY(a.NE."az")) STOP 1 + END diff --git a/Fortran/gfortran/regression/data_char_4.f90 b/Fortran/gfortran/regression/data_char_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_char_4.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR fortran/99205 - Out of memory with undefined character length +! { dg-options "-w" } + +program p + character(l) :: c(2) ! { dg-error "must have constant character length" } + data c /'a', 'b'/ + common c +end + +! { dg-error "cannot appear in the expression at" " " { target *-*-* } 6 } diff --git a/Fortran/gfortran/regression/data_char_5.f90 b/Fortran/gfortran/regression/data_char_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_char_5.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! PR fortran/99205 - Issues with non-constant character length + +subroutine sub () + integer :: ll = 4 + block + character(ll) :: c(2) ! { dg-error "non-constant" } + data c /'a', 'b'/ + end block +contains + subroutine sub1 () + character(ll) :: d(2) ! { dg-error "non-constant" } + data d /'a', 'b'/ + end subroutine sub1 +end subroutine sub diff --git a/Fortran/gfortran/regression/data_components_1.f90 b/Fortran/gfortran/regression/data_components_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_components_1.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! Check the fix for PR30879, in which the structure +! components in the DATA values would cause a syntax +! error. +! +! Contributed by Joost VandeVondele +! + TYPE T1 + INTEGER :: I + END TYPE T1 + + TYPE(T1), PARAMETER :: D1=T1(2) + TYPE(T1) :: D2(2) + + INTEGER :: a(2) + + DATA (a(i),i=1,D1%I) /D1%I*D1%I/ + + DATA (D2(i),i=1,D1%I) /D1%I*T1(4)/ + + print *, a + print *, D2 + END diff --git a/Fortran/gfortran/regression/data_constraints_1.f90 b/Fortran/gfortran/regression/data_constraints_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_constraints_1.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "" } +! Tests standard indepedendent constraints for variables in a data statement +! +! Contributed by Paul Thomas +! + module global + integer n + end module global + + use global + integer q + data n /0/ ! { dg-error "Cannot change attributes" } + n = 1 + n = foo (n) +contains + function foo (m) result (bar) + integer p (m), bar + integer, allocatable :: l(:) + allocate (l(1)) + data l /42/ ! { dg-error "conflicts with ALLOCATABLE" } + data p(1) /1/ ! { dg-error "non-constant array in DATA" } + data q /1/ ! { dg-error "Host associated variable" } + data m /1/ ! { dg-error "conflicts with DUMMY attribute" } + data bar /99/ ! { dg-error "conflicts with RESULT" } + end function foo + function foobar () + integer foobar + data foobar /0/ ! { dg-error "conflicts with FUNCTION" } + end function foobar +end diff --git a/Fortran/gfortran/regression/data_constraints_2.f90 b/Fortran/gfortran/regression/data_constraints_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_constraints_2.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! Tests constraints for variables in a data statement that are commonly +! relaxed. +! +! Contributed by Paul Thomas +! + common // a + common /b/ c + integer d + data a /1/ ! { dg-error "common block variable" } + data c /2/ ! { dg-error "common block variable" } + data d /3/ + data d /4/ ! { dg-error " re-initialization" } +end diff --git a/Fortran/gfortran/regression/data_constraints_3.f90 b/Fortran/gfortran/regression/data_constraints_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_constraints_3.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! +! PR fortran/40881 +! +integer :: a(3) +print *, 'Hello' +data a/3*5/ ! { dg-warning "Obsolescent feature: DATA statement at .1. after the first executable statement" } +end diff --git a/Fortran/gfortran/regression/data_derived_1.f90 b/Fortran/gfortran/regression/data_derived_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_derived_1.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! PR 66328 - this used to give a wrong value for integer values for DATA +program main + TYPE t + REAL r + END TYPE t + TYPE (t) e1, e2 + + DATA e1 / t(1) / + DATA e2 / t(1.0) / + if (abs(e1%r - 1.0) > 1e-6) STOP 1 + if (abs(e2%r - 1.0) > 1e-6) STOP 2 +END diff --git a/Fortran/gfortran/regression/data_implied_do_1.f90 b/Fortran/gfortran/regression/data_implied_do_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_implied_do_1.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! Test of the patch for PR23232, in which implied do loop +! variables were not permitted in DATA statements. +! +! Contributed by Roger Ferrer Ib��ez +! +PROGRAM p + REAL :: TWO_ARRAY (3, 3) + INTEGER :: K, J + DATA ((TWO_ARRAY (K, J), K = 1, J-1), J = 1, 3) /3 * 1.0/ + DATA ((TWO_ARRAY (K, J), K = J, 3), J = 1, 3) /6 * 2.0/ + if (any (reshape (two_array, (/9/)) & + .ne. (/2.0,2.0,2.0,1.0,2.0,2.0,1.0,1.0,2.0/))) STOP 1 +END PROGRAM + diff --git a/Fortran/gfortran/regression/data_implied_do_2.f90 b/Fortran/gfortran/regression/data_implied_do_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_implied_do_2.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/84134 - this used to ICE. +! Test case by Gerhard Steinmetz + +program p + integer :: i, x(3) + data (x(i+1:i+2:i),i=0,1) /1,2,3/ ! { dg-error "Nonconstant array section" } +end diff --git a/Fortran/gfortran/regression/data_initialized.f90 b/Fortran/gfortran/regression/data_initialized.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_initialized.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! Tests fix for PR17737 - already initialized variable cannot appear +! in data statement + integer :: i, j = 1 + data i/0/ + data i/0/ ! { dg-error "Extension: re-initialization" } + data j/2/ ! { dg-error "Extension: re-initialization" } + end + diff --git a/Fortran/gfortran/regression/data_initialized_2.f90 b/Fortran/gfortran/regression/data_initialized_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_initialized_2.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! Tests the fix for PR32236, in which the error below manifested itself +! as an ICE. +! Contributed by Bob Arduini + real :: x(2) = 1.0 ! { dg-error "already is initialized" } + data x /1.0, 2.0/ ! { dg-error "already is initialized" } + print *, x +end diff --git a/Fortran/gfortran/regression/data_initialized_3.f90 b/Fortran/gfortran/regression/data_initialized_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_initialized_3.f90 @@ -0,0 +1,43 @@ +! { dg-do compile } +! +! PR fortran/65532 +! The partial initialization through data statements was producing +! shape mismatch errors. +! +! Contributed by Harald Anlauf + +module gfcbug131 + implicit none +contains + DOUBLE PRECISION FUNCTION d1mach(i) + INTEGER, INTENT(IN) :: i + + INTEGER :: small(4) + INTEGER :: large(4) + INTEGER :: right(4) + INTEGER :: diver(4) + INTEGER :: LOG10(4) + DOUBLE PRECISION :: dmach(5) + + EQUIVALENCE (dmach(1),small(1)) + EQUIVALENCE (dmach(2),large(1)) + EQUIVALENCE (dmach(3),right(1)) + EQUIVALENCE (dmach(4),diver(1)) + EQUIVALENCE (dmach(5),LOG10(1)) + + DATA small(1),small(2) / 0, 1048576 / + DATA large(1),large(2) / -1, 2146435071 / + DATA right(1),right(2) / 0, 1017118720 / + DATA diver(1),diver(2) / 0, 1018167296 / + DATA LOG10(1),LOG10(2) / 1352628735, 1070810131 / + + d1mach = dmach(i) + END FUNCTION d1mach + + DOUBLE PRECISION FUNCTION foo (x) + DOUBLE PRECISION, INTENT(IN) :: x + foo = SQRT (d1mach(4)) + END FUNCTION foo + +end module gfcbug131 + diff --git a/Fortran/gfortran/regression/data_inquiry_ref.f90 b/Fortran/gfortran/regression/data_inquiry_ref.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_inquiry_ref.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! +! Test the fix for PR98022. Code is in place to deliver the expected result. +! However, it was determined that the data statements below violate F18(R841) +! and so an error results. +! +! Contributed by Arseny Solokha +! +module ur +contains +! The reporter's test. + function kn1() result(hm2) + complex :: hm(1:2), hm2(1:3), scalar + data (hm(md)%re, md=1,2)/1.0, 2.0/, scalar%re/42.0/ ! { dg-error "neither an array-element" } + data (hm(md)%im, md=1,2)/0.0, 0.0/, scalar%im/-42.0/ ! { dg-error "neither an array-element" } + hm2(1:2) = hm + hm2(3) = scalar + end function kn1 + +! Check for derived types with complex components. + function kn2() result(hm2) + type t + complex :: c + integer :: i + end type + type (t) :: hm(1:2), scalar + complex :: hm2(1:3) + data (hm(md)%c%re, md=1,2)/0.0, 0.0/, scalar%c%re/42.0/ ! { dg-error "neither an array-element" } + data (hm(md)%c%im, md=1,2)/1.0, 2.0/, scalar%c%im/-42.0/ ! { dg-error "neither an array-element" } + data (hm(md)%i, md=1,2)/1, 2/ + hm2(1:2) = hm%c + hm2(3) = scalar%c + end function kn2 +end module ur + +! use ur +! if (any (kn1() .ne. [(1.0,0.0),(2.0,0.0),(42.0,-42.0)])) stop 1 +! if (any (kn2() .ne. [(0.0,1.0),(0.0,2.0),(42.0,-42.0)])) stop 2 +end diff --git a/Fortran/gfortran/regression/data_invalid.f90 b/Fortran/gfortran/regression/data_invalid.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_invalid.f90 @@ -0,0 +1,120 @@ +! { dg-do compile } +! { dg-options "-std=f95 -fmax-errors=0" } +! +! Testcases from PR fortran/24978 +! + +SUBROUTINE data_init_scalar_invalid() + integer :: a + data a / 1 / + data a / 1 / ! { dg-error "re-initialization" } + + integer :: b = 0 + data b / 1 / ! { dg-error "re-initialization" } +END SUBROUTINE + +SUBROUTINE data_init_array_invalid() + ! initialize (at least) one element, re-initialize full array + integer :: a(3) + data a(2) / 2 / + data a / 3*1 / ! { dg-error "re-initialization" } + + ! initialize (at least) one element, re-initialize subsection including the element + integer :: b(3) + data b(2) / 2 / + data b(1:2) / 2*1 / ! { dg-error "re-initialization" } + + ! initialize subsection, re-initialize (intersecting) subsection + integer :: c(3) + data c(1:2) / 2*1 / + data c(2:3) / 1,1 / ! { dg-error "re-initialization" } + + ! initialize subsection, re-initialize full array + integer :: d(3) + data d(2:3) / 2*1 / + data d / 2*2, 3 / ! { dg-error "re-initialization" } + + ! full array initializer, re-initialize (at least) one element + integer :: e(3) + data e / 3*1 / + data e(2) / 2 / ! { dg-error "re-initialization" } + + integer :: f(3) = 0 ! { dg-error "already is initialized" } + data f(2) / 1 / ! { dg-error "already is initialized" } + + ! full array initializer, re-initialize subsection + integer :: g(3) + data g / 3*1 / + data g(1:2) / 2*2 / ! { dg-error "re-initialization" } + + integer :: h(3) = 1 ! { dg-error "already is initialized" } + data h(2:3) / 2*2 / ! { dg-error "already is initialized" } + + ! full array initializer, re-initialize full array + integer :: i(3) + data i / 3*1 / + data i / 2,2,2 / ! { dg-error "re-initialization" } + + integer :: j(3) = 1 ! { dg-error "already is initialized" } + data j / 3*2 / ! { dg-error "already is initialized" } +END SUBROUTINE + +SUBROUTINE data_init_matrix_invalid() + ! initialize (at least) one element, re-initialize full matrix + integer :: a(3,3) + data a(2,2) / 1 / + data a / 9*2 / ! { dg-error "re-initialization" } + + ! initialize (at least) one element, re-initialize subsection + integer :: b(3,3) + data b(2,2) / 1 / + data b(2,:) / 3*2 / ! { dg-error "re-initialization" } + + ! initialize subsection, re-initialize (intersecting) subsection + integer :: c(3,3) + data c(3,:) / 3*1 /, c(:,3) / 3*2 / ! { dg-error "re-initialization" } + + ! initialize subsection, re-initialize full array + integer :: d(3,3) + data d(2,:) / 1,2,3 / + data d / 9*4 / ! { dg-error "re-initialization" } + + ! full array initializer, re-initialize (at least) one element + integer :: e(3,3) + data e / 9*1 / + data e(2,3) / 2 / ! { dg-error "re-initialization" } + + integer :: f(3,3) = 1 ! { dg-error "already is initialized" } + data f(3,2) / 2 / ! { dg-error "already is initialized" } + + ! full array initializer, re-initialize subsection + integer :: g(3,3) + data g / 9 * 1 / + data g(2:3,2:3) / 2, 2*3, 4 / ! { dg-error "re-initialization" } + + integer :: h(3,3) = 1 ! { dg-error "already is initialized" } + data h(2:3,2:3) / 2, 2*3, 4 / ! { dg-error "already is initialized" } + + ! full array initializer, re-initialize full array + integer :: i(3,3) + data i / 3*1, 3*2, 3*3 / + data i / 9 * 1 / ! { dg-error "re-initialization" } + + integer :: j(3,3) = 0 ! { dg-error "already is initialized" } + data j / 9 * 1 / ! { dg-error "already is initialized" } +END SUBROUTINE + +SUBROUTINE data_init_misc_invalid() + ! wrong number of dimensions + integer :: a(3) + data a(1,1) / 1 / ! { dg-error "Rank mismatch" } + + ! index out-of-bounds, direct access + integer :: b(3) + data b(-2) / 1 / ! { dg-error "below array lower bound" } + ! { dg-warning "is out of bounds" "" { target *-*-* } .-1 } + ! index out-of-bounds, implied do-loop (PR32315) + integer :: i + character(len=20), dimension(4) :: string + data (string(i), i = 1, 5) / 'A', 'B', 'C', 'D', 'E' / ! { dg-error "above array upper bound" } +END SUBROUTINE diff --git a/Fortran/gfortran/regression/data_namelist_conflict.f90 b/Fortran/gfortran/regression/data_namelist_conflict.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_namelist_conflict.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! Problem report: http://gcc.gnu.org/ml/fortran/2010-05/msg00139.html +! +module globals + implicit none + integer j + data j/1/ +end module + +program test + use globals + implicit none + character(len=80) str + integer :: i + data i/0/ + namelist /nl/i,j + open(unit=10,status='scratch') + write(10,nl) + i = 42 + j = 42 + rewind(10) + read(10,nl) + if (i /= 0 .or. j /= 1) STOP 1 + close(10) +end program diff --git a/Fortran/gfortran/regression/data_pointer_1.f90 b/Fortran/gfortran/regression/data_pointer_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_pointer_1.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! Test the fixes for PR38917 and 38918, in which the NULL values caused errors. +! +! Contributed by Dick Hendrickson +! and Tobias Burnus +! + SUBROUTINE PF0009 +! PR38918 + TYPE :: HAS_POINTER + INTEGER, POINTER :: PTR_S + END TYPE HAS_POINTER + TYPE (HAS_POINTER) :: PTR_ARRAY(5) + + DATA PTR_ARRAY(1)%PTR_S /NULL()/ + + end subroutine pf0009 + + SUBROUTINE PF0005 +! PR38917 + REAL, SAVE, POINTER :: PTR1 + INTEGER, POINTER :: PTR2(:,:,:) + CHARACTER(LEN=1), SAVE, POINTER :: PTR3(:) + + DATA PTR1 / NULL() / + DATA PTR2 / NULL() / + DATA PTR3 / NULL() / + + end subroutine pf0005 + +! Tobias pointed out that this would cause an ICE rather than an error. + subroutine tobias + integer, pointer :: ptr(:) + data ptr(1) /NULL()/ ! { dg-error "must be a full array" } + end subroutine tobias + diff --git a/Fortran/gfortran/regression/data_pointer_2.f90 b/Fortran/gfortran/regression/data_pointer_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_pointer_2.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-O -g" } +! PR fortran/77693 - ICE in rtl_for_decl_init +! Contributed by G.Steinmetz + +program p + implicit none + complex, target :: y = (1.,2.) + complex, target :: z(2) = (3.,4.) + complex, pointer :: a => y + complex, pointer :: b => z(1) + complex, pointer :: c, d, e + data c /NULL()/ ! Valid + data d /y/ ! Valid + data e /(1.,2.)/ ! { dg-error "Pointer assignment target" } + if (associated (a)) print *, a% re + if (associated (b)) print *, b% im + if (associated (c)) print *, c% re + if (associated (d)) print *, d% im + if (associated (e)) print *, e% re +end diff --git a/Fortran/gfortran/regression/data_stmt_pointer.f90 b/Fortran/gfortran/regression/data_stmt_pointer.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_stmt_pointer.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +program foo + real, pointer :: p + real, save, target :: x = 42 + data p / x / + if (p /= 42) stop 1 + call bar +end program foo + +subroutine bar + type bah + integer, pointer :: p + end type bah + type(bah) a + integer, save, target :: i = 42 + data a%p / i / + if (a%p /= 42) stop 2 +end subroutine + diff --git a/Fortran/gfortran/regression/data_substring.f90 b/Fortran/gfortran/regression/data_substring.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_substring.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR fortran/30792 +character string*1025 +integer i +data (string(i:i),i=1,1025)/1025*'?'/ ! { dg-error "Invalid substring" } +end diff --git a/Fortran/gfortran/regression/data_value_1.f90 b/Fortran/gfortran/regression/data_value_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/data_value_1.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! Test the fix for PR40402, in which it was not detected that X +! is not a constant and so the DATA statement did not have +! a constant value expression. +! +! Modified dg-error for PR41807 +! +! Contributed by Philippe Marguinaud +! + TYPE POINT + REAL :: X + ENDTYPE + TYPE(POINT) :: P + DATA P / POINT(1.+X) / ! { dg-error "non-constant initialization" } + print *, p + END diff --git a/Fortran/gfortran/regression/date_and_time_1.f90 b/Fortran/gfortran/regression/date_and_time_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/date_and_time_1.f90 @@ -0,0 +1,35 @@ +! PR libfortran/98507 +! { dg-do run } + +program demo_time_and_date + implicit none + character(8) :: date + character(10) :: time + character(5) :: zone + integer :: val(8) + integer :: h, m + + call date_and_time(values=val) + + if (val(1) < 2000 .or. val(1) > 2100) stop 1 + if (val(2) < 1 .or. val(2) > 12) stop 2 + if (val(3) < 1 .or. val(3) > 31) stop 3 + + ! Maximum offset is 14 hours (UTC+14) + if (val(4) < -14*60 .or. val(4) > 14*60) stop 4 + + if (val(5) < 0 .or. val(5) > 23) stop 5 + if (val(6) < 0 .or. val(6) > 59) stop 6 + if (val(7) < 0 .or. val(7) > 60) stop 7 + if (val(8) < 0 .or. val(8) > 999) stop 8 + + call date_and_time(zone=zone) + if (len(zone) /= 0) then + ! If ZONE is present, it should present the same information as + ! given in VALUES(4) + if (len(zone) /= 5) stop 9 + read(zone(1:3),*) h + read(zone(4:5),*) m + if (val(4) /= 60*h+m) stop 10 + endif +end diff --git a/Fortran/gfortran/regression/deallocate_alloc_opt_1.f90 b/Fortran/gfortran/regression/deallocate_alloc_opt_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deallocate_alloc_opt_1.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +program a + + implicit none + + real x + integer j, k, n(4) + character(len=70) err + character(len=70), allocatable :: error(:) + + integer, allocatable :: i(:) + + type b + integer, allocatable :: c(:), d(:) + end type b + + type(b) e, f(3) + + deallocate(i, stat=x) ! { dg-error "must be a scalar INTEGER" } + deallocate(i, stat=j, stat=k) ! { dg-error "Redundant STAT" } + deallocate(i) + deallocate(i)) ! { dg-error "Syntax error in DEALLOCATE" } + deallocate(i, errmsg=err, errmsg=err) ! { dg-error "Redundant ERRMSG" } + deallocate(i, errmsg=err) ! { dg-warning "useless without a STAT" } + deallocate(i, stat=j, errmsg=x) ! { dg-error "shall be a scalar default CHARACTER" } + + deallocate(err) ! { dg-error "nonprocedure pointer nor an allocatable" } + + deallocate(error,stat=j,errmsg=error(1)) ! { dg-error "shall not be DEALLOCATEd within" } + deallocate(i, stat = i(1)) ! { dg-error "shall not be DEALLOCATEd within" } + + deallocate(n) ! { dg-error "must be ALLOCATABLE or a POINTER" } + + deallocate(i, i) ! { dg-error "Allocate-object at" } + + ! These should not fail the check for duplicate alloc-objects. + deallocate(f(1)%c, f(2)%d) + deallocate(e%c, e%d) + +end program a diff --git a/Fortran/gfortran/regression/deallocate_alloc_opt_2.f90 b/Fortran/gfortran/regression/deallocate_alloc_opt_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deallocate_alloc_opt_2.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +subroutine sub(i, j, err) + implicit none + character(len=*), intent(in) :: err + integer, intent(in) :: j + integer, intent(in), allocatable :: i(:) + integer, allocatable :: m(:) + integer n + deallocate(i) ! { dg-error "variable definition context" } + deallocate(m, stat=j) ! { dg-error "variable definition context" } + deallocate(m,stat=n,errmsg=err) ! { dg-error "variable definition context" } +end subroutine sub diff --git a/Fortran/gfortran/regression/deallocate_alloc_opt_3.f90 b/Fortran/gfortran/regression/deallocate_alloc_opt_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deallocate_alloc_opt_3.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +program a + + implicit none + + integer n + character(len=70) e1 + character(len=30) e2 + integer, allocatable :: i(:) + + e1 = 'No error' + allocate(i(4)) + deallocate(i, stat=n, errmsg=e1) + if (trim(e1) /= 'No error') STOP 1 + + e2 = 'No error' + allocate(i(4)) + deallocate(i, stat=n, errmsg=e2) + if (trim(e2) /= 'No error') STOP 2 + + e1 = 'No error' + deallocate(i, stat=n, errmsg=e1) + if (trim(e1) /= 'Attempt to deallocate an unallocated object') STOP 3 + + e2 = 'No error' + deallocate(i, stat=n, errmsg=e2) + if (trim(e2) /= 'Attempt to deallocate an unall') STOP 4 + +end program a diff --git a/Fortran/gfortran/regression/deallocate_error_1.f90 b/Fortran/gfortran/regression/deallocate_error_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deallocate_error_1.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-shouldfail "runtime error" } +! { dg-output "At line 14.*Attempt to DEALLOCATE unallocated 'arr'" } + +! PR fortran/37507 +! Check that locus is printed for DEALLOCATE errors. + +PROGRAM main + IMPLICIT NONE + INTEGER, ALLOCATABLE :: arr(:) + + ALLOCATE (arr(5)) + DEALLOCATE (arr) + DEALLOCATE (arr) +END PROGRAM main diff --git a/Fortran/gfortran/regression/deallocate_error_2.f90 b/Fortran/gfortran/regression/deallocate_error_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deallocate_error_2.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-shouldfail "runtime error" } +! { dg-output "At line 15.*Attempt to DEALLOCATE unallocated 'ptr'" } + +! PR fortran/37507 +! Check that locus is printed for DEALLOCATE errors. + +PROGRAM main + IMPLICIT NONE + INTEGER, POINTER :: ptr + INTEGER, ALLOCATABLE :: arr(:) + + ALLOCATE (ptr, arr(5)) + DEALLOCATE (ptr) + DEALLOCATE (arr, ptr) +END PROGRAM main diff --git a/Fortran/gfortran/regression/deallocate_error_3.f90 b/Fortran/gfortran/regression/deallocate_error_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deallocate_error_3.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/82994 +! Code contributed by Gerhard Steinmetz +program p + type t + end type + class(t) :: x ! { dg-error "must be dummy, allocatable or pointer" } + deallocate (x) ! { dg-error "not a nonprocedure pointer nor an allocatable" } +end diff --git a/Fortran/gfortran/regression/deallocate_error_4.f90 b/Fortran/gfortran/regression/deallocate_error_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deallocate_error_4.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/82994 +! Code contributed by Gerhard Steinmetz +program p + type t + end type + class(t) :: x ! { dg-error "must be dummy, allocatable or pointer" } + allocate (x) ! { dg-error "neither a data pointer nor an allocatable" } + deallocate (x) ! { dg-error "not a nonprocedure pointer nor an allocatable" } +end diff --git a/Fortran/gfortran/regression/deallocate_stat.f90 b/Fortran/gfortran/regression/deallocate_stat.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deallocate_stat.f90 @@ -0,0 +1,77 @@ +! { dg-do run } +! PR 17792 +! PR 21375 +! Test that the STAT argument to DEALLOCATE works with POINTERS and +! ALLOCATABLE arrays. +program deallocate_stat + + implicit none + + integer i + real, pointer :: a1(:), a2(:,:), a3(:,:,:), a4(:,:,:,:), & + & a5(:,:,:,:,:), a6(:,:,:,:,:,:), a7(:,:,:,:,:,:,:) + + real, allocatable :: b1(:), b2(:,:), b3(:,:,:), b4(:,:,:,:), & + & b5(:,:,:,:,:), b6(:,:,:,:,:,:), b7(:,:,:,:,:,:,:) + + allocate(a1(2), a2(2,2), a3(2,2,2), a4(2,2,2,2), a5(2,2,2,2,2)) + allocate(a6(2,2,2,2,2,2), a7(2,2,2,2,2,2,2)) + + a1 = 1. ; a2 = 2. ; a3 = 3. ; a4 = 4. ; a5 = 5. ; a6 = 6. ; a7 = 7. + + i = 13 + deallocate(a1, stat=i) ; if (i /= 0) STOP 1 + deallocate(a2, stat=i) ; if (i /= 0) STOP 2 + deallocate(a3, stat=i) ; if (i /= 0) STOP 3 + deallocate(a4, stat=i) ; if (i /= 0) STOP 4 + deallocate(a5, stat=i) ; if (i /= 0) STOP 5 + deallocate(a6, stat=i) ; if (i /= 0) STOP 6 + deallocate(a7, stat=i) ; if (i /= 0) STOP 7 + + i = 14 + deallocate(a1, stat=i) ; if (i /= 1) STOP 8 + deallocate(a2, stat=i) ; if (i /= 1) STOP 9 + deallocate(a3, stat=i) ; if (i /= 1) STOP 10 + deallocate(a4, stat=i) ; if (i /= 1) STOP 11 + deallocate(a5, stat=i) ; if (i /= 1) STOP 12 + deallocate(a6, stat=i) ; if (i /= 1) STOP 13 + deallocate(a7, stat=i) ; if (i /= 1) STOP 14 + + allocate(b1(2), b2(2,2), b3(2,2,2), b4(2,2,2,2), b5(2,2,2,2,2)) + allocate(b6(2,2,2,2,2,2), b7(2,2,2,2,2,2,2)) + + b1 = 1. ; b2 = 2. ; b3 = 3. ; b4 = 4. ; b5 = 5. ; b6 = 6. ; b7 = 7. + + i = 13 + deallocate(b1, stat=i) ; if (i /= 0) STOP 15 + deallocate(b2, stat=i) ; if (i /= 0) STOP 16 + deallocate(b3, stat=i) ; if (i /= 0) STOP 17 + deallocate(b4, stat=i) ; if (i /= 0) STOP 18 + deallocate(b5, stat=i) ; if (i /= 0) STOP 19 + deallocate(b6, stat=i) ; if (i /= 0) STOP 20 + deallocate(b7, stat=i) ; if (i /= 0) STOP 21 + + i = 14 + deallocate(b1, stat=i) ; if (i /= 1) STOP 22 + deallocate(b2, stat=i) ; if (i /= 1) STOP 23 + deallocate(b3, stat=i) ; if (i /= 1) STOP 24 + deallocate(b4, stat=i) ; if (i /= 1) STOP 25 + deallocate(b5, stat=i) ; if (i /= 1) STOP 26 + deallocate(b6, stat=i) ; if (i /= 1) STOP 27 + deallocate(b7, stat=i) ; if (i /= 1) STOP 28 + + + allocate(a1(2), a2(2,2), a3(2,2,2), b4(2,2,2,2), b5(2,2,2,2,2)) + allocate(b6(2,2,2,2,2,2)) + + a1 = 1. ; a2 = 2. ; a3 = 3. ; b4 = 4. ; b5 = 5. ; b6 = 6. + + i = 13 + deallocate(a1, stat=i) ; if (i /= 0) STOP 29 + deallocate(a2, a1, stat=i) ; if (i /= 1) STOP 30 + deallocate(a1, a3, a2, stat=i) ; if (i /= 1) STOP 31 + deallocate(b4, stat=i) ; if (i /= 0) STOP 32 + deallocate(b4, b5, stat=i) ; if (i /= 1) STOP 33 + deallocate(b4, b5, b6, stat=i) ; if (i /= 1) STOP 34 + +end program deallocate_stat diff --git a/Fortran/gfortran/regression/deallocate_stat_2.f90 b/Fortran/gfortran/regression/deallocate_stat_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deallocate_stat_2.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! +! Check that the error is properly diagnosed and the strings are correctly padded. +! +integer, allocatable :: A, B(:) +integer :: stat +character(len=5) :: sstr +character(len=200) :: str + +str = repeat('X', len(str)) +deallocate(a, stat=stat, errmsg=str) +!print *, stat, trim(str) +if (stat == 0 .or. str /= "Attempt to deallocate an unallocated object") STOP 1 + +str = repeat('Y', len(str)) +deallocate(b, stat=stat, errmsg=str) +!print *, stat, trim(str) +if (stat == 0 .or. str /= "Attempt to deallocate an unallocated object") STOP 2 + +sstr = repeat('Q', len(sstr)) +deallocate(a, stat=stat, errmsg=sstr) +!print *, stat, trim(sstr) +if (stat == 0 .or. sstr /= "Attem") STOP 3 + +sstr = repeat('P', len(sstr)) +deallocate(b, stat=stat, errmsg=sstr) +!print *, stat, trim(sstr) +if (stat == 0 .or. sstr /= "Attem") STOP 4 + +end diff --git a/Fortran/gfortran/regression/debug_1.f90 b/Fortran/gfortran/regression/debug_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/debug_1.f90 @@ -0,0 +1,20 @@ +subroutine gfc_debug_bug (n,m,k,ax,bx,c) +! above line must be the first line +! { dg-do compile } +! { dg-options "-g" } +! PR 19195 +! we set line numbers wrongly, which made the compiler choke when emitting +! debug information. + implicit none + integer :: n, m + integer :: k(n+m) + real :: ax(:), bx(n), c(n+m) + + integer :: i + real :: f + + i = k(n) + f = c(n) + f = bx(n) + f = ax(n) +end subroutine gfc_debug_bug diff --git a/Fortran/gfortran/regression/debug_2.f b/Fortran/gfortran/regression/debug_2.f --- /dev/null +++ b/Fortran/gfortran/regression/debug_2.f @@ -0,0 +1,16 @@ +# 1 "debug_2.F" +# 1 "" +# 1 "" +# 1 "debug_2.F" +# 3 "debug_2.inc1" 1 +# 4 "debug_2.inc2" 1 +! The above lines must be present as is. +! PR fortran/34084 +! { dg-do compile } +! { dg-options "-g" } + subroutine foo + end subroutine foo +# 4 "debug_2.inc1" 2 +# 2 "debug_2.F" 2 + program bar + end program bar diff --git a/Fortran/gfortran/regression/dec-comparison-character_1.f90 b/Fortran/gfortran/regression/dec-comparison-character_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec-comparison-character_1.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-options "-fdec" } +! +! Test case contributed by Mark Eggleston +! + +program convert + character(4) :: c = 4HJMAC + if (4HJMAC.ne.4HJMAC) stop 1 + if (4HJMAC.ne."JMAC") stop 2 + if (4HJMAC.eq."JMAN") stop 3 + if ("JMAC".eq.4HJMAN) stop 4 + if ("AAAA".eq.5HAAAAA) stop 5 + if ("BBBBB".eq.5HBBBB ) stop 6 + if (4HJMAC.ne.c) stop 7 + if (c.ne.4HJMAC) stop 8 +end program + diff --git a/Fortran/gfortran/regression/dec-comparison-character_2.f90 b/Fortran/gfortran/regression/dec-comparison-character_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec-comparison-character_2.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-options "-fdec -Wconversion" } +! +! Test case contributed by Mark Eggleston +! + +include "dec-comparison-character_1.f90" + +! { dg-warning "HOLLERITH to CHARACTER" " " { target *-*-* } 8 } +! { dg-warning "HOLLERITH to CHARACTER" " " { target *-*-* } 9 } +! { dg-warning "HOLLERITH to CHARACTER" " " { target *-*-* } 10 } +! { dg-warning "HOLLERITH to CHARACTER" " " { target *-*-* } 11 } +! { dg-warning "HOLLERITH to CHARACTER" " " { target *-*-* } 12 } +! { dg-warning "HOLLERITH to CHARACTER" " " { target *-*-* } 13 } +! { dg-warning "HOLLERITH to CHARACTER" " " { target *-*-* } 14 } +! { dg-warning "HOLLERITH to CHARACTER" " " { target *-*-* } 15 } +! { dg-warning "HOLLERITH to CHARACTER" " " { target *-*-* } 16 } + diff --git a/Fortran/gfortran/regression/dec-comparison-character_3.f90 b/Fortran/gfortran/regression/dec-comparison-character_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec-comparison-character_3.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! +! Test case contributed by Mark Eggleston +! + +include "dec-comparison-character_1.f90" + +! { dg-warning "Legacy Extension: Hollerith constant at" " " { target *-*-* } 8 } +! { dg-warning "Legacy Extension: Hollerith constant at" " " { target *-*-* } 9 } +! { dg-warning "Legacy Extension: Hollerith constant at" " " { target *-*-* } 10 } +! { dg-warning "Legacy Extension: Hollerith constant at" " " { target *-*-* } 11 } +! { dg-warning "Legacy Extension: Hollerith constant at" " " { target *-*-* } 12 } +! { dg-warning "Legacy Extension: Hollerith constant at" " " { target *-*-* } 13 } +! { dg-warning "Legacy Extension: Hollerith constant at" " " { target *-*-* } 14 } +! { dg-warning "Legacy Extension: Hollerith constant at" " " { target *-*-* } 15 } +! { dg-warning "Legacy Extension: Hollerith constant at" " " { target *-*-* } 16 } +! { dg-warning "Extension: Conversion from HOLLERITH to CHARACTER" " " { target *-*-* } 8 } +! { dg-error "Operands of comparison operator" " " { target *-*-* } 9 } +! { dg-error "Operands of comparison operator" " " { target *-*-* } 10 } +! { dg-error "Operands of comparison operator" " " { target *-*-* } 11 } +! { dg-error "Operands of comparison operator" " " { target *-*-* } 12 } +! { dg-error "Operands of comparison operator" " " { target *-*-* } 13 } +! { dg-error "Operands of comparison operator" " " { target *-*-* } 14 } +! { dg-error "Operands of comparison operator" " " { target *-*-* } 15 } +! { dg-error "Operands of comparison operator" " " { target *-*-* } 16 } + diff --git a/Fortran/gfortran/regression/dec-comparison-complex_1.f90 b/Fortran/gfortran/regression/dec-comparison-complex_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec-comparison-complex_1.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! { dg-options "-fdec" } +! +! Test case contributed by Mark Eggleston +! + +program convert + complex(4) :: a + complex(4) :: b + a = 8HABCDABCD + b = transfer("ABCDABCD", b); + ! Hollerith constants + if (a.ne.8HABCDABCD) stop 1 + if (a.eq.8HABCEABCE) stop 2 + if (8HABCDABCD.ne.b) stop 3 + if (8HABCEABCE.eq.b) stop 4 +end program diff --git a/Fortran/gfortran/regression/dec-comparison-complex_2.f90 b/Fortran/gfortran/regression/dec-comparison-complex_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec-comparison-complex_2.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! { dg-options "-fdec -Wconversion" } +! +! Test case contributed by Mark Eggleston +! + +include "dec-comparison-complex_1.f90" + +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 10 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 13 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 14 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 15 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 16 } + diff --git a/Fortran/gfortran/regression/dec-comparison-complex_3.f90 b/Fortran/gfortran/regression/dec-comparison-complex_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec-comparison-complex_3.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! +! Test case contributed by Mark Eggleston +! + +include "dec-comparison-complex_1.f90" + +! { dg-warning "Legacy Extension: Hollerith constant at" " " { target *-*-* } 10 } +! { dg-warning "Legacy Extension: Hollerith constant at" " " { target *-*-* } 13 } +! { dg-warning "Legacy Extension: Hollerith constant at" " " { target *-*-* } 14 } +! { dg-warning "Legacy Extension: Hollerith constant at" " " { target *-*-* } 15 } +! { dg-warning "Legacy Extension: Hollerith constant at" " " { target *-*-* } 16 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 10 } +! { dg-error "Operands of comparison operator" " " { target *-*-* } 13 } +! { dg-error "Operands of comparison operator" " " { target *-*-* } 14 } +! { dg-error "Operands of comparison operator" " " { target *-*-* } 15 } +! { dg-error "Operands of comparison operator" " " { target *-*-* } 16 } + diff --git a/Fortran/gfortran/regression/dec-comparison-int_1.f90 b/Fortran/gfortran/regression/dec-comparison-int_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec-comparison-int_1.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! { dg-options "-fdec" } +! +! Test case contributed by Mark Eggleston +! + +program convert + integer(4) :: a + integer(4) :: b + a = 4HABCD + b = transfer("ABCD", b) + ! Hollerith constants + if (a.ne.4HABCD) stop 1 + if (a.eq.4HABCE) stop 2 + if (4HABCD.ne.b) stop 3 + if (4HABCE.eq.b) stop 4 + if (4HABCE.lt.a) stop 5 + if (a.gt.4HABCE) stop 6 + if (4HABCE.le.a) stop 7 + if (a.ge.4HABCE) stop 8 +end program + diff --git a/Fortran/gfortran/regression/dec-comparison-int_2.f90 b/Fortran/gfortran/regression/dec-comparison-int_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec-comparison-int_2.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-options "-fdec -Wconversion" } +! +! Test case contributed by Mark Eggleston +! + +include "dec-comparison-int_1.f90" + +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 10 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 13 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 14 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 15 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 16 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 17 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 18 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 19 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 20 } + diff --git a/Fortran/gfortran/regression/dec-comparison-int_3.f90 b/Fortran/gfortran/regression/dec-comparison-int_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec-comparison-int_3.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! +! Test case contributed by Mark Eggleston +! + +include "dec-comparison-int_1.f90" + +! { dg-warning "Extension: Hollerith constant at" " " { target *-*-* } 10 } +! { dg-warning "Extension: Hollerith constant at" " " { target *-*-* } 13 } +! { dg-warning "Extension: Hollerith constant at" " " { target *-*-* } 14 } +! { dg-warning "Extension: Hollerith constant at" " " { target *-*-* } 15 } +! { dg-warning "Extension: Hollerith constant at" " " { target *-*-* } 16 } +! { dg-warning "Extension: Hollerith constant at" " " { target *-*-* } 17 } +! { dg-warning "Extension: Hollerith constant at" " " { target *-*-* } 18 } +! { dg-warning "Extension: Hollerith constant at" " " { target *-*-* } 19 } +! { dg-warning "Extension: Hollerith constant at" " " { target *-*-* } 20 } +! { dg-warning "HOLLERITH to INTEGER" " " { target *-*-* } 10 } +! { dg-error "Operands of comparison operator" " " { target *-*-* } 13 } +! { dg-error "Operands of comparison operator" " " { target *-*-* } 14 } +! { dg-error "Operands of comparison operator" " " { target *-*-* } 15 } +! { dg-error "Operands of comparison operator" " " { target *-*-* } 16 } +! { dg-error "Operands of comparison operator" " " { target *-*-* } 17 } +! { dg-error "Operands of comparison operator" " " { target *-*-* } 18 } +! { dg-error "Operands of comparison operator" " " { target *-*-* } 19 } +! { dg-error "Operands of comparison operator" " " { target *-*-* } 20 } + diff --git a/Fortran/gfortran/regression/dec-comparison-real_1.f90 b/Fortran/gfortran/regression/dec-comparison-real_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec-comparison-real_1.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! { dg-options "-fdec" } +! +! Test case contributed by Mark Eggleston +! + +program convert + real(4) :: a + real(4) :: b + a = 4HABCD + b = transfer("ABCD", b) + ! Hollerith constants + if (a.ne.4HABCD) stop 1 + if (a.eq.4HABCE) stop 2 + if (4HABCD.ne.b) stop 3 + if (4HABCE.eq.b) stop 4 + if (4HABCE.lt.a) stop 5 + if (a.gt.4HABCE) stop 6 + if (4HABCE.le.a) stop 7 + if (a.ge.4HABCE) stop 8 +end program + diff --git a/Fortran/gfortran/regression/dec-comparison-real_2.f90 b/Fortran/gfortran/regression/dec-comparison-real_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec-comparison-real_2.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-options "-fdec -Wconversion" } +! +! Test case contributed by Mark Eggleston +! + +include "dec-comparison-real_1.f90" + +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 10 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 13 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 14 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 15 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 16 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 17 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 18 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 19 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 20 } + diff --git a/Fortran/gfortran/regression/dec-comparison-real_3.f90 b/Fortran/gfortran/regression/dec-comparison-real_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec-comparison-real_3.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! +! Test case contributed by Mark Eggleston +! + +include "dec-comparison-real_1.f90" + +! { dg-warning "Legacy Extension: Hollerith constant at" " " { target *-*-* } 10 } +! { dg-warning "Legacy Extension: Hollerith constant at" " " { target *-*-* } 13 } +! { dg-warning "Legacy Extension: Hollerith constant at" " " { target *-*-* } 14 } +! { dg-warning "Legacy Extension: Hollerith constant at" " " { target *-*-* } 15 } +! { dg-warning "Legacy Extension: Hollerith constant at" " " { target *-*-* } 16 } +! { dg-warning "Legacy Extension: Hollerith constant at" " " { target *-*-* } 17 } +! { dg-warning "Legacy Extension: Hollerith constant at" " " { target *-*-* } 18 } +! { dg-warning "Legacy Extension: Hollerith constant at" " " { target *-*-* } 19 } +! { dg-warning "Legacy Extension: Hollerith constant at" " " { target *-*-* } 20 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 10 } +! { dg-error "Operands of comparison operator" " " { target *-*-* } 13 } +! { dg-error "Operands of comparison operator" " " { target *-*-* } 14 } +! { dg-error "Operands of comparison operator" " " { target *-*-* } 15 } +! { dg-error "Operands of comparison operator" " " { target *-*-* } 16 } +! { dg-error "Operands of comparison operator" " " { target *-*-* } 17 } +! { dg-error "Operands of comparison operator" " " { target *-*-* } 18 } +! { dg-error "Operands of comparison operator" " " { target *-*-* } 19 } +! { dg-error "Operands of comparison operator" " " { target *-*-* } 20 } + diff --git a/Fortran/gfortran/regression/dec-comparison.f90 b/Fortran/gfortran/regression/dec-comparison.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec-comparison.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! { dg-options "-fdec" } +! +! Test case contributed by Mark Eggleston +! +! Hollerith constants and character literals are allowed in comparisons, +! check that character variables can not be compared with numeric variables. + +program convert + character(4) :: a = 4hJMAC + integer(4) :: b = "JMAC" + real(4) :: c = "JMAC" + complex(4) :: d = "JMACJMAC" + ! integers + if (a.ne.b) stop 1 ! { dg-error "Operands of comparison" } + if (b.eq.a) stop 2 ! { dg-error "Operands of comparison" } + if (a.ge.b) stop 3 ! { dg-error "Operands of comparison" } + if (b.ge.a) stop 4 ! { dg-error "Operands of comparison" } + if (a.gt.b) stop 5 ! { dg-error "Operands of comparison" } + if (b.gt.a) stop 6 ! { dg-error "Operands of comparison" } + if (a.le.b) stop 3 ! { dg-error "Operands of comparison" } + if (b.le.a) stop 4 ! { dg-error "Operands of comparison" } + if (a.lt.b) stop 5 ! { dg-error "Operands of comparison" } + if (b.lt.a) stop 6 ! { dg-error "Operands of comparison" } + ! reals + if (a.ne.c) stop 7 ! { dg-error "Operands of comparison" } + if (c.eq.a) stop 8 ! { dg-error "Operands of comparison" } + if (a.ge.c) stop 9 ! { dg-error "Operands of comparison" } + if (c.ge.a) stop 10 ! { dg-error "Operands of comparison" } + if (a.gt.c) stop 11 ! { dg-error "Operands of comparison" } + if (c.gt.a) stop 12 ! { dg-error "Operands of comparison" } + if (a.le.c) stop 13 ! { dg-error "Operands of comparison" } + if (c.le.a) stop 14 ! { dg-error "Operands of comparison" } + if (a.lt.c) stop 15 ! { dg-error "Operands of comparison" } + if (c.lt.a) stop 16 ! { dg-error "Operands of comparison" } + ! complexes + a = "JMACJMAC" + if (a.ne.d) stop 17 ! { dg-error "Operands of comparison" } + if (d.eq.a) stop 18 ! { dg-error "Operands of comparison" } +end program diff --git a/Fortran/gfortran/regression/dec_bitwise_ops_1.f90 b/Fortran/gfortran/regression/dec_bitwise_ops_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_bitwise_ops_1.f90 @@ -0,0 +1,106 @@ +! { dg-do run } +! { dg-options "-fdec" } +! +! Runtime tests to verify logical-to-bitwise operations perform as expected +! with -fdec. +! + +subroutine assert(expected, actual, str) + implicit none + character(*), intent(in) :: str + integer, intent(in) :: expected, actual + if (actual .ne. expected) then + write (*, '(A,I4,I4)') str, expected, actual + STOP 1 + endif +end subroutine + +implicit none + +integer expected, expected_expr +integer output_vars, output_const, output_expr +integer op1, op2, mult + +mult = 3 +op1 = 3 +op2 = 5 + +!!!! AND -> IAND + +expected = IAND(op1, op2) +expected_expr = mult*expected + +output_const = 3 .AND. 5 +output_vars = op1 .AND. op2 +output_expr = mult * (op1 .AND. op2) + +call assert(expected, output_vars, "( ) and") +call assert(expected, output_const, "(c) and") +call assert(expected_expr, output_expr, "(x) and") + +!!!! EQV -> NOT IEOR + +expected = NOT(IEOR(op1, op2)) +expected_expr = mult*expected + +output_const = 3 .EQV. 5 +output_vars = op1 .EQV. op2 +output_expr = mult * (op1 .EQV. op2) + +call assert(expected, output_vars, "( ) EQV") +call assert(expected, output_const, "(c) EQV") +call assert(expected_expr, output_expr, "(x) EQV") + +!!!! NEQV -> IEOR + +expected = IEOR(op1, op2) +expected_expr = mult*expected + +output_const = 3 .NEQV. 5 +output_vars = op1 .NEQV. op2 +output_expr = mult * (op1 .NEQV. op2) + +call assert(expected, output_vars, "( ) NEQV") +call assert(expected, output_const, "(c) NEQV") +call assert(expected_expr, output_expr, "(x) NEQV") + +!!!! NOT -> NOT + +expected = NOT(op2) +expected_expr = mult*expected + +output_const = .NOT. 5 +output_vars = .NOT. op2 +output_expr = mult * (.NOT. op2) + +call assert(expected, output_vars, "( ) NOT") +call assert(expected, output_const, "(c) NOT") +call assert(expected_expr, output_expr, "(x) NOT") + +!!!! OR -> IOR + +expected = IOR(op1, op2) +expected_expr = mult*expected + +output_const = 3 .OR. 5 +output_vars = op1 .OR. op2 +output_expr = mult * (op1 .OR. op2) + +call assert(expected, output_vars, "( ) OR") +call assert(expected, output_const, "(c) OR") +call assert(expected_expr, output_expr, "(x) OR") + +!!!! XOR -> IEOR, not to be confused with .XOR. + +expected = IEOR(op1, op2) +expected_expr = mult*expected + +output_const = 3 .XOR. 5 +output_vars = op1 .XOR. op2 +output_expr = mult * (op1 .XOR. op2) + +call assert(expected, output_vars, "( ) XOR") +call assert(expected, output_const, "(c) XOR") +call assert(expected_expr, output_expr, "(x) XOR") + +end diff --git a/Fortran/gfortran/regression/dec_bitwise_ops_2.f90 b/Fortran/gfortran/regression/dec_bitwise_ops_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_bitwise_ops_2.f90 @@ -0,0 +1,155 @@ +! { dg-do run } +! { dg-options "-fdec" } +! +! Runtime tests to verify bitwise ops perform appropriate conversions +! with -fdec. +! + +subroutine assert(expected, actual, str) + implicit none + character(*), intent(in) :: str + integer, intent(in) :: expected, actual(9) + integer :: i + do i=1,9 + if (expected .ne. actual(i)) then + write (*, '(A,I8,I8)') str, expected, actual(i) + STOP 1 + endif + enddo +end subroutine + +implicit none + +logical(1), volatile :: op1_1l +integer(1), volatile :: op1_1, op2_1 + +logical(2), volatile :: op1_2l +integer(2), volatile :: op1_2, op2_2 + +logical(4), volatile :: op1_4l +integer(4), volatile :: op1_4, op2_4 + +integer, volatile :: expect, outs(9) + + +op1_1l = .true. +op1_2l = .true. +op1_4l = .true. +op1_1 = 117_1 +op1_2 = 117_2 +op1_4 = 117_4 +op2_1 = 49_1 +op2_2 = 49_2 +op2_4 = 49_4 + +!!! Explicit integer operands + +expect = IAND(op1_1, op2_1) +outs(1) = op1_1 .AND. op2_1 +outs(2) = op1_1 .AND. op2_2 +outs(3) = op1_1 .AND. op2_4 +outs(4) = op1_2 .AND. op2_1 +outs(5) = op1_2 .AND. op2_2 +outs(6) = op1_2 .AND. op2_4 +outs(7) = op1_4 .AND. op2_1 +outs(8) = op1_4 .AND. op2_2 +outs(9) = op1_4 .AND. op2_4 +call assert(expect, outs, "AND") + +expect = IOR(op1_1, op2_1) +outs(1) = op1_1 .OR. op2_1 +outs(2) = op1_1 .OR. op2_2 +outs(3) = op1_1 .OR. op2_4 +outs(4) = op1_2 .OR. op2_1 +outs(5) = op1_2 .OR. op2_2 +outs(6) = op1_2 .OR. op2_4 +outs(7) = op1_4 .OR. op2_1 +outs(8) = op1_4 .OR. op2_2 +outs(9) = op1_4 .OR. op2_4 + +call assert(expect, outs, "OR") + +expect = NOT(IEOR(op1_1, op2_1)) +outs(1) = op1_1 .EQV. op2_1 +outs(2) = op1_1 .EQV. op2_2 +outs(3) = op1_1 .EQV. op2_4 +outs(4) = op1_2 .EQV. op2_1 +outs(5) = op1_2 .EQV. op2_2 +outs(6) = op1_2 .EQV. op2_4 +outs(7) = op1_4 .EQV. op2_1 +outs(8) = op1_4 .EQV. op2_2 +outs(9) = op1_4 .EQV. op2_4 + +call assert(expect, outs, "EQV") + +expect = IEOR(op1_1, op2_1) +outs(1) = op1_1 .NEQV. op2_1 +outs(2) = op1_1 .NEQV. op2_2 +outs(3) = op1_1 .NEQV. op2_4 +outs(4) = op1_2 .NEQV. op2_1 +outs(5) = op1_2 .NEQV. op2_2 +outs(6) = op1_2 .NEQV. op2_4 +outs(7) = op1_4 .NEQV. op2_1 +outs(8) = op1_4 .NEQV. op2_2 +outs(9) = op1_4 .NEQV. op2_4 + +call assert(expect, outs, "NEQV") + +!!! Logical -> Integer operand conversions +op1_1 = op1_1l +op1_2 = op1_2l +op1_4 = op1_4l + +expect = IAND(op1_1, op2_1) +outs(1) = op1_1l .AND. op2_1 ! implicit conversions +outs(2) = op1_1l .AND. op2_2 +outs(3) = op1_1l .AND. op2_4 +outs(4) = op1_2l .AND. op2_1 +outs(5) = op1_2l .AND. op2_2 +outs(6) = op1_2l .AND. op2_4 +outs(7) = op1_4l .AND. op2_1 +outs(8) = op1_4l .AND. op2_2 +outs(9) = op1_4l .AND. op2_4 +call assert(expect, outs, "AND") + +expect = IOR(op1_1, op2_1) +outs(1) = op1_1l .OR. op2_1 ! implicit conversions +outs(2) = op1_1l .OR. op2_2 +outs(3) = op1_1l .OR. op2_4 +outs(4) = op1_2l .OR. op2_1 +outs(5) = op1_2l .OR. op2_2 +outs(6) = op1_2l .OR. op2_4 +outs(7) = op1_4l .OR. op2_1 +outs(8) = op1_4l .OR. op2_2 +outs(9) = op1_4l .OR. op2_4 + +call assert(expect, outs, "OR") + +expect = NOT(IEOR(op1_1, op2_1)) +outs(1) = op1_1l .EQV. op2_1 ! implicit conversions +outs(2) = op1_1l .EQV. op2_2 +outs(3) = op1_1l .EQV. op2_4 +outs(4) = op1_2l .EQV. op2_1 +outs(5) = op1_2l .EQV. op2_2 +outs(6) = op1_2l .EQV. op2_4 +outs(7) = op1_4l .EQV. op2_1 +outs(8) = op1_4l .EQV. op2_2 +outs(9) = op1_4l .EQV. op2_4 + +call assert(expect, outs, "EQV") + +expect = IEOR(op1_1, op2_1) +outs(1) = op1_1l .NEQV. op2_1 ! implicit conversions +outs(2) = op1_1l .NEQV. op2_2 +outs(3) = op1_1l .NEQV. op2_4 +outs(4) = op1_2l .NEQV. op2_1 +outs(5) = op1_2l .NEQV. op2_2 +outs(6) = op1_2l .NEQV. op2_4 +outs(7) = op1_4l .NEQV. op2_1 +outs(8) = op1_4l .NEQV. op2_2 +outs(9) = op1_4l .NEQV. op2_4 + +call assert(expect, outs, "NEQV") + + +end diff --git a/Fortran/gfortran/regression/dec_bitwise_ops_3.f90 b/Fortran/gfortran/regression/dec_bitwise_ops_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_bitwise_ops_3.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! { dg-options "-std=legacy -fdec -fno-dec" } +! +! PR fortran/87919 +! +! Make sure -fno-dec disables bitwise ops and check for the right errors. +! -std=legacy is added to avoid the .XOR. extension warning. +! + +include 'dec_bitwise_ops_1.f90' + +! { dg-error "Operands of logical operator" " " { target *-*-* } 33 } +! { dg-error "Operands of logical operator" " " { target *-*-* } 34 } +! { dg-error "Operands of logical operator" " " { target *-*-* } 35 } +! { dg-error "Operands of logical operator" " " { target *-*-* } 46 } +! { dg-error "Operands of logical operator" " " { target *-*-* } 47 } +! { dg-error "Operands of logical operator" " " { target *-*-* } 48 } +! { dg-error "Operands of logical operator" " " { target *-*-* } 59 } +! { dg-error "Operands of logical operator" " " { target *-*-* } 60 } +! { dg-error "Operands of logical operator" " " { target *-*-* } 61 } +! { dg-error "Operand of .not. operator" " " { target *-*-* } 72 } +! { dg-error "Operand of .not. operator" " " { target *-*-* } 73 } +! { dg-error "Operand of .not. operator" " " { target *-*-* } 74 } +! { dg-error "Operands of logical operator" " " { target *-*-* } 85 } +! { dg-error "Operands of logical operator" " " { target *-*-* } 86 } +! { dg-error "Operands of logical operator" " " { target *-*-* } 87 } +! { dg-error "Operands of logical operator" " " { target *-*-* } 98 } +! { dg-error "Operands of logical operator" " " { target *-*-* } 99 } +! { dg-error "Operands of logical operator" " " { target *-*-* } 100 } diff --git a/Fortran/gfortran/regression/dec_char_conversion_in_assignment_1.f90 b/Fortran/gfortran/regression/dec_char_conversion_in_assignment_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_char_conversion_in_assignment_1.f90 @@ -0,0 +1,61 @@ +! { dg-do run } +! { dg-options "-fdec" } +! +! Modified by Mark Eggleston +! +program test + integer(4) :: a + real(4) :: b + complex(4) :: c + logical(4) :: d + integer(4) :: e + real(4) :: f + complex(4) :: g + logical(4) :: h + + a = '1234' + b = '1234' + c = '12341234' + d = '1234' + e = 4h1234 + f = 4h1234 + g = 8h12341234 + h = 4h1234 + + if (a.ne.e) stop 1 + if (b.ne.f) stop 2 + if (c.ne.g) stop 3 + if (d.neqv.h) stop 4 + + ! padded values + a = '12' + b = '12' + c = '12234' + d = '124' + e = 2h12 + f = 2h12 + g = 5h12234 + h = 3h123 + + if (a.ne.e) stop 5 + if (b.ne.f) stop 6 + if (c.ne.g) stop 7 + if (d.neqv.h) stop 8 + + ! truncated values + a = '123478' + b = '123478' + c = '12341234987' + d = '1234abc' + e = 6h123478 + f = 6h123478 + g = 11h12341234987 + h = 7h1234abc + + if (a.ne.e) stop 5 + if (b.ne.f) stop 6 + if (c.ne.g) stop 7 + if (d.neqv.h) stop 8 + +end program + diff --git a/Fortran/gfortran/regression/dec_char_conversion_in_assignment_2.f90 b/Fortran/gfortran/regression/dec_char_conversion_in_assignment_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_char_conversion_in_assignment_2.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! { dg-options "-fdec -Wconversion" } +! +! Modified by Mark Eggleston +! +include "dec_char_conversion_in_assignment_1.f90" + +! { dg-warning "Nonstandard conversion from CHARACTER" " " { target *-*-* } 16 } +! { dg-warning "Nonstandard conversion from CHARACTER" " " { target *-*-* } 17 } +! { dg-warning "Nonstandard conversion from CHARACTER" " " { target *-*-* } 18 } +! { dg-warning "Nonstandard conversion from CHARACTER" " " { target *-*-* } 19 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 20 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 21 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 22 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 23 } +! { dg-warning "Nonstandard conversion from CHARACTER" " " { target *-*-* } 31 } +! { dg-warning "Nonstandard conversion from CHARACTER" " " { target *-*-* } 32 } +! { dg-warning "Nonstandard conversion from CHARACTER" " " { target *-*-* } 33 } +! { dg-warning "Nonstandard conversion from CHARACTER" " " { target *-*-* } 34 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 35 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 36 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 37 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 38 } +! { dg-warning "Nonstandard conversion from CHARACTER" " " { target *-*-* } 46 } +! { dg-warning "Nonstandard conversion from CHARACTER" " " { target *-*-* } 47 } +! { dg-warning "Nonstandard conversion from CHARACTER" " " { target *-*-* } 48 } +! { dg-warning "Nonstandard conversion from CHARACTER" " " { target *-*-* } 49 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 50 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 51 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 52 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 53 } diff --git a/Fortran/gfortran/regression/dec_char_conversion_in_assignment_3.f90 b/Fortran/gfortran/regression/dec_char_conversion_in_assignment_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_char_conversion_in_assignment_3.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! { dg-options "-fdec-char-conversions" } +! +! Contributeds by Mark Eggleston +! +include "dec_char_conversion_in_assignment_1.f90" + +! { dg-warning "Extension: Conversion from CHARACTER" " " { target *-*-* } 16 } +! { dg-warning "Extension: Conversion from CHARACTER" " " { target *-*-* } 17 } +! { dg-warning "Extension: Conversion from CHARACTER" " " { target *-*-* } 18 } +! { dg-warning "Extension: Conversion from CHARACTER" " " { target *-*-* } 19 } +! { dg-warning "Extension: Hollerith constant" " " { target *-*-* } 20 } +! { dg-warning "Extension: Hollerith constant" " " { target *-*-* } 21 } +! { dg-warning "Extension: Hollerith constant" " " { target *-*-* } 22 } +! { dg-warning "Extension: Hollerith constant" " " { target *-*-* } 23 } +! { dg-warning "Extension: Conversion from HOLLERITH" " " { target *-*-* } 20 } +! { dg-warning "Extension: Conversion from HOLLERITH" " " { target *-*-* } 21 } +! { dg-warning "Extension: Conversion from HOLLERITH" " " { target *-*-* } 22 } +! { dg-warning "Extension: Conversion from HOLLERITH" " " { target *-*-* } 23 } +! { dg-warning "Extension: Conversion from CHARACTER" " " { target *-*-* } 31 } +! { dg-warning "Extension: Conversion from CHARACTER" " " { target *-*-* } 32 } +! { dg-warning "Extension: Conversion from CHARACTER" " " { target *-*-* } 33 } +! { dg-warning "Extension: Conversion from CHARACTER" " " { target *-*-* } 34 } +! { dg-warning "Extension: Hollerith constant" " " { target *-*-* } 35 } +! { dg-warning "Extension: Hollerith constant" " " { target *-*-* } 36 } +! { dg-warning "Extension: Hollerith constant" " " { target *-*-* } 37 } +! { dg-warning "Extension: Hollerith constant" " " { target *-*-* } 38 } +! { dg-warning "Extension: Conversion from HOLLERITH" " " { target *-*-* } 35 } +! { dg-warning "Extension: Conversion from HOLLERITH" " " { target *-*-* } 36 } +! { dg-warning "Extension: Conversion from HOLLERITH" " " { target *-*-* } 37 } +! { dg-warning "Extension: Conversion from HOLLERITH" " " { target *-*-* } 38 } +! { dg-warning "Extension: Conversion from CHARACTER" " " { target *-*-* } 46 } +! { dg-warning "Extension: Conversion from CHARACTER" " " { target *-*-* } 47 } +! { dg-warning "Extension: Conversion from CHARACTER" " " { target *-*-* } 48 } +! { dg-warning "Extension: Conversion from CHARACTER" " " { target *-*-* } 49 } +! { dg-warning "Extension: Hollerith constant" " " { target *-*-* } 50 } +! { dg-warning "Extension: Hollerith constant" " " { target *-*-* } 51 } +! { dg-warning "Extension: Hollerith constant" " " { target *-*-* } 52 } +! { dg-warning "Extension: Hollerith constant" " " { target *-*-* } 53 } +! { dg-warning "Extension: Conversion from HOLLERITH" " " { target *-*-* } 50 } +! { dg-warning "Extension: Conversion from HOLLERITH" " " { target *-*-* } 51 } +! { dg-warning "Extension: Conversion from HOLLERITH" " " { target *-*-* } 52 } +! { dg-warning "Extension: Conversion from HOLLERITH" " " { target *-*-* } 53 } + diff --git a/Fortran/gfortran/regression/dec_char_conversion_in_assignment_4.f90 b/Fortran/gfortran/regression/dec_char_conversion_in_assignment_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_char_conversion_in_assignment_4.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-fdec -fno-dec-char-conversions" } +! +! Modified by Mark Eggleston +! +include "dec_char_conversion_in_assignment_1.f90" + +! { dg-error "Cannot convert" " " { target *-*-* } 16 } +! { dg-error "Cannot convert" " " { target *-*-* } 17 } +! { dg-error "Cannot convert" " " { target *-*-* } 18 } +! { dg-error "Cannot convert" " " { target *-*-* } 19 } +! { dg-error "Cannot convert" " " { target *-*-* } 31 } +! { dg-error "Cannot convert" " " { target *-*-* } 32 } +! { dg-error "Cannot convert" " " { target *-*-* } 33 } +! { dg-error "Cannot convert" " " { target *-*-* } 34 } +! { dg-error "Cannot convert" " " { target *-*-* } 46 } +! { dg-error "Cannot convert" " " { target *-*-* } 47 } +! { dg-error "Cannot convert" " " { target *-*-* } 48 } +! { dg-error "Cannot convert" " " { target *-*-* } 49 } diff --git a/Fortran/gfortran/regression/dec_char_conversion_in_assignment_5.f90 b/Fortran/gfortran/regression/dec_char_conversion_in_assignment_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_char_conversion_in_assignment_5.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-fdec -Wcharacter-truncation" } +! +! Modified by Mark Eggleston +! +include "dec_char_conversion_in_assignment_1.f90" + +! { dg-warning "is truncated in conversion" " " { target *-*-* } 46 } +! { dg-warning "is truncated in conversion" " " { target *-*-* } 47 } +! { dg-warning "is truncated in conversion" " " { target *-*-* } 48 } +! { dg-warning "is truncated in conversion" " " { target *-*-* } 49 } +! { dg-warning "is truncated in conversion" " " { target *-*-* } 50 } +! { dg-warning "is truncated in conversion" " " { target *-*-* } 51 } +! { dg-warning "is truncated in conversion" " " { target *-*-* } 52 } +! { dg-warning "is truncated in conversion" " " { target *-*-* } 53 } + diff --git a/Fortran/gfortran/regression/dec_char_conversion_in_assignment_6.f90 b/Fortran/gfortran/regression/dec_char_conversion_in_assignment_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_char_conversion_in_assignment_6.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! { dg-options "-fdec -Wsurprising" } +! +! Modified by Mark Eggleston +! +include "dec_char_conversion_in_assignment_1.f90" + +! { dg-warning "Assigning value other than 0 or 1 to LOGICAL" " " { target *-*-* } 19 } +! { dg-warning "Assigning value other than 0 or 1 to LOGICAL" " " { target *-*-* } 23 } +! { dg-warning "Assigning value other than 0 or 1 to LOGICAL" " " { target *-*-* } 34 } +! { dg-warning "Assigning value other than 0 or 1 to LOGICAL" " " { target *-*-* } 38 } +! { dg-warning "Assigning value other than 0 or 1 to LOGICAL" " " { target *-*-* } 49 } +! { dg-warning "Assigning value other than 0 or 1 to LOGICAL" " " { target *-*-* } 53 } + diff --git a/Fortran/gfortran/regression/dec_char_conversion_in_assignment_7.f90 b/Fortran/gfortran/regression/dec_char_conversion_in_assignment_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_char_conversion_in_assignment_7.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! { dg-options "-fdec -Wconversion -Wcharacter-truncation" } +! +! Modified by Mark Eggleston +! +program test + integer(4), parameter :: a = '1234' + real(4), parameter :: b = '12' + complex(4), parameter :: c = '12341234' + logical(4), parameter :: d = 'abcd' + integer(4), parameter :: e = 4h1234 + real(4), parameter :: f = 2h12 + complex(4), parameter :: g = 8h12341234 + logical(4), parameter :: h = 4habcd + + if (a.ne.e) stop 1 + if (b.ne.f) stop 2 + if (c.ne.g) stop 3 + if (d.neqv.h) stop 4 +end program + +! { dg-warning "Nonstandard conversion from CHARACTER" " " { target *-*-* } 7 } +! { dg-warning "Nonstandard conversion from CHARACTER" " " { target *-*-* } 8 } +! { dg-warning "Nonstandard conversion from CHARACTER" " " { target *-*-* } 9 } +! { dg-warning "Nonstandard conversion from CHARACTER" " " { target *-*-* } 10 } +! { dg-warning "Conversion from HOLLERITH to INTEGER" " " { target *-*-* } 11 } +! { dg-warning "Conversion from HOLLERITH to REAL" " " { target *-*-* } 12 } +! { dg-warning "Conversion from HOLLERITH to COMPLEX" " " { target *-*-* } 13 } +! { dg-warning "Conversion from HOLLERITH to LOGICAL" " " { target *-*-* } 14 } + diff --git a/Fortran/gfortran/regression/dec_char_conversion_in_assignment_8.f90 b/Fortran/gfortran/regression/dec_char_conversion_in_assignment_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_char_conversion_in_assignment_8.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-fdec" } +! +! Modified by Mark Eggleston +! +program test + integer(4) :: a + real(4) :: b + complex(4) :: c + logical(4) :: d + + a = 4_'1234' ! { dg-error "Cannot convert CHARACTER\\(4,4\\) to" } + b = 4_'12' ! { dg-error "Cannot convert CHARACTER\\(2,4\\) to" } + c = 4_'12341234' ! { dg-error "Cannot convert CHARACTER\\(8,4\\) to" } + d = 4_'abcd' ! { dg-error "Cannot convert CHARACTER\\(4,4\\) to" } +end program + diff --git a/Fortran/gfortran/regression/dec_char_conversion_in_data_1.f90 b/Fortran/gfortran/regression/dec_char_conversion_in_data_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_char_conversion_in_data_1.f90 @@ -0,0 +1,87 @@ +! { dg-do run } +! { dg-options "-fdec" } +! +! Modified by Mark Eggleston +! + +subroutine normal + integer(4) :: a + real(4) :: b + complex(4) :: c + logical(4) :: d + integer(4) :: e + real(4) :: f + complex(4) :: g + logical(4) :: h + + data a / '1234' / + data b / '1234' / + data c / '12341234' / ! double the length for complex + data d / '1234' / + data e / 4h1234 / + data f / 4h1234 / + data g / 8h12341234 / ! double the length for complex + data h / 4h1234 / + + if (a.ne.e) stop 1 + if (b.ne.f) stop 2 + if (c.ne.g) stop 3 + if (d.neqv.h) stop 4 +end subroutine + +subroutine padded + integer(4) :: a + real(4) :: b + complex(4) :: c + logical(4) :: d + integer(4) :: e + real(4) :: f + complex(4) :: g + logical(4) :: h + + data a / '12' / + data b / '12' / + data c / '12334' / + data d / '123' / + data e / 2h12 / + data f / 2h12 / + data g / 5h12334 / + data h / 3h123 / + + if (a.ne.e) stop 5 + if (b.ne.f) stop 6 + if (c.ne.g) stop 7 + if (d.neqv.h) stop 8 +end subroutine + +subroutine truncated + integer(4) :: a + real(4) :: b + complex(4) :: c + logical(4) :: d + integer(4) :: e + real(4) :: f + complex(4) :: g + logical(4) :: h + + data a / '123478' / + data b / '123478' / + data c / '1234123498' / + data d / '12345' / + data e / 6h123478 / + data f / 6h123478 / + data g / 10h1234123498 / + data h / 5h12345 / + + if (a.ne.e) stop 9 + if (b.ne.f) stop 10 + if (c.ne.g) stop 11 + if (d.neqv.h) stop 12 +end subroutine + +program test + call normal + call padded + call truncated +end program + diff --git a/Fortran/gfortran/regression/dec_char_conversion_in_data_2.f90 b/Fortran/gfortran/regression/dec_char_conversion_in_data_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_char_conversion_in_data_2.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! { dg-options "-fdec-char-conversions" } +! +! Modified by Mark Eggleston +! +include "dec_char_conversion_in_data_1.f90" + +! { dg-warning "Legacy Extension: Hollerith constant" " " { target *-*-* } 21 } +! { dg-warning "Legacy Extension: Hollerith constant" " " { target *-*-* } 22 } +! { dg-warning "Legacy Extension: Hollerith constant" " " { target *-*-* } 23 } +! { dg-warning "Legacy Extension: Hollerith constant" " " { target *-*-* } 24 } +! { dg-warning "Legacy Extension: Hollerith constant" " " { target *-*-* } 46 } +! { dg-warning "Legacy Extension: Hollerith constant" " " { target *-*-* } 47 } +! { dg-warning "Legacy Extension: Hollerith constant" " " { target *-*-* } 48 } +! { dg-warning "Legacy Extension: Hollerith constant" " " { target *-*-* } 49 } +! { dg-warning "Legacy Extension: Hollerith constant" " " { target *-*-* } 71 } +! { dg-warning "Legacy Extension: Hollerith constant" " " { target *-*-* } 72 } +! { dg-warning "Legacy Extension: Hollerith constant" " " { target *-*-* } 73 } +! { dg-warning "Legacy Extension: Hollerith constant" " " { target *-*-* } 74 } +! { dg-warning "Extension: Conversion from HOLLERITH" " " { target *-*-* } 21 } +! { dg-warning "Extension: Conversion from HOLLERITH" " " { target *-*-* } 22 } +! { dg-warning "Extension: Conversion from HOLLERITH" " " { target *-*-* } 23 } +! { dg-warning "Extension: Conversion from HOLLERITH" " " { target *-*-* } 24 } +! { dg-warning "Extension: Conversion from HOLLERITH" " " { target *-*-* } 46 } +! { dg-warning "Extension: Conversion from HOLLERITH" " " { target *-*-* } 47 } +! { dg-warning "Extension: Conversion from HOLLERITH" " " { target *-*-* } 48 } +! { dg-warning "Extension: Conversion from HOLLERITH" " " { target *-*-* } 49 } +! { dg-warning "Extension: Conversion from HOLLERITH" " " { target *-*-* } 71 } +! { dg-warning "Extension: Conversion from HOLLERITH" " " { target *-*-* } 72 } +! { dg-warning "Extension: Conversion from HOLLERITH" " " { target *-*-* } 73 } +! { dg-warning "Extension: Conversion from HOLLERITH" " " { target *-*-* } 74 } +! { dg-warning "Extension: Conversion from CHARACTER\\(4\\)" " " { target *-*-* } 17 } +! { dg-warning "Extension: Conversion from CHARACTER\\(4\\)" " " { target *-*-* } 18 } +! { dg-warning "Extension: Conversion from CHARACTER\\(8\\)" " " { target *-*-* } 19 } +! { dg-warning "Extension: Conversion from CHARACTER\\(4\\)" " " { target *-*-* } 20 } +! { dg-warning "Extension: Conversion from CHARACTER\\(2\\)" " " { target *-*-* } 42 } +! { dg-warning "Extension: Conversion from CHARACTER\\(2\\)" " " { target *-*-* } 43 } +! { dg-warning "Extension: Conversion from CHARACTER\\(5\\)" " " { target *-*-* } 44 } +! { dg-warning "Extension: Conversion from CHARACTER\\(3\\)" " " { target *-*-* } 45 } +! { dg-warning "Extension: Conversion from CHARACTER\\(6\\)" " " { target *-*-* } 67 } +! { dg-warning "Extension: Conversion from CHARACTER\\(6\\)" " " { target *-*-* } 68 } +! { dg-warning "Extension: Conversion from CHARACTER\\(10\\)" " " { target *-*-* } 69 } +! { dg-warning "Extension: Conversion from CHARACTER\\(5\\)" " " { target *-*-* } 70 } + + diff --git a/Fortran/gfortran/regression/dec_char_conversion_in_data_3.f90 b/Fortran/gfortran/regression/dec_char_conversion_in_data_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_char_conversion_in_data_3.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-fdec -fno-dec-char-conversions" } +! +! Modified by Mark Eggleston +! +include "dec_char_conversion_in_data_1.f90" + +! { dg-error "Incompatible types" " " { target *-*-* } 17 } +! { dg-error "Incompatible types" " " { target *-*-* } 18 } +! { dg-error "Incompatible types" " " { target *-*-* } 19 } +! { dg-error "Incompatible types" " " { target *-*-* } 20 } +! { dg-error "Incompatible types" " " { target *-*-* } 42 } +! { dg-error "Incompatible types" " " { target *-*-* } 43 } +! { dg-error "Incompatible types" " " { target *-*-* } 44 } +! { dg-error "Incompatible types" " " { target *-*-* } 45 } +! { dg-error "Incompatible types" " " { target *-*-* } 67 } +! { dg-error "Incompatible types" " " { target *-*-* } 68 } +! { dg-error "Incompatible types" " " { target *-*-* } 69 } +! { dg-error "Incompatible types" " " { target *-*-* } 70 } diff --git a/Fortran/gfortran/regression/dec_char_conversion_in_data_4.f90 b/Fortran/gfortran/regression/dec_char_conversion_in_data_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_char_conversion_in_data_4.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! { dg-options "-fdec -Wcharacter-truncation" } +! +! Modified by Mark Eggleston +! +include "dec_char_conversion_in_data_1.f90" + +! { dg-warning "character constant at \\(1\\) is truncated in conversion" " " { target *-*-* } 67 } +! { dg-warning "character constant at \\(1\\) is truncated in conversion" " " { target *-*-* } 68 } +! { dg-warning "character constant at \\(1\\) is truncated in conversion" " " { target *-*-* } 69 } +! { dg-warning "character constant at \\(1\\) is truncated in conversion" " " { target *-*-* } 70 } +! { dg-warning "Hollerith constant at \\(1\\) is truncated in conversion" " " { target *-*-* } 71 } +! { dg-warning "Hollerith constant at \\(1\\) is truncated in conversion" " " { target *-*-* } 72 } +! { dg-warning "Hollerith constant at \\(1\\) is truncated in conversion" " " { target *-*-* } 73 } +! { dg-warning "Hollerith constant at \\(1\\) is truncated in conversion" " " { target *-*-* } 74 } + + diff --git a/Fortran/gfortran/regression/dec_char_conversion_in_data_5.f90 b/Fortran/gfortran/regression/dec_char_conversion_in_data_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_char_conversion_in_data_5.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-fdec -Wsurprising" } +! +! Modified by Mark Eggleston +! +include "dec_char_conversion_in_data_1.f90" + +! { dg-warning "Assigning value other than 0 or 1 to LOGICAL" " " { target *-*-* } 20 } +! { dg-warning "Assigning value other than 0 or 1 to LOGICAL" " " { target *-*-* } 24 } +! { dg-warning "Assigning value other than 0 or 1 to LOGICAL" " " { target *-*-* } 45 } +! { dg-warning "Assigning value other than 0 or 1 to LOGICAL" " " { target *-*-* } 49 } +! { dg-warning "Assigning value other than 0 or 1 to LOGICAL" " " { target *-*-* } 70 } +! { dg-warning "Assigning value other than 0 or 1 to LOGICAL" " " { target *-*-* } 74 } + + diff --git a/Fortran/gfortran/regression/dec_char_conversion_in_data_6.f90 b/Fortran/gfortran/regression/dec_char_conversion_in_data_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_char_conversion_in_data_6.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! { dg-options "-fdec -Wconversion" } +! +! Modified by Mark Eggleston +! +include "dec_char_conversion_in_data_1.f90" + +! { dg-warning "Nonstandard conversion from CHARACTER\\(4\\)" " " { target *-*-* } 17 } +! { dg-warning "Nonstandard conversion from CHARACTER\\(4\\)" " " { target *-*-* } 18 } +! { dg-warning "Nonstandard conversion from CHARACTER\\(8\\)" " " { target *-*-* } 19 } +! { dg-warning "Nonstandard conversion from CHARACTER\\(4\\)" " " { target *-*-* } 20 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 21 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 22 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 23 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 24 } +! { dg-warning "Nonstandard conversion from CHARACTER\\(2\\)" " " { target *-*-* } 42 } +! { dg-warning "Nonstandard conversion from CHARACTER\\(2\\)" " " { target *-*-* } 43 } +! { dg-warning "Nonstandard conversion from CHARACTER\\(5\\)" " " { target *-*-* } 44 } +! { dg-warning "Nonstandard conversion from CHARACTER\\(3\\)" " " { target *-*-* } 45 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 46 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 47 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 48 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 49 } +! { dg-warning "Nonstandard conversion from CHARACTER\\(6\\)" " " { target *-*-* } 67 } +! { dg-warning "Nonstandard conversion from CHARACTER\\(6\\)" " " { target *-*-* } 68 } +! { dg-warning "Nonstandard conversion from CHARACTER\\(10\\)" " " { target *-*-* } 69 } +! { dg-warning "Nonstandard conversion from CHARACTER\\(5\\)" " " { target *-*-* } 70 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 71 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 72 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 73 } +! { dg-warning "Conversion from HOLLERITH" " " { target *-*-* } 74 } + + diff --git a/Fortran/gfortran/regression/dec_char_conversion_in_data_7.f90 b/Fortran/gfortran/regression/dec_char_conversion_in_data_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_char_conversion_in_data_7.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-fdec" } +! +! Modified by Mark Eggleston +! +program test + integer(4) :: a + real(4) :: b + complex(4) :: c + logical(4) :: d + + data a / 4_'1234' / ! { dg-error "attempted conversion of CHARACTER\\(4,4\\)" } + data b / 4_'12' / ! { dg-error "attempted conversion of CHARACTER\\(2,4\\)" } + data c / 4_'12341234' / ! { dg-error "attempted conversion of CHARACTER\\(8,4\\)" } + data d / 4_'abcd' / ! { dg-error "attempted conversion of CHARACTER\\(4,4\\)" } +end program + diff --git a/Fortran/gfortran/regression/dec_d_lines_1.f b/Fortran/gfortran/regression/dec_d_lines_1.f --- /dev/null +++ b/Fortran/gfortran/regression/dec_d_lines_1.f @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-ffixed-form -fd-lines-as-code -fdec" } +! +! Ensure -fd-lines-as-code is not overridden by -fdec. +! + i = 0 +d end + subroutine s +D end diff --git a/Fortran/gfortran/regression/dec_d_lines_2.f b/Fortran/gfortran/regression/dec_d_lines_2.f --- /dev/null +++ b/Fortran/gfortran/regression/dec_d_lines_2.f @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "-ffixed-form -fdec" } +! +! Ensure -fd-lines-as-comments is enabled by default with -fdec. +! +d This is a comment. +D This line, too. + end diff --git a/Fortran/gfortran/regression/dec_d_lines_3.f b/Fortran/gfortran/regression/dec_d_lines_3.f --- /dev/null +++ b/Fortran/gfortran/regression/dec_d_lines_3.f @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-ffixed-form -fdec -fno-dec" } +! +! PR fortran/87919 +! +! Ensure -fno-dec disables -fdec, leaving d-lines as code by default. +! + +include 'dec_d_lines_2.f' + +! { dg-error "character in statement label" " " { target *-*-* } 6 } +! { dg-error "character in statement label" " " { target *-*-* } 7 } diff --git a/Fortran/gfortran/regression/dec_exp_1.f90 b/Fortran/gfortran/regression/dec_exp_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_exp_1.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! { dg-options "-fdec" } +! +! Test support for providing a default exponent of zero when unspecified in +! real constants with -fdec. +! + +subroutine asserteq (rexp, ract, msg) + real, intent(in) :: rexp, ract + character(*), intent(in) :: msg + if (rexp .ne. ract) then + write (*, '(A,F12.6,F12.6)') msg, rexp, ract + STOP 1 + endif +end subroutine + +implicit none + +real, parameter :: r1 = 8e0 +real, parameter :: r2 = 8e ! { equivalent to 8e0 } +real, volatile :: r3, r4 +character(2) :: s +r3 = 8e ! { equivalent to 8e0 } +s = '8e' + +read (s, *) r4 + +call asserteq (r1, r2, "[const]") +call asserteq (r1, r3, "[vol. ]") +call asserteq (r1, r4, "[read ]") + +r4 = 8e + 48e +call asserteq (56e, r4, "[sum ]") + +end diff --git a/Fortran/gfortran/regression/dec_exp_2.f90 b/Fortran/gfortran/regression/dec_exp_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_exp_2.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "" } +! +! Make sure we still see an error for missing exponents without -fdec. +! + +implicit none + +real, parameter :: r1 = 8e ! { dg-error "Missing exponent" } +real, volatile :: r2 +r2 = 8e ! { dg-error "Missing exponent" } + +end diff --git a/Fortran/gfortran/regression/dec_exp_3.f90 b/Fortran/gfortran/regression/dec_exp_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_exp_3.f90 @@ -0,0 +1,15 @@ +! { dg-do run "xfail *-*-*" } +! { dg-options "" } +! +! Make sure we still see an error for missing exponents without -fdec. +! + +implicit none + +real :: r +character(2) :: s +s = '8e' + +read (s, *) r ! { XFAIL "Bad real number" } + +end diff --git a/Fortran/gfortran/regression/dec_exp_4.f90 b/Fortran/gfortran/regression/dec_exp_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_exp_4.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-fdec -fno-dec" } +! +! PR fortran/87919 +! +! Make sure -fno-dec disables -fdec as with dec_exp_2. +! + +include 'dec_exp_2.f90' + +! { dg-error "Missing exponent" "" { target *-*-* } 9 } +! { dg-error "Missing exponent" "" { target *-*-* } 11 } diff --git a/Fortran/gfortran/regression/dec_exp_5.f90 b/Fortran/gfortran/regression/dec_exp_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_exp_5.f90 @@ -0,0 +1,11 @@ +! { dg-do run "xfail *-*-*" } +! { dg-options "-fdec -fno-dec" } +! +! PR fortran/87919 +! +! Make sure -fno-dec disables -fdec as with dec_exp_3. +! + +include 'dec_exp_3.f90' + +! { XFAIL "Bad real number" "" { target *-*-* } 13 } diff --git a/Fortran/gfortran/regression/dec_format_empty_item_1.f b/Fortran/gfortran/regression/dec_format_empty_item_1.f --- /dev/null +++ b/Fortran/gfortran/regression/dec_format_empty_item_1.f @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-options "-fdec" } +! +! Test blank/empty format items in format string +! +! Test case contributed by Jim MacArthur +! Modified by Mark Eggleston +! + PROGRAM blank_format_items + INTEGER A/0/ + + OPEN(1, status="scratch") + WRITE(1, 10) 100 + REWIND(1) + READ(1, 10) A + IF (a.NE.100) STOP 1 + PRINT 10, A +10 FORMAT( I5,) + END diff --git a/Fortran/gfortran/regression/dec_format_empty_item_2.f b/Fortran/gfortran/regression/dec_format_empty_item_2.f --- /dev/null +++ b/Fortran/gfortran/regression/dec_format_empty_item_2.f @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-options "-fdec-blank-format-item" } +! +! Test blank/empty format items in format string +! +! Test case contributed by Jim MacArthur +! Modified by Mark Eggleston +! + PROGRAM blank_format_items + INTEGER A/0/ + + OPEN(1, status="scratch") + WRITE(1, 10) 100 + REWIND(1) + READ(1, 10) A + IF (a.NE.100) STOP 1 + PRINT 10, A +10 FORMAT( I5,) + END diff --git a/Fortran/gfortran/regression/dec_format_empty_item_3.f b/Fortran/gfortran/regression/dec_format_empty_item_3.f --- /dev/null +++ b/Fortran/gfortran/regression/dec_format_empty_item_3.f @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-fdec -fno-dec-blank-format-item" } +! +! Test blank/empty format items in format string +! +! Test case contributed by Jim MacArthur +! Modified by Mark Eggleston +! + PROGRAM blank_format_items + INTEGER A/0/ + + OPEN(1, status="scratch") + WRITE(1, 10) 100 ! { dg-error "FORMAT label 10 at" } + REWIND(1) + READ(1, 10) A ! { dg-error "FORMAT label 10 at" } + IF (a.NE.100) STOP 1 + PRINT 10, A ! { dg-error "FORMAT label 10 at" } + 10 FORMAT( I5,) ! { dg-error "Missing item" } + END diff --git a/Fortran/gfortran/regression/dec_init_1.f90 b/Fortran/gfortran/regression/dec_init_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_init_1.f90 @@ -0,0 +1,62 @@ +! { dg-do run } +! { dg-options "-fdec-structure -finit-derived -finit-local-zero" } +! +! Test -finit-derived with DEC structure and union. +! + +subroutine dummy(i1,r1,c1,l1,i2,r2,c2,l2) + implicit none + integer, intent(in) :: i1 + real, intent(in) :: r1 + character, intent(in) :: c1 + logical, intent(in) :: l1 + integer, intent(inout) :: i2 + real, intent(inout) :: r2 + character, intent(inout) :: c2 + logical, intent(inout) :: l2 + print *, i1, i2, l1, l2, ichar(c1), ichar(c2), r1, r2 + if ( i1 .ne. 0 .or. i2 .ne. 0 ) STOP 1 + if ( l1 .or. l2 ) STOP 2 + if ( c1 .ne. achar(0) .or. c2 .ne. achar(0) ) STOP 3 + if ( r1 .ne. 0.0 .or. r2 .ne. 0.0 ) STOP 4 +end subroutine + +structure /s3/ + union + map + integer m11 + real m12 + character m13 + logical m14 + end map + map + logical m21 + character m22 + real m23 + integer m24 + end map + end union +end structure + +structure /s2/ + integer i2 + real r2 + character c2 + logical l2 +end structure + +structure /s1/ + logical l1 + real r1 + character c1 + integer i1 + record /s2/ y +end structure + +record /s1/ x +record /s3/ y + +call dummy (x.i1, x.r1, x.c1, x.l1, x.y.i2, x.y.r2, x.y.c2, x.y.l2) +call dummy (y.m11, y.m12, y.m13, y.m14, y.m24, y.m23, y.m22, y.m21) + +end diff --git a/Fortran/gfortran/regression/dec_init_2.f90 b/Fortran/gfortran/regression/dec_init_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_init_2.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! { dg-options "-fdec-structure -finit-derived -finit-integer=42 -finit-real=nan -finit-logical=true -finit-character=32" } +! { dg-add-options ieee } +! +! Test -finit-derived with DEC structure and union. +! + +subroutine dummy(i1,r1,c1,l1,i2,r2,c2,l2) + implicit none + integer, intent(in) :: i1 + real, intent(in) :: r1 + character, intent(in) :: c1 + logical, intent(in) :: l1 + integer, intent(inout) :: i2 + real, intent(inout) :: r2 + character, intent(inout) :: c2 + logical, intent(inout) :: l2 + print *, i1, i2, l1, l2, ichar(c1), ichar(c2), r1, r2 + if ( i1 .ne. 42 .or. i2 .ne. 42 ) STOP 1 + if ( (.not. l1) .or. (.not. l2) ) STOP 2 + if ( c1 .ne. achar(32) .or. c2 .ne. achar(32) ) STOP 3 + if ( (.not. isnan(r1)) .or. (.not. isnan(r2)) ) STOP 4 +end subroutine + +! Nb. the current implementation decides the -finit-* flags are meaningless +! with components of a union, so we omit the union test here. + +structure /s2/ + integer i2 + real r2 + character c2 + logical l2 +end structure + +structure /s1/ + logical l1 + real r1 + character c1 + integer i1 + record /s2/ y +end structure + +record /s1/ x + +call dummy (x.i1, x.r1, x.c1, x.l1, x.y.i2, x.y.r2, x.y.c2, x.y.l2) + +end diff --git a/Fortran/gfortran/regression/dec_init_3.f90 b/Fortran/gfortran/regression/dec_init_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_init_3.f90 @@ -0,0 +1,59 @@ +! { dg-do run } +! { dg-options "-fdec-structure -finit-derived -finit-local-zero" } +! +! Test -finit-derived with DEC structure and union. +! + +subroutine dummy(i1,r1,c1,l1,i2,r2,c2,l2) + implicit none + integer, intent(in) :: i1 + real, intent(in) :: r1 + character, intent(in) :: c1 + logical, intent(in) :: l1 + integer, intent(inout) :: i2 + real, intent(inout) :: r2 + character, intent(inout) :: c2 + logical, intent(inout) :: l2 + print *, i1, i2, l1, l2, ichar(c1), ichar(c2), r1, r2 + if ( i1 .ne. 0 .or. i2 .ne. 0 ) STOP 1 + if ( l1 .or. l2 ) STOP 2 + if ( c1 .ne. achar(0) .or. c2 .ne. achar(0) ) STOP 3 + if ( r1 .ne. 0.0 .or. r2 .ne. 0.0 ) STOP 4 +end subroutine + +subroutine sub + structure /s1/ + integer i + end structure + + structure /s2/ + union + map + integer m11 + real m12 + character m13 + logical m14 + end map + map + logical m21 + character m22 + real m23 + integer m24 + end map + map + character(32) s + record /s1/ r + end map + end union + end structure + record /s2/ x + call dummy (x.m11, x.m12, x.m13, x.m14, x.m24, x.m23, x.m22, x.m21) + print *, x.r.i + if ( x.r.i .ne. 0 ) then + STOP 5 + endif +end subroutine + +call sub + +end diff --git a/Fortran/gfortran/regression/dec_init_4.f90 b/Fortran/gfortran/regression/dec_init_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_init_4.f90 @@ -0,0 +1,80 @@ +! { dg-do run } +! { dg-options "-fdec-structure -finit-derived -finit-local-zero" } +! +! Test a UNION with explicit initialization and -finit-derived. +! + +subroutine sub + structure /s2/ + integer(4) :: i = 8 + union ! U7 + map + integer(4) :: x = 1600 + integer(4) :: y = 1800 + end map + map + integer(2) a, b, c, d, e, f, g, h + end map + end union + end structure + record /s2/ r2 + + ! Initialized unions + if ( r2.i .ne. 8 ) then + print *, 'structure init' + STOP 1 + endif + + ! Explicit initializations + if ( r2.x .ne. 1600 .or. r2.y .ne. 1800) then + r2.x = r2.y + print *, 'union explicit init' + STOP 2 + endif + + ! Initialization from -finit-derived + if ( r2.h .ne. 0 ) then + r2.h = 135 + print *, 'union default init' + STOP 3 + endif + +end subroutine + +! Initialization expressions +structure /s3/ + integer(4) :: i = 8 + union ! U7 + map + integer(4) :: x = 1600 + integer(4) :: y = 1800 + end map + map + integer(2) a, b, c, d, e + end map + end union +end structure + +record /s3/ r3 + +! Initialized unions +if ( r3.i .ne. 8 ) then + print *, 'structure init' + STOP 4 +endif + +! Explicit initializations +if ( r3.x .ne. 1600 .or. r3.y .ne. 1800) then + r3.x = r3.y + print *, 'union explicit init' + STOP 5 +endif + +! Initialization from -finit-derived +if ( r3.e .ne. 0 ) then + r3.e = 135 + print *, 'union default init' + STOP 6 +endif + +end diff --git a/Fortran/gfortran/regression/dec_intrinsic_ints.f90 b/Fortran/gfortran/regression/dec_intrinsic_ints.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_intrinsic_ints.f90 @@ -0,0 +1,165 @@ +! { dg-do compile } +! { dg-options "-fdec-intrinsic-ints" } +! +! Test B/I/J/K integer intrinsics. +! +program main + +implicit none + +integer*1 :: ab = 9_1, bb = 3_1, cb +integer*2 :: ai = 9_2, bi = 3_2, ci +integer*4 :: aj = 9_4, bj = 3_4, cj +integer*8 :: ak = 9_8, bk = 3_8, ck +integer :: a = 9 , b = 3 , c + +integer*1 :: ib = 9_1, bpos = 3_1 +integer*2 :: ii = 9_2, ipos = 3_2 +integer*4 :: ij = 9_4, jpos = 3_4 +integer*8 :: ik = 9_8, kpos = 3_8 +integer :: i = 9 , pos = 3 + +integer*1 :: ba, bc, bd +integer*2 :: ia, ic, id +integer*4 :: ja, jb, jc, jd +integer*8 :: ka, kb, kc, kd + +logical*1 :: lb +logical*2 :: li +logical*4 :: lj +logical*8 :: lk +logical :: l + +real :: r + +lb = bbtest(ib, bpos) +li = bitest(ii, ipos) +lj = bjtest(ij, jpos) +lk = bktest(ik, kpos) +l = btest(i , pos) + +lb = bbtest(9_1, 3_1) +li = bitest(9_2, 3_2) +lj = bjtest(9_4, 3_4) +lk = bktest(9_8, 3_8) +l = btest(9 , 3 ) + +r = floati(ai) +r = floatj(aj) +r = floatk(ak) +r = float (a ) + +r = floati(9_2) +r = floatj(9_4) +r = floatk(9_8) +r = float (9 ) + +bb = babs(ab) +bi = iiabs(ai) +bj = jiabs(aj) +bk = kiabs(ak) +b = iabs(a ) + +bb = babs(9_1) +bi = iiabs(9_2) +bj = jiabs(9_4) +bk = kiabs(9_8) +b = iabs(9 ) + +cb = biand(ab, bb) +ci = iiand(ai, bi) +cj = jiand(aj, bj) +ck = kiand(ak, bk) +c = iand(a , b ) + +cb = biand(9_1, 3_1) +ci = iiand(9_2, 3_2) +cj = jiand(9_4, 3_4) +ck = kiand(9_8, 3_8) +c = iand(9 , 3 ) + +cb = bbclr(ib, bpos) +ci = iibclr(ii, ipos) +cj = jibclr(ij, jpos) +ck = kibclr(ik, kpos) +c = ibclr(i , pos) + +cb = bbclr(9_1, 3_1) +ci = iibclr(9_2, 3_2) +cj = jibclr(9_4, 3_4) +ck = kibclr(9_8, 3_8) +c = ibclr(i , pos) + +cb = bbset(ib, bpos) +ci = iibset(ii, ipos) +cj = jibset(ij, jpos) +ck = kibset(ik, kpos) +c = ibset(i , pos) + +cb = bbset(9_1, 3_1) +ci = iibset(9_2, 3_2) +cj = jibset(9_4, 3_4) +ck = kibset(9_8, 3_8) +c = ibset(i , pos) + +cb = bieor(ab, bb) +ci = iieor(ai, bi) +cj = jieor(aj, bj) +ck = kieor(ak, bk) +c = ieor(a , b ) + +cb = bieor(9_1, 3_1) +ci = iieor(9_2, 3_2) +cj = jieor(9_4, 3_4) +ck = kieor(9_8, 3_8) +c = ieor(9 , 3 ) + +cb = bior(ab, bb) +ci = iior(ai, bi) +cj = jior(aj, bj) +ck = kior(ak, bk) +c = ior(a , b ) + +cb = bior(9_1, 3_1) +ci = iior(9_2, 3_2) +cj = jior(9_4, 3_4) +ck = kior(9_8, 3_8) +c = ior(9 , 3 ) + +cb = bmod(ab, bb) +ci = imod(ai, bi) +cj = jmod(aj, bj) +ck = kmod(ak, bk) +c = mod(a , b ) + +cb = bmod(9_1, 3_1) +ci = imod(9_2, 3_2) +cj = jmod(9_4, 3_4) +ck = kmod(9_8, 3_8) +c = mod(9 , 3 ) + +ba = bbits(121, 10, 5) +call bmvbits(121_1, 2, 3, ba, 1) +bc = bshftc(ba, 3, 6) +bd = bshft(bc, -3) +ba = bnot(bd) + +ia = iibits(357, 10, 5) +call imvbits(357_2, 8, 3, ia, 1) +ic = iishftc(ia, 3, 6) +id = iishft(ic, -3) +ia = inot(id) + +ja = jibits(357, 10, 5) +call jmvbits(357_4, 8, 3, ja, 1) +jc = jishftc(ja, 3, 6) +jd = jishft(jc, -3) +ja = jnot(jd) + +ka = kibits(357_8, 10_8, 5_8) +call kmvbits(357_8, 8_8, 3_8, ka, 1_8) +kc = kishftc(ka, 3_8, 6_8) +kd = kishft(kc, -3_8) +ka = knot(kd) + +end program diff --git a/Fortran/gfortran/regression/dec_io_1.f90 b/Fortran/gfortran/regression/dec_io_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_io_1.f90 @@ -0,0 +1,101 @@ +! { dg-do run { target fd_truncate } } +! { dg-options "-fdec" } +! +! Run-time tests for values of DEC I/O parameters (doesn't test functionality). +! + +subroutine check_cc (fd, cc) + implicit none + character(*), intent(in) :: cc + integer, intent(in) :: fd + character(20) :: cc_inq + inquire(unit=fd, carriagecontrol=cc_inq) + if (cc_inq .ne. cc) then + print *, '(', fd, ') cc expected ', cc, ' was ', cc_inq + STOP 1 + endif +endsubroutine + +subroutine check_share (fd, share) + implicit none + character(*), intent(in) :: share + integer, intent(in) :: fd + character(20) :: share_inq + inquire(unit=fd, share=share_inq) + if (share_inq .ne. share) then + print *, '(', fd, ') share expected ', share, ' was ', share_inq + STOP 2 + endif +endsubroutine + +subroutine check_action (fd, acc) + implicit none + character(*), intent(in) :: acc + integer, intent(in) :: fd + character(20) acc_inq + inquire(unit=fd, action=acc_inq) + if (acc_inq .ne. acc) then + print *, '(', fd, ') access expected ', acc, ' was ', acc_inq + STOP 3 + endif +endsubroutine + +implicit none + +integer, parameter :: fd=3 +character(*), parameter :: fname = 'dec_io_1.txt' + +!!!! + +open(unit=fd, file=fname, action='WRITE') +call check_cc(fd, 'LIST') +call check_share(fd, 'NODENY') +write (fd,*) 'test' +close(unit=fd) + +!!!! READONLY + +open (unit=fd, file=fname, readonly) +call check_action(fd, 'READ') +close (unit=fd) + +!!!! SHARED / SHARE='DENYNONE' + +open (unit=fd, file=fname, action='read', shared) +call check_share(fd, 'DENYNONE') +close (unit=fd) + +open (unit=fd, file=fname, action='read', share='DENYNONE') +call check_share(fd, 'DENYNONE') +close (unit=fd) + +!!!! NOSHARED / SHARE='DENYRW' + +open (unit=fd, file=fname, action='write', noshared) +call check_share(fd, 'DENYRW') +close (unit=fd) + +open (unit=fd, file=fname, action='write', share='DENYRW') +call check_share(fd, 'DENYRW') +close (unit=fd) + +!!!! CC=FORTRAN + +open(unit=fd, file=fname, action ='WRITE', carriagecontrol='FORTRAN') +call check_cc(fd, 'FORTRAN') +close(unit=fd) + +!!!! CC=LIST + +open(unit=fd, file=fname, action ='WRITE', carriagecontrol='LIST') +call check_cc(fd, 'LIST') +close(unit=fd) + +!!!! CC=NONE + +open(unit=fd, file=fname, action ='WRITE', carriagecontrol='NONE') +call check_cc(fd, 'NONE') +close(unit=fd, status='delete') ! cleanup temp file + + +end diff --git a/Fortran/gfortran/regression/dec_io_2.f90 b/Fortran/gfortran/regression/dec_io_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_io_2.f90 @@ -0,0 +1,104 @@ +! { dg-do run { target { ! { *-*-mingw* } } } } +! { dg-options "-fdec" } +! +! Run-time tests for various carriagecontrol parameters with DEC I/O. +! Ensures the output is as defined. +! + +subroutine write_lines(fd) + implicit none + integer, intent(in) :: fd + write(fd, '(A)') "+ first" + write(fd, '(A)') "-second line" + write(fd, '(A)') "0now you know" + write(fd, '(A)') "1this is the fourth line" + write(fd, '(A)') "$finally we have a new challenger for the final line" + write(fd, '(A)') CHAR(0)//"this is the end" + write(fd, '(A)') " this is a plain old line" +endsubroutine + +subroutine check_cc (cc, fname, expected) + implicit none + ! carraigecontrol type, file name to write to + character(*), intent(in) :: cc, fname + ! expected output + character(*), intent(in) :: expected + + ! read buffer, line number, unit, status + character(len=:), allocatable :: buf + integer :: i, fd, siz + fd = 3 + + ! write lines using carriagecontrol setting + open(unit=fd, file=fname, action='write', carriagecontrol=cc) + call write_lines(fd) + close(unit=fd) + + open(unit=fd, file=fname, action='readwrite', & + form='unformatted', access='stream') + call fseek(fd, 0, 0) + inquire(file=fname, size=siz) + allocate(character(len=siz) :: buf) + read(unit=fd, pos=1) buf + if (buf .ne. expected) then + print *, '=================> ',cc,' <=================' + print *, '***** actual *****' + print *, buf + print *, '***** expected *****' + print *, expected + deallocate(buf) + close(unit=fd) + STOP 1 + else + deallocate(buf) + close(unit=fd, status='delete') + endif +endsubroutine + +implicit none + +character(*), parameter :: fname = 'dec_io_2.txt' + +!! In NONE mode, there are no line breaks between records. +character(*), parameter :: output_ccnone = & + "+ first"//& + "-second line"//& + "0now you know"//& + "1this is the fourth line"//& + "$finally we have a new challenger for the final line"//& + CHAR(0)//"this is the end"//& + " this is a plain old line" + +!! In LIST mode, each record is terminated with a newline. +character(*), parameter :: output_cclist = & + "+ first"//CHAR(10)//& + "-second line"//CHAR(10)//& + "0now you know"//CHAR(10)//& + "1this is the fourth line"//CHAR(10)//& + "$finally we have a new challenger for the final line"//CHAR(10)//& + CHAR(0)//"this is the end"//CHAR(10)//& + " this is a plain old line"//CHAR(10) + +!! In FORTRAN mode, the default record break is CR, and the first character +!! implies the start- and end-of-record formatting. +! '+' Overprinting: CR +! '-' One line feed: NL CR +! '0' Two line feeds: NL NL CR +! '1' Next page: FF CR +! '$' Prompting: NL +!'\0' Overprinting with no advance: +! Other: defaults to Overprinting CR +character(*), parameter :: output_ccfort = ""//& + " first"//CHAR(13)//& + CHAR(10)//"second line"//CHAR(13)//& + CHAR(10)//CHAR(10)//"now you know"//CHAR(13)//& + CHAR(12)//"this is the fourth line"//CHAR(13)//& + CHAR(10)//"finally we have a new challenger for the final line"//& + "this is the end"//& + CHAR(10)//"this is a plain old line"//CHAR(13) + +call check_cc('none', fname, output_ccnone) +call check_cc('list', fname, output_cclist) +call check_cc('fortran', fname, output_ccfort) + +end diff --git a/Fortran/gfortran/regression/dec_io_2a.f90 b/Fortran/gfortran/regression/dec_io_2a.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_io_2a.f90 @@ -0,0 +1,104 @@ +! { dg-do run { target { *-*-mingw* } } } +! { dg-options "-fdec" } +! +! Run-time tests for various carriagecontrol parameters with DEC I/O. +! Ensures the output is as defined. +! + +subroutine write_lines(fd) + implicit none + integer, intent(in) :: fd + write(fd, '(A)') "+ first" + write(fd, '(A)') "-second line" + write(fd, '(A)') "0now you know" + write(fd, '(A)') "1this is the fourth line" + write(fd, '(A)') "$finally we have a new challenger for the final line" + write(fd, '(A)') CHAR(0)//"this is the end" + write(fd, '(A)') " this is a plain old line" +endsubroutine + +subroutine check_cc (cc, fname, expected) + implicit none + ! carraigecontrol type, file name to write to + character(*), intent(in) :: cc, fname + ! expected output + character(*), intent(in) :: expected + + ! read buffer, line number, unit, status + character(len=:), allocatable :: buf + integer :: i, fd, siz + fd = 3 + + ! write lines using carriagecontrol setting + open(unit=fd, file=fname, action='write', carriagecontrol=cc) + call write_lines(fd) + close(unit=fd) + + open(unit=fd, file=fname, action='readwrite', & + form='unformatted', access='stream') + call fseek(fd, 0, 0) + inquire(file=fname, size=siz) + allocate(character(len=siz) :: buf) + read(unit=fd, pos=1) buf + if (buf .ne. expected) then + print *, '=================> ',cc,' <=================' + print *, '***** actual *****' + print *, buf + print *, '***** expected *****' + print *, expected + deallocate(buf) + close(unit=fd) + STOP 1 + else + deallocate(buf) + close(unit=fd, status='delete') + endif +endsubroutine + +implicit none + +character(*), parameter :: fname = 'dec_io_2.txt' + +!! In NONE mode, there are no line breaks between records. +character(*), parameter :: output_ccnone = & + "+ first"//& + "-second line"//& + "0now you know"//& + "1this is the fourth line"//& + "$finally we have a new challenger for the final line"//& + CHAR(0)//"this is the end"//& + " this is a plain old line" + +!! In LIST mode, each record is terminated with a newline. +character(*), parameter :: output_cclist = & + "+ first"//CHAR(13)//CHAR(10)//& + "-second line"//CHAR(13)//CHAR(10)//& + "0now you know"//CHAR(13)//CHAR(10)//& + "1this is the fourth line"//CHAR(13)//CHAR(10)//& + "$finally we have a new challenger for the final line"//CHAR(13)//CHAR(10)//& + CHAR(0)//"this is the end"//CHAR(13)//CHAR(10)//& + " this is a plain old line"//CHAR(13)//CHAR(10) + +!! In FORTRAN mode, the default record break is CR, and the first character +!! implies the start- and end-of-record formatting. +! '+' Overprinting: CR +! '-' One line feed: NL CR +! '0' Two line feeds: NL NL CR +! '1' Next page: FF CR +! '$' Prompting: NL +!'\0' Overprinting with no advance: +! Other: defaults to Overprinting CR +character(*), parameter :: output_ccfort = ""//& + " first"//CHAR(13)//& + CHAR(10)//"second line"//CHAR(13)//& + CHAR(10)//CHAR(10)//"now you know"//CHAR(13)//& + CHAR(12)//"this is the fourth line"//CHAR(13)//& + CHAR(10)//"finally we have a new challenger for the final line"//& + "this is the end"//& + CHAR(10)//"this is a plain old line"//CHAR(13) + +call check_cc('none', fname, output_ccnone) +call check_cc('list', fname, output_cclist) +call check_cc('fortran', fname, output_ccfort) + +end diff --git a/Fortran/gfortran/regression/dec_io_3.f90 b/Fortran/gfortran/regression/dec_io_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_io_3.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "" } +! +! Test compile-time errors for DEC I/O intrinsics without -fdec. +! + +integer :: fd +open (unit=fd, carriagecontrol='cc') ! { dg-error "is a DEC extension" } +open (unit=fd, share='cc') ! { dg-error "is a DEC extension" } +open (unit=fd, shared) ! { dg-error "is a DEC extension" } +open (unit=fd, noshared) ! { dg-error "is a DEC extension" } +open (unit=fd, readonly) ! { dg-error "is a DEC extension" } +close (unit=fd, status='delete') + +end diff --git a/Fortran/gfortran/regression/dec_io_4.f90 b/Fortran/gfortran/regression/dec_io_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_io_4.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-fdec" } +! +! Test compile-time errors for DEC I/O intrinsics with -fdec. +! + +integer :: fd +open (unit=fd, readonly, action='read') ! these are okay +open (unit=fd, action='read', readonly) +open (unit=fd, readonly, action='write') ! { dg-error "ACTION type conflicts" } +open (unit=fd, action='readwrite', readonly) ! { dg-error "ACTION type conflicts" } +open (unit=fd, shared, shared) ! { dg-error "Duplicate SHARE" } +open (unit=fd, noshared, shared) ! { dg-error "Duplicate SHARE" } +open (unit=fd, share='denyrw', share='denynone') ! { dg-error "Duplicate SHARE" } +open (unit=fd, carriagecontrol='fortran', carriagecontrol='none') ! { dg-error "Duplicate CARRIAGECONTROL" } + +end diff --git a/Fortran/gfortran/regression/dec_io_5.f90 b/Fortran/gfortran/regression/dec_io_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_io_5.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-options "-fdec" } +! { dg-shouldfail "ACTION conflicts with READONLY" } +! +! Test that we get a run-time error for opening a READONLY file with +! ACTION='WRITE'. +! + +implicit none + +integer :: fd = 8 +character(*), parameter :: f = "dec_io_5.txt" +character(10), volatile :: c +c = 'write' + +open(unit=fd,file=f,action=c,readonly) + +end +! { dg-output "ACTION conflicts with READONLY" } diff --git a/Fortran/gfortran/regression/dec_io_6.f90 b/Fortran/gfortran/regression/dec_io_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_io_6.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! { dg-options "-fdec" } +! +! Test that we get a run-time warning for close-on-delete with READONLY, +! and that the file is protected from deletion. +! + +implicit none + +integer :: fd = 8 +character(*), parameter :: f = "dec_io_6.txt" +logical :: exists + +open(unit=fd,file=f,action='write') +close(unit=fd) + +open(unit=fd,file=f,action='read',readonly) +close(unit=fd,status='delete') ! { dg-output "file protected by READONLY" } + +inquire(file=f, EXIST=exists) +if (.not. exists) then + print *, 'file was not protected by READONLY!' + STOP 1 +endif + +open(unit=fd,file=f,action='write') +close(unit=fd,status='delete') ! cleanup + +end diff --git a/Fortran/gfortran/regression/dec_io_7.f90 b/Fortran/gfortran/regression/dec_io_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_io_7.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-fdec -fno-dec" } +! +! PR fortran/87919 +! +! Make sure -fno-dec rejects -fdec I/O specifiers as with dec_io_1. +! + +include 'dec_io_1.f90' + +! { dg-error "is a DEC extension" "" { target *-*-* } 12 } +! { dg-error "is a DEC extension" "" { target *-*-* } 24 } +! { dg-error "is a DEC extension" "" { target *-*-* } 58 } +! { dg-error "is a DEC extension" "" { target *-*-* } 64 } +! { dg-error "is a DEC extension" "" { target *-*-* } 68 } +! { dg-error "is a DEC extension" "" { target *-*-* } 74 } +! { dg-error "is a DEC extension" "" { target *-*-* } 78 } +! { dg-error "is a DEC extension" "" { target *-*-* } 84 } +! { dg-error "is a DEC extension" "" { target *-*-* } 90 } +! { dg-error "is a DEC extension" "" { target *-*-* } 96 } diff --git a/Fortran/gfortran/regression/dec_loc_rval_1.f90 b/Fortran/gfortran/regression/dec_loc_rval_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_loc_rval_1.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! Test the usage of %loc as an rvalue. +! +program main +implicit none + +integer :: i, j, k + +i = loc(j) +k = %loc(j) + +if (i .ne. k) then + print *, "bad %loc value" + STOP 1 +endif + +end diff --git a/Fortran/gfortran/regression/dec_loc_rval_2.f90 b/Fortran/gfortran/regression/dec_loc_rval_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_loc_rval_2.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-std=gnu" } +! +! Test warnings for usage of %loc as an rvalue without -std=legacy. +! +program main +implicit none + +integer, volatile :: i, j, k + +i = loc(j) +k = %loc(j) ! { dg-warning "Legacy Extension:" } + +end diff --git a/Fortran/gfortran/regression/dec_loc_rval_3.f03 b/Fortran/gfortran/regression/dec_loc_rval_3.f03 --- /dev/null +++ b/Fortran/gfortran/regression/dec_loc_rval_3.f03 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! Test errors for usage of %loc as an rvalue with a real standard. +! +program main +implicit none + +integer, volatile :: i, j, k + +k = %loc(j) ! { dg-error "Legacy Extension:" } + +end diff --git a/Fortran/gfortran/regression/dec_logical_xor_1.f90 b/Fortran/gfortran/regression/dec_logical_xor_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_logical_xor_1.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! Test logical .XOR. operator. +! + +implicit none + +logical :: in1, in2, neqv_out, lxor_out, truth_table(2) +integer :: i, j, ixor_out, ieor_out + +truth_table(1) = .true. +truth_table(2) = .false. +do i = 1,2 + do j = 1,2 + in1 = truth_table(j) + in2 = truth_table(i) + + ! make sure logical xor works + neqv_out = in1 .neqv. in2 + lxor_out = in1 .xor. in2 + + if ( neqv_out .neqv. lxor_out ) then + print *, "(",in1,in2,") .neqv.: ",neqv_out," .xor.: ",lxor_out + STOP 1 + endif + + ! make sure we didn't break xor() intrinsic + ixor_out = xor(i*7, j*5) + ieor_out = ieor(i*7, j*5) + + if ( ixor_out .ne. ieor_out ) then + print *, "(",in1,in2,") ieor(): ",ieor_out," xor(): ",ixor_out + STOP 2 + endif + + enddo +enddo + +end diff --git a/Fortran/gfortran/regression/dec_logical_xor_2.f90 b/Fortran/gfortran/regression/dec_logical_xor_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_logical_xor_2.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-std=gnu" } +! +! Test warnings for logical .XOR. operator without -std=legacy. +! + +implicit none + +logical, volatile :: in1, in2, xor_out +xor_out = in1 .xor. in2 ! { dg-warning ".XOR. operator" } + +end diff --git a/Fortran/gfortran/regression/dec_logical_xor_3.f03 b/Fortran/gfortran/regression/dec_logical_xor_3.f03 --- /dev/null +++ b/Fortran/gfortran/regression/dec_logical_xor_3.f03 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! Test errors for logical .XOR. operator with a real standard. +! + +implicit none + +logical, volatile :: in1, in2, xor_out +xor_out = in1 .xor. in2 ! { dg-error ".XOR. operator" } + +end diff --git a/Fortran/gfortran/regression/dec_math.f90 b/Fortran/gfortran/regression/dec_math.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_math.f90 @@ -0,0 +1,700 @@ +! { dg-options "-cpp -std=gnu" } +! { dg-do run { xfail i?86-*-freebsd* } } +! +! Test extra math intrinsics formerly offered by -fdec-math, +! now included with -std=gnu or -std=legacy. +! + +module dec_math + + implicit none + + real(4), parameter :: pi_f = 3.14159274_4 + real(8), parameter :: pi_d = 3.1415926535897931_8 +#ifdef __GFC_REAL_10__ + real(10), parameter :: pi_l = 3.1415926535897932383_10 +#endif +#ifdef __GFC_REAL_16__ + real(16), parameter :: pi_q = 3.1415926535897932384626433832795028_16 +#endif + + real(4), parameter :: r2d_f = 180.0_4 / pi_f + real(8), parameter :: r2d_d = 180.0_8 / pi_d +#ifdef __GFC_REAL_10__ + real(10), parameter :: r2d_l = 180.0_10 / pi_l +#endif +#ifdef __GFC_REAL_16__ + real(16), parameter :: r2d_q = 180.0_16 / pi_q +#endif + +contains + + function d2rf(x) + implicit none + real(4), intent(in) :: x + real(4) :: d2rf + d2rf = (x * pi_f) / 180.0_4 + endfunction + + subroutine cmpf(x, f1, f2, tolerance, str) + implicit none + real(4), intent(in) :: x, f1, f2, tolerance + character(len=*), intent(in) :: str + if ( abs(f2 - f1) .gt. tolerance ) then + write (*, '(A,A,F12.6,A,F12.6,F12.6)') str, "(", x, ")", f1, f2 + STOP 1 + endif + endsubroutine + + function d2rd(x) + implicit none + real(8), intent(in) :: x + real(8) :: d2rd + d2rd = (x * pi_d) / 180.0_8 + endfunction + + subroutine cmpd(x, d1, d2, tolerance, str) + implicit none + real(8), intent(in) :: x, d1, d2, tolerance + character(len=*), intent(in) :: str + if ( dabs(d2 - d1) .gt. tolerance ) then + write (*, '(A,A,F18.14,A,F18.14,F18.14)') str, "(", x, ")", d1, d2 + STOP 2 + endif + endsubroutine + +#ifdef __GFC_REAL_10__ + function d2rl(x) + implicit none + real(10), intent(in) :: x + real(10) :: d2rl + d2rl = (x * pi_l) / 180.0_10 + endfunction + + subroutine cmpl(x, f1, f2, tolerance, str) + implicit none + real(10), intent(in) :: x, f1, f2, tolerance + character(len=*), intent(in) :: str + if ( abs(f2 - f1) .gt. tolerance ) then + write (*, '(A,A,F21.17,A,F21.17,F21.17)') str, "(", x, ")", f1, f2 + STOP 1 + endif + endsubroutine +#endif + +#ifdef __GFC_REAL_16__ + function d2rq(x) + implicit none + real(16), intent(in) :: x + real(16) :: d2rq + d2rq = (x * pi_q) / 180.0_16 + endfunction + + subroutine cmpq(x, f1, f2, tolerance, str) + implicit none + real(16), intent(in) :: x, f1, f2, tolerance + character(len=*), intent(in) :: str + if ( abs(f2 - f1) .gt. tolerance ) then + write (*, '(A,A,F34.30,A,F34.30,F34.30)') str, "(", x, ")", f1, f2 + STOP 1 + endif + endsubroutine +#endif + +end module + +use dec_math + +implicit none + +! inputs +real(4) :: f_i1, f_i2 +real(4), volatile :: xf +real(8) :: d_i1, d_i2 +real(8), volatile :: xd +#ifdef __GFC_REAL_10__ +real(10) :: l_i1, l_i2 +real(10), volatile :: xl +#endif +#ifdef __GFC_REAL_16__ +real(16) :: q_i1, q_i2 +real(16), volatile :: xq +#endif + +! expected outputs from (oe) default (oxe) expression +real(4) :: f_oe, f_oxe +real(8) :: d_oe, d_oxe +#ifdef __GFC_REAL_10__ +real(10) :: l_oe, l_oxe +#endif +#ifdef __GFC_REAL_16__ +real(16) :: q_oe, q_oxe +#endif + +! actual outputs from (oa) default (oc) constant (ox) expression +real(4) :: f_oa, f_oc, f_ox +real(8) :: d_oa, d_oc, d_ox +#ifdef __GFC_REAL_10__ +real(10) :: l_oa, l_oc, l_ox +#endif +#ifdef __GFC_REAL_16__ +real(16) :: q_oa, q_oc, q_ox +#endif + +! tolerance of the answer: assert |exp-act| <= tol +! accept loss of ~four decimal places +real(4), parameter :: f_tol = 5e-3_4 +real(8), parameter :: d_tol = 5e-10_8 +#ifdef __GFC_REAL_10__ +real(10), parameter :: l_tol = 5e-15_10 +#endif +#ifdef __GFC_REAL_16__ +real(16), parameter :: q_tol = 5e-20_16 +#endif + +! volatile multiplication factors to test non-constant expressions +xf = 2.0_4 +xd = 2.0_8 +#ifdef __GFC_REAL_10__ +xl = 2.0_10 +#endif +#ifdef __GFC_REAL_16__ +xq = 2.0_16 +#endif + +! Input -- cos(pi/4) +f_i1 = 0.707107_4 +d_i1 = 0.707106781186548_8 +#ifdef __GFC_REAL_10__ +l_i1 = 0.707106781186547573_10 +#endif +#ifdef __GFC_REAL_16__ +q_i1 = 0.707106781186547572737310929369414_16 +#endif + +! Expected -- pi/4 +f_oe = r2d_f * acos (f_i1) +f_oxe = r2d_f * acos (xf * f_i1) +d_oe = r2d_d * acos (d_i1) +d_oxe = r2d_d * acos (xd * d_i1) +#ifdef __GFC_REAL_10__ +l_oe = r2d_l * acos (l_i1) +l_oxe = r2d_l * acos (xl * l_i1) +#endif +#ifdef __GFC_REAL_16__ +q_oe = r2d_q * acos (q_i1) +q_oxe = r2d_q * acos (xq * q_i1) +#endif + +! Actual +f_oa = acosd (f_i1) +f_oc = acosd (0.707107_4) +f_ox = acosd (xf * f_i1) +d_oa = acosd (d_i1) +d_oc = acosd (0.707106781186548_8) +d_ox = acosd (xd * 0.707106781186548_8) +#ifdef __GFC_REAL_10__ +l_oa = acosd (l_i1) +l_oc = acosd (0.707106781186547573_10) +l_ox = acosd (xl * l_i1) +#endif +#ifdef __GFC_REAL_16__ +q_oa = acosd (q_i1) +q_oc = acosd (0.707106781186547572737310929369414_16) +q_ox = acosd (xq * 0.707106781186547572737310929369414_16) +#endif + +call cmpf(f_i1, f_oe, f_oa, f_tol, "( ) facosd") +call cmpf(f_i1, f_oe, f_oc, f_tol, "(c) facosd") +call cmpf(f_i1, f_oxe, f_ox, f_tol, "(x) facosd") +call cmpd(d_i1, d_oe, d_oa, d_tol, "( ) dacosd") +call cmpd(d_i1, d_oe, d_oc, d_tol, "(c) dacosd") +call cmpd(d_i1, d_oxe, d_ox, d_tol, "(x) dacosd") +#ifdef __GFC_REAL_10__ +call cmpl(l_i1, l_oe, l_oa, l_tol, "( ) lacosd") +call cmpl(l_i1, l_oe, l_oc, l_tol, "(c) lacosd") +call cmpl(l_i1, l_oxe, l_ox, l_tol, "(x) lacosd") +#endif +#ifdef __GFC_REAL_16__ +call cmpq(q_i1, q_oe, q_oa, q_tol, "( ) qacosd") +call cmpq(q_i1, q_oe, q_oc, q_tol, "(c) qacosd") +call cmpq(q_i1, q_oxe, q_ox, q_tol, "(x) qacosd") +#endif + +! Input +f_i1 = 60.0_4 +d_i1 = 60.0_8 +#ifdef __GFC_REAL_10__ +l_i1 = 60.0_10 +#endif +#ifdef __GFC_REAL_16__ +q_i1 = 60.0_16 +#endif + +! Expected +f_oe = cos (d2rf(f_i1)) +f_oxe = cos (d2rf(xf * f_i1)) +d_oe = cos (d2rd(d_i1)) +d_oxe = cos (d2rd(xd * d_i1)) +#ifdef __GFC_REAL_10__ +l_oe = cos (d2rl(l_i1)) +l_oxe = cos (d2rl(xl * l_i1)) +#endif +#ifdef __GFC_REAL_16__ +q_oe = cos (d2rq(q_i1)) +q_oxe = cos (d2rq(xq * q_i1)) +#endif + +! Actual +f_oa = cosd (f_i1) +f_oc = cosd (60.0_4) +f_ox = cosd (xf * f_i1) +d_oa = cosd (d_i1) +d_oc = cosd (60.0_8) +d_ox = cosd (xd * d_i1) +#ifdef __GFC_REAL_10__ +l_oa = cosd (l_i1) +l_oc = cosd (60.0_10) +l_ox = cosd (xl * l_i1) +#endif +#ifdef __GFC_REAL_16__ +q_oa = cosd (q_i1) +q_oc = cosd (60.0_16) +q_ox = cosd (xq * q_i1) +#endif + +call cmpf(f_i1, f_oe, f_oa, f_tol, "( ) fcosd") +call cmpf(f_i1, f_oe, f_oc, f_tol, "(c) fcosd") +call cmpf(f_i1, f_oxe, f_ox, f_tol, "(x) fcosd") +call cmpd(d_i1, d_oe, d_oa, d_tol, "( ) dcosd") +call cmpd(d_i1, d_oe, d_oc, d_tol, "(c) dcosd") +call cmpd(d_i1, d_oxe, d_ox, d_tol, "(x) cosd") +#ifdef __GFC_REAL_10__ +call cmpl(l_i1, l_oe, l_oa, l_tol, "( ) lcosd") +call cmpl(l_i1, l_oe, l_oc, l_tol, "(c) lcosd") +call cmpl(l_i1, l_oxe, l_ox, l_tol, "(x) lcosd") +#endif +#ifdef __GFC_REAL_16__ +call cmpq(q_i1, q_oe, q_oa, q_tol, "( ) qcosd") +call cmpq(q_i1, q_oe, q_oc, q_tol, "(c) qcosd") +call cmpq(q_i1, q_oxe, q_ox, q_tol, "(x) qcosd") +#endif + +! Input -- sin(pi/4) +f_i1 = 0.707107_4 +d_i1 = 0.707106781186548_8 +#ifdef __GFC_REAL_10__ +l_i1 = 0.707106781186547573_10 +#endif +#ifdef __GFC_REAL_16__ +q_i1 = 0.707106781186547572737310929369414_16 +#endif + +! Expected -- pi/4 +f_oe = r2d_f * asin (f_i1) +f_oxe = r2d_f * asin (xf * f_i1) +d_oe = r2d_d * asin (d_i1) +d_oxe = r2d_d * asin (xd * d_i1) +#ifdef __GFC_REAL_10__ +l_oe = r2d_l * asin (l_i1) +l_oxe = r2d_l * asin (xl * l_i1) +#endif +#ifdef __GFC_REAL_16__ +q_oe = r2d_q * asin (q_i1) +q_oxe = r2d_q * asin (xq * q_i1) +#endif + +! Actual +f_oa = asind (f_i1) +f_oc = asind (0.707107_4) +f_ox = asind (xf * f_i1) +d_oa = asind (d_i1) +d_oc = asind (0.707106781186548_8) +d_ox = asind (xd * d_i1) +#ifdef __GFC_REAL_10__ +l_oa = asind (l_i1) +l_oc = asind (0.707106781186547573_10) +l_ox = asind (xl * l_i1) +#endif +#ifdef __GFC_REAL_16__ +q_oa = asind (q_i1) +q_oc = asind (0.707106781186547572737310929369414_16) +q_ox = asind (xq * q_i1) +#endif + +call cmpf(f_i1, f_oe, f_oa, f_tol, "( ) fasind") +call cmpf(f_i1, f_oe, f_oc, f_tol, "(c) fasind") +call cmpf(f_i1, f_oxe, f_ox, f_tol, "(x) fasind") +call cmpd(d_i1, d_oe, d_oa, d_tol, "( ) dasind") +call cmpd(d_i1, d_oe, d_oc, d_tol, "(c) dasind") +call cmpd(d_i1, d_oxe, d_ox, d_tol, "(x) asind") +#ifdef __GFC_REAL_10__ +call cmpl(l_i1, l_oe, l_oa, l_tol, "( ) lasind") +call cmpl(l_i1, l_oe, l_oc, l_tol, "(c) lasind") +call cmpl(l_i1, l_oxe, l_ox, l_tol, "(x) lasind") +#endif +#ifdef __GFC_REAL_16__ +call cmpq(q_i1, q_oe, q_oa, q_tol, "( ) qasind") +call cmpq(q_i1, q_oe, q_oc, q_tol, "(c) qasind") +call cmpq(q_i1, q_oxe, q_ox, q_tol, "(x) qasind") +#endif + +! Input +f_i1 = 60.0_4 +d_i1 = 60.0_8 +#ifdef __GFC_REAL_10__ +l_i1 = 60.0_10 +#endif +#ifdef __GFC_REAL_16__ +q_i1 = 60.0_16 +#endif + +! Expected +f_oe = sin (d2rf(f_i1)) +f_oxe = sin (d2rf(xf * f_i1)) +d_oe = sin (d2rd(d_i1)) +d_oxe = sin (d2rd(xd * d_i1)) +#ifdef __GFC_REAL_10__ +l_oe = sin (d2rl(l_i1)) +l_oxe = sin (d2rl(xl * l_i1)) +#endif +#ifdef __GFC_REAL_16__ +q_oe = sin (d2rq(q_i1)) +q_oxe = sin (d2rq(xq * q_i1)) +#endif + +! Actual +f_oa = sind (f_i1) +f_oc = sind (60.0_4) +f_ox = sind (xf * f_i1) +d_oa = sind (d_i1) +d_oc = sind (60.0_8) +d_ox = sind (xd * d_i1) +#ifdef __GFC_REAL_10__ +l_oa = sind (l_i1) +l_oc = sind (60.0_10) +l_ox = sind (xl * l_i1) +#endif +#ifdef __GFC_REAL_16__ +q_oa = sind (q_i1) +q_oc = sind (60.0_16) +q_ox = sind (xq * q_i1) +#endif + +call cmpf(f_i1, f_oe, f_oa, f_tol, "( ) fsind") +call cmpf(f_i1, f_oe, f_oc, f_tol, "(c) fsind") +call cmpf(f_i1, f_oxe, f_ox, f_tol, "(x) fsind") +call cmpd(d_i1, d_oe, d_oa, d_tol, "( ) dsind") +call cmpd(d_i1, d_oe, d_oc, d_tol, "(c) dsind") +call cmpd(d_i1, d_oxe, d_ox, d_tol, "(x) sind") +#ifdef __GFC_REAL_10__ +call cmpl(l_i1, l_oe, l_oa, l_tol, "( ) lsind") +call cmpl(l_i1, l_oe, l_oc, l_tol, "(c) lsind") +call cmpl(l_i1, l_oxe, l_ox, l_tol, "(x) lsind") +#endif +#ifdef __GFC_REAL_16__ +call cmpq(q_i1, q_oe, q_oa, q_tol, "( ) qsind") +call cmpq(q_i1, q_oe, q_oc, q_tol, "(c) qsind") +call cmpq(q_i1, q_oxe, q_ox, q_tol, "(x) qsind") +#endif + +! Input +f_i1 = 1.0_4 +f_i2 = 2.0_4 +d_i1 = 1.0_8 +d_i2 = 2.0_8 +#ifdef __GFC_REAL_10__ +l_i1 = 1.0_10 +l_i2 = 2.0_10 +#endif +#ifdef __GFC_REAL_16__ +q_i1 = 1.0_16 +q_i2 = 2.0_16 +#endif + +! Expected +f_oe = r2d_f * atan2 (f_i1, f_i2) +f_oxe = r2d_f * atan2 (xf * f_i1, f_i2) +d_oe = r2d_d * atan2 (d_i1, d_i2) +d_oxe = r2d_d * atan2 (xd * d_i1, d_i2) +#ifdef __GFC_REAL_10__ +l_oe = r2d_l * atan2 (l_i1, l_i2) +l_oxe = r2d_l * atan2 (xl * l_i1, l_i2) +#endif +#ifdef __GFC_REAL_16__ +q_oe = r2d_q * atan2 (q_i1, q_i2) +q_oxe = r2d_q * atan2 (xq * q_i1, q_i2) +#endif + +! Actual +f_oa = atan2d (f_i1, f_i2) +f_oc = atan2d (1.0_4, 2.0_4) +f_ox = atan2d (xf * f_i1, f_i2) +d_oa = atan2d (d_i1, d_i2) +d_oc = atan2d (1.0_8, 2.0_8) +d_ox = atan2d (xd * d_i1, d_i2) +#ifdef __GFC_REAL_10__ +l_oa = atan2d (l_i1, l_i2) +l_oc = atan2d (1.0_10, 2.0_10) +l_ox = atan2d (xl * l_i1, l_i2) +#endif +#ifdef __GFC_REAL_16__ +q_oa = atan2d (q_i1, q_i2) +q_oc = atan2d (1.0_16, 2.0_16) +q_ox = atan2d (xq * q_i1, q_i2) +#endif + +call cmpf(f_i1, f_oe, f_oa, f_tol, "( ) fatan2d") +call cmpf(f_i1, f_oe, f_oc, f_tol, "(c) fatan2d") +call cmpf(f_i1, f_oxe, f_ox, f_tol, "(x) fatan2d") +call cmpd(d_i1, d_oe, d_oa, d_tol, "( ) datan2d") +call cmpd(d_i1, d_oe, d_oc, d_tol, "(c) datan2d") +call cmpd(d_i1, d_oxe, d_ox, d_tol, "(x) atan2d") +#ifdef __GFC_REAL_10__ +call cmpl(l_i1, l_oe, l_oa, l_tol, "( ) latan2d") +call cmpl(l_i1, l_oe, l_oc, l_tol, "(c) latan2d") +call cmpl(l_i1, l_oxe, l_ox, l_tol, "(x) latan2d") +#endif +#ifdef __GFC_REAL_16__ +call cmpq(q_i1, q_oe, q_oa, q_tol, "( ) qatan2d") +call cmpq(q_i1, q_oe, q_oc, q_tol, "(c) qatan2d") +call cmpq(q_i1, q_oxe, q_ox, q_tol, "(x) qatan2d") +#endif + +! Input +f_i1 = 1.55741_4 +d_i1 = 1.5574077246549_8 +#ifdef __GFC_REAL_10__ +l_i1 = 1.55740772465490229_10 +#endif +#ifdef __GFC_REAL_16__ +q_i1 = 1.55740772465490229237161656783428_16 +#endif + +! Expected +f_oe = r2d_f * atan (f_i1) +f_oxe = r2d_f * atan (xf * f_i1) +d_oe = r2d_d * atan (d_i1) +d_oxe = r2d_d * atan (xd * d_i1) +#ifdef __GFC_REAL_10__ +l_oe = r2d_l * atan (l_i1) +l_oxe = r2d_l * atan (xl * l_i1) +#endif +#ifdef __GFC_REAL_16__ +q_oe = r2d_q * atan (q_i1) +q_oxe = r2d_q * atan (xq * q_i1) +#endif + +! Actual +f_oa = atand (f_i1) +f_oc = atand (1.55741_4) +f_ox = atand (xf * f_i1) +d_oa = atand (d_i1) +d_oc = atand (1.5574077246549_8) +d_ox = atand (xd * d_i1) +#ifdef __GFC_REAL_10__ +l_oa = atand (l_i1) +l_oc = atand (1.55740772465490229_10) +l_ox = atand (xl * l_i1) +#endif +#ifdef __GFC_REAL_16__ +q_oa = atand (q_i1) +q_oc = atand (1.55740772465490229237161656783428_16) +q_ox = atand (xq * q_i1) +#endif + +call cmpf(f_i1, f_oe, f_oa, f_tol, "( ) fatand") +call cmpf(f_i1, f_oe, f_oc, f_tol, "(c) fatand") +call cmpf(f_i1, f_oxe, f_ox, f_tol, "(x) fatand") +call cmpd(d_i1, d_oe, d_oa, d_tol, "( ) datand") +call cmpd(d_i1, d_oe, d_oc, d_tol, "(c) datand") +call cmpd(d_i1, d_oxe, d_ox, d_tol, "(x) atand") +#ifdef __GFC_REAL_10__ +call cmpl(l_i1, l_oe, l_oa, l_tol, "( ) latand") +call cmpl(l_i1, l_oe, l_oc, l_tol, "(c) latand") +call cmpl(l_i1, l_oxe, l_ox, l_tol, "(x) latand") +#endif +#ifdef __GFC_REAL_16__ +call cmpq(q_i1, q_oe, q_oa, q_tol, "( ) qatand") +call cmpq(q_i1, q_oe, q_oc, q_tol, "(c) qatand") +call cmpq(q_i1, q_oxe, q_ox, q_tol, "(x) qatand") +#endif + +! Input +f_i1 = 34.3775_4 +d_i1 = 34.3774677078494_8 +#ifdef __GFC_REAL_10__ +l_i1 = 34.3774677078493909_10 +#endif +#ifdef __GFC_REAL_16__ +q_i1 = 34.3774677078493908766176900826395_16 +#endif + +! Expected +f_oe = 1.0_4/tan (f_i1) +f_oxe = 1.0_4/tan (xf * f_i1) +d_oe = 1.0_8/tan (d_i1) +d_oxe = 1.0_8/tan (xd * d_i1) +#ifdef __GFC_REAL_10__ +l_oe = 1.0_10/tan (l_i1) +l_oxe = 1.0_10/tan (xl * l_i1) +#endif +#ifdef __GFC_REAL_16__ +q_oe = 1.0_16/tan (q_i1) +q_oxe = 1.0_16/tan (xq * q_i1) +#endif + +! Actual +f_oa = cotan (f_i1) +f_oc = cotan (34.3775_4) +f_ox = cotan (xf * f_i1) +d_oa = cotan (d_i1) +d_oc = cotan (34.3774677078494_8) +d_ox = cotan (xd * d_i1) +#ifdef __GFC_REAL_10__ +l_oa = cotan (l_i1) +l_oc = cotan (34.3774677078493909_10) +l_ox = cotan (xl * l_i1) +#endif +#ifdef __GFC_REAL_16__ +q_oa = cotan (q_i1) +q_oc = cotan (34.3774677078493908766176900826395_16) +q_ox = cotan (xq * q_i1) +#endif + +call cmpf(f_i1, f_oe, f_oa, f_tol, "( ) fcotan") +call cmpf(f_i1, f_oe, f_oc, f_tol, "(c) fcotan") +call cmpf(f_i1, f_oxe, f_ox, f_tol, "(x) fcotan") +call cmpd(d_i1, d_oe, d_oa, d_tol, "( ) dcotan") +call cmpd(d_i1, d_oe, d_oc, d_tol, "(c) dcotan") +call cmpd(d_i1, d_oxe, d_ox, d_tol, "(x) cotan") +#ifdef __GFC_REAL_10__ +call cmpl(l_i1, l_oe, l_oa, l_tol, "( ) lcotan") +call cmpl(l_i1, l_oe, l_oc, l_tol, "(c) lcotan") +call cmpl(l_i1, l_oxe, l_ox, l_tol, "(x) lcotan") +#endif +#ifdef __GFC_REAL_16__ +call cmpq(q_i1, q_oe, q_oa, q_tol, "( ) qcotan") +call cmpq(q_i1, q_oe, q_oc, q_tol, "(c) qcotan") +call cmpq(q_i1, q_oxe, q_ox, q_tol, "(x) qcotan") +#endif + +! Input +f_i1 = 0.6_4 +d_i1 = 0.6_8 +#ifdef __GFC_REAL_10__ +l_i1 = 0.6_10 +#endif +#ifdef __GFC_REAL_16__ +q_i1 = 0.6_16 +#endif + +! Expected +f_oe = cotan (d2rf(f_i1)) +f_oxe = cotan (d2rf(xf * f_i1)) +d_oe = cotan (d2rd(d_i1)) +d_oxe = cotan (d2rd(xd * d_i1)) +#ifdef __GFC_REAL_10__ +l_oe = cotan (d2rl(l_i1)) +l_oxe = cotan (d2rl(xl * l_i1)) +#endif +#ifdef __GFC_REAL_16__ +q_oe = cotan (d2rq(q_i1)) +q_oxe = cotan (d2rq(xq * q_i1)) +#endif + +! Actual +f_oa = cotand (f_i1) +f_oc = cotand (0.6_4) +f_ox = cotand (xf * f_i1) +d_oa = cotand (d_i1) +d_oc = cotand (0.6_8) +d_ox = cotand (xd * d_i1) +#ifdef __GFC_REAL_10__ +l_oa = cotand (l_i1) +l_oc = cotand (0.6_10) +l_ox = cotand (xl * l_i1) +#endif +#ifdef __GFC_REAL_16__ +q_oa = cotand (q_i1) +q_oc = cotand (0.6_16) +q_ox = cotand (xq * q_i1) +#endif + +call cmpf(f_i1, f_oe, f_oa, f_tol, "( ) fcotand") +call cmpf(f_i1, f_oe, f_oc, f_tol, "(c) fcotand") +call cmpf(f_i1, f_oxe, f_ox, f_tol, "(x) fcotand") +call cmpd(d_i1, d_oe, d_oa, d_tol, "( ) dcotand") +call cmpd(d_i1, d_oe, d_oc, d_tol, "(c) dcotand") +call cmpd(d_i1, d_oxe, d_ox, d_tol, "(x) cotand") +#ifdef __GFC_REAL_10__ +call cmpl(l_i1, l_oe, l_oa, l_tol, "( ) lcotand") +call cmpl(l_i1, l_oe, l_oc, l_tol, "(c) lcotand") +call cmpl(l_i1, l_oxe, l_ox, l_tol, "(x) lcotand") +#endif +#ifdef __GFC_REAL_16__ +call cmpq(q_i1, q_oe, q_oa, q_tol, "( ) qcotand") +call cmpq(q_i1, q_oe, q_oc, q_tol, "(c) qcotand") +call cmpq(q_i1, q_oxe, q_ox, q_tol, "(x) qcotand") +#endif + +! Input +f_i1 = 60.0_4 +d_i1 = 60.0_8 +#ifdef __GFC_REAL_10__ +l_i1 = 60.0_10 +#endif +#ifdef __GFC_REAL_16__ +q_i1 = 60.0_16 +#endif + +! Expected +f_oe = tan (d2rf(f_i1)) +f_oxe = tan (d2rf(xf * f_i1)) +d_oe = tan (d2rd(d_i1)) +d_oxe = tan (d2rd(xd * d_i1)) +#ifdef __GFC_REAL_10__ +l_oe = tan (d2rl(l_i1)) +l_oxe = tan (d2rl(xl * l_i1)) +#endif +#ifdef __GFC_REAL_16__ +q_oe = tan (d2rq(q_i1)) +q_oxe = tan (d2rq(xq * q_i1)) +#endif + +! Actual +f_oa = tand (f_i1) +f_oc = tand (60.0_4) +f_ox = tand (xf * f_i1) +d_oa = tand (d_i1) +d_oc = tand (60.0_8) +d_ox = tand (xd * d_i1) +#ifdef __GFC_REAL_10__ +l_oa = tand (l_i1) +l_oc = tand (60.0_10) +l_ox = tand (xl * l_i1) +#endif +#ifdef __GFC_REAL_16__ +q_oa = tand (q_i1) +q_oc = tand (60.0_16) +q_ox = tand (xq * q_i1) +#endif + +call cmpf(f_i1, f_oe, f_oa, f_tol, "( ) ftand") +call cmpf(f_i1, f_oe, f_oc, f_tol, "(c) ftand") +call cmpf(f_i1, f_oxe, f_ox, f_tol, "(x) ftand") +call cmpd(d_i1, d_oe, d_oa, d_tol, "( ) dtand") +call cmpd(d_i1, d_oe, d_oc, d_tol, "(c) dtand") +call cmpd(d_i1, d_oxe, d_ox, d_tol, "(x) dtand") +#ifdef __GFC_REAL_10__ +call cmpl(l_i1, l_oe, l_oa, l_tol, "( ) ltand") +call cmpl(l_i1, l_oe, l_oc, l_tol, "(c) ltand") +call cmpl(l_i1, l_oxe, l_ox, l_tol, "(x) ltand") +#endif +#ifdef __GFC_REAL_16__ +call cmpq(q_i1, q_oe, q_oa, q_tol, "( ) qtand") +call cmpq(q_i1, q_oe, q_oc, q_tol, "(c) qtand") +call cmpq(q_i1, q_oxe, q_ox, q_tol, "(x) qtand") +#endif + +end diff --git a/Fortran/gfortran/regression/dec_math_2.f90 b/Fortran/gfortran/regression/dec_math_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_math_2.f90 @@ -0,0 +1,14 @@ +! { dg-options "-fdec-math" } +! { dg-do compile } +! +! Ensure extra math intrinsics formerly offered by -fdec-math +! are still available with -fdec-math. +! + +print *, sind(0.0) +print *, cosd(0.0) +print *, tand(0.0) +print *, cotan(1.0) +print *, cotand(90.0) + +end diff --git a/Fortran/gfortran/regression/dec_math_3.f90 b/Fortran/gfortran/regression/dec_math_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_math_3.f90 @@ -0,0 +1,8 @@ +! { dg-options "-std=gnu" } +! { dg-do compile } + +! Former ICE when simplifying asind, plus wrong function name in error message +real, parameter :: d = asind(1.1) ! { dg-error "Argument of ASIND at.*must be between -1 and 1" } +print *, d + +end diff --git a/Fortran/gfortran/regression/dec_math_4.f90 b/Fortran/gfortran/regression/dec_math_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_math_4.f90 @@ -0,0 +1,8 @@ +! { dg-options "-std=gnu" } +! { dg-do compile } + +! Former ICE when simplifying complex cotan +complex, parameter :: z = cotan((1., 1.)) +print *, z + +end diff --git a/Fortran/gfortran/regression/dec_math_5.f90 b/Fortran/gfortran/regression/dec_math_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_math_5.f90 @@ -0,0 +1,104 @@ +! { dg-do run } +! { dg-additional-options "-std=gnu" } +! { dg-require-effective-target fortran_real_10 } +! { dg-require-effective-target fortran_real_16 } + +program p + implicit none + integer, parameter :: ep = selected_real_kind (17) ! real(10) + real(4) :: a1, e1 = 1.e-5 + real(8) :: b1, e2 = 1.e-14 + real(ep) :: c1, e3 = 1.e-17 + real(16) :: d1, e4 = 1.e-30 + + a1 = 1; a1 = atand(a1) + b1 = 1; b1 = atand(b1) + c1 = 1; c1 = atand(c1) + d1 = 1; d1 = atand(d1) +! print '(4(F15.11))', a1, b1, c1, d1 + if (abs(a1 - 45) > e1) stop 1 + if (abs(b1 - 45) > e2) stop 2 + if (abs(c1 - 45) > e3) stop 3 + if (abs(d1 - 45) > e4) stop 4 + + a1 = 0.5; a1 = asind(a1) + b1 = 0.5; b1 = asind(b1) + c1 = 0.5; c1 = asind(c1) + d1 = 0.5; d1 = asind(d1) + if (abs(a1 - 30) > e1) stop 5 + if (abs(b1 - 30) > e2) stop 6 + if (abs(c1 - 30) > e3) stop 7 + if (abs(d1 - 30) > e4) stop 8 + + a1 = 0.5; a1 = acosd(a1) + b1 = 0.5; b1 = acosd(b1) + c1 = 0.5; c1 = acosd(c1) + d1 = 0.5; d1 = acosd(d1) + if (abs(a1 - 60) > e1) stop 9 + if (abs(b1 - 60) > e2) stop 10 + if (abs(c1 - 60) > e3) stop 11 + if (abs(d1 - 60) > e4) stop 12 + + a1 = 45; a1 = tand(a1) + b1 = 45; b1 = tand(b1) + c1 = 45; c1 = tand(c1) + d1 = 45; d1 = tand(d1) + if (abs(a1 - 1) > e1) stop 13 + if (abs(b1 - 1) > e2) stop 14 + if (abs(c1 - 1) > e3) stop 15 + if (abs(d1 - 1) > e4) stop 16 + + a1 = 60; a1 = tand(a1) + b1 = 60; b1 = tand(b1) + c1 = 60; c1 = tand(c1) + d1 = 60; d1 = tand(d1) + if (abs(a1 - sqrt (3._4) ) > e1) stop 17 + if (abs(b1 - sqrt (3._8) ) > e2) stop 18 + if (abs(c1 - sqrt (3._ep)) > e3) stop 19 + if (abs(d1 - sqrt (3._16)) > e4) stop 20 + + a1 = 45; a1 = cotand(a1) + b1 = 45; b1 = cotand(b1) + c1 = 45; c1 = cotand(c1) + d1 = 45; d1 = cotand(d1) + if (abs(a1 - 1) > e1) stop 21 + if (abs(b1 - 1) > e2) stop 22 + if (abs(c1 - 1) > e3) stop 23 + if (abs(d1 - 1) > e4) stop 24 + + a1 = 30; a1 = cotand(a1) + b1 = 30; b1 = cotand(b1) + c1 = 30; c1 = cotand(c1) + d1 = 30; d1 = cotand(d1) + if (abs(a1 - sqrt (3._4) ) > e1) stop 25 + if (abs(b1 - sqrt (3._8) ) > e2) stop 26 + if (abs(c1 - sqrt (3._ep)) > e3) stop 27 + if (abs(d1 - sqrt (3._16)) > e4) stop 28 + + a1 = 1; a1 = atan2d(a1, a1) + b1 = 1; b1 = atan2d(b1, b1) + c1 = 1; c1 = atan2d(c1, c1) + d1 = 1; d1 = atan2d(d1, d1) + if (abs(a1 - 45) > e1) stop 29 + if (abs(b1 - 45) > e2) stop 30 + if (abs(c1 - 45) > e3) stop 31 + if (abs(d1 - 45) > e4) stop 32 + + a1 = 30; a1 = sind(a1) + b1 = 30; b1 = sind(b1) + c1 = 30; c1 = sind(c1) + d1 = 30; d1 = sind(d1) + if (abs(a1 - 0.5) > e1) stop 33 + if (abs(b1 - 0.5) > e2) stop 34 + if (abs(c1 - 0.5) > e3) stop 35 + if (abs(d1 - 0.5) > e4) stop 36 + + a1 = 60; a1 = cosd(a1) + b1 = 60; b1 = cosd(b1) + c1 = 60; c1 = cosd(c1) + d1 = 60; d1 = cosd(d1) + if (abs(a1 - 0.5) > e1) stop 37 + if (abs(b1 - 0.5) > e2) stop 38 + if (abs(c1 - 0.5) > e3) stop 39 + if (abs(d1 - 0.5) > e4) stop 40 +end program p diff --git a/Fortran/gfortran/regression/dec_parameter_1.f b/Fortran/gfortran/regression/dec_parameter_1.f --- /dev/null +++ b/Fortran/gfortran/regression/dec_parameter_1.f @@ -0,0 +1,63 @@ + ! { dg-do run } + ! { dg-options "-ffixed-form -std=legacy" } + ! + ! Test DEC-style PARAMETER statements without parentheses in + ! fixed form. + ! + + subroutine sub1(t, x, y) + implicit real(8) (A-H,O-Z) + parameter (pi_1 = 3.141592654d0, f_1 = 3.d08) + parameter pi_2 = 3.141592654d0, f_2 = 3.d08 + ! Note that if the parameter statements above are matched + ! incorrectly as assignments, the below specification + ! statements will be considered out-of-order and we see + ! 'unexpected specification statement'. A PARAMETER + ! statement should still be a specification statement. + + real(8), intent(in) :: t + real(8), intent(out) :: x, y + + real(8), volatile :: two + two = 2.0d0 + x = two * pi_1 * f_1 * t + y = two * pi_2 * f_2 * t + return + end subroutine + + subroutine sub2(t, x, y, z) + implicit none + real(8) :: pi_1, pi_2, f_1, f_2 + parameter (pi_1 = 3.141592654d0, f_1 = 3.d08) + parameter pi_2 = 3.141592654d0, f_2 = 3.d08 + real(8), parameter :: pi_3 = 3.141592654d0, f_3 = 3.d08 + ! Ditto sub1 + + real(8), intent(in) :: t + real(8), intent(out) :: x, y, z + + real(8), volatile :: two + two = 2.0d0 + x = two * pi_1 * f_1 * t + y = two * pi_2 * f_2 * t + z = two * pi_3 * f_3 * t + end subroutine + + implicit none + real(8) :: x1, x2, y1, y2, z2 + real(8), volatile :: t + t = 1.5e-6 + + call sub1(t, x1, y1) + call sub2(t, x2, y2, z2) + + write(*,'(4D18.5)') t, x1, y1 + write(*,'(4D18.5)') t, x2, y2, z2 + + if (x1 .ne. x2 .or. y1 .ne. y2 + & .or. x1 .ne. y1 .or. x2 .ne. y2 + & .or. y2 .ne. z2) then + STOP 1 + endif + + end diff --git a/Fortran/gfortran/regression/dec_parameter_2.f90 b/Fortran/gfortran/regression/dec_parameter_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_parameter_2.f90 @@ -0,0 +1,62 @@ +! { dg-do run } +! { dg-options "-ffree-form -std=legacy" } +! +! Test DEC-style PARAMETER statements without parentheses in free form. +! + +subroutine sub1(t, x, y) + implicit real(8) (A-H,O-Z) + parameter (pi_1 = 3.141592654d0, f_1 = 3.d08) + parameter pi_2 = 3.141592654d0, f_2 = 3.d08 ! legacy PARAMETER + ! Note that if the parameter statements above are matched + ! incorrectly as assignments, the below specification + ! statements will be considered out-of-order and we see + ! 'unexpected specification statement'. A PARAMETER + ! statement should still be a specification statement. + + real(8), intent(in) :: t + real(8), intent(out) :: x, y + + real(8), volatile :: two + two = 2.0d0 + x = two * pi_1 * f_1 * t + y = two * pi_2 * f_2 * t + return +end subroutine + +subroutine sub2(t, x, y, z) + implicit none + real(8) :: pi_1, pi_2, f_1, f_2 + parameter (pi_1 = 3.141592654d0, f_1 = 3.d08) + parameter pi_2 = 3.141592654d0, f_2 = 3.d08 ! legacy PARAMETER + real(8), parameter :: pi_3 = 3.141592654d0, f_3 = 3.d08 + ! Ditto sub1 + + real(8), intent(in) :: t + real(8), intent(out) :: x, y, z + + real(8), volatile :: two + two = 2.0d0 + x = two * pi_1 * f_1 * t + y = two * pi_2 * f_2 * t + z = two * pi_3 * f_3 * t +end subroutine + +implicit none +real(8) :: x1, x2, y1, y2, z2 +real(8), volatile :: t +t = 1.5e-6 + +call sub1(t, x1, y1) +call sub2(t, x2, y2, z2) + +write(*,'(4D18.5)') t, x1, y1 +write(*,'(4D18.5)') t, x2, y2, z2 + +if (x1 .ne. x2 .or. y1 .ne. y2 & + .or. x1 .ne. y1 .or. x2 .ne. y2 & + .or. y2 .ne. z2) then + STOP 1 +endif + +end diff --git a/Fortran/gfortran/regression/dec_parameter_3.f90 b/Fortran/gfortran/regression/dec_parameter_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_parameter_3.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-ffree-form -std=gnu" } +! +! Test warnings for DEC-style PARAMETER statements with std=gnu. +! + +subroutine sub() + implicit real(8) (A-Z) + parameter pi = 3.1415926535d0 ! { dg-warning "Legacy Extension: PARAMETER" } + print *, pi +end subroutine + +end diff --git a/Fortran/gfortran/regression/dec_parameter_4.f90 b/Fortran/gfortran/regression/dec_parameter_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_parameter_4.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-ffree-form -std=f95" } +! +! Test errors for DEC-style PARAMETER statements with a real standard. +! + +subroutine sub() + implicit real(8) (A-Z) + parameter pi = 3.1415926535d0 ! { dg-error "Legacy Extension: PARAMETER" } + print *, pi +end subroutine + +end diff --git a/Fortran/gfortran/regression/dec_static_1.f90 b/Fortran/gfortran/regression/dec_static_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_static_1.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +! { dg-options "-fdec-static -finit-local-zero" } +! +! Test AUTOMATIC and STATIC attributes. +! +subroutine assert(s, i1, i2) + implicit none + integer, intent(in) :: i1, i2 + character(*), intent(in) :: s + if (i1 .ne. i2) then + print *, s, ": expected ", i2, " but was ", i1 + STOP 1 + endif +endsubroutine assert + +function f (x, y) + implicit none + integer f + integer, intent(in) :: x, y + integer :: a ! only a can actually be saved + integer, automatic :: c ! should actually be automatic + save + + ! a should be incremented by x every time and saved + a = a + x + f = a + + ! c should be zeroed every time, therefore equal y + c = c + y + call assert ("f%c", c, y) + return +endfunction + +implicit none +integer :: f + +! Should return static value of a; accumulates x +call assert ("f()", f(1,3), 1) +call assert ("f()", f(1,4), 2) +call assert ("f()", f(1,2), 3) + +end diff --git a/Fortran/gfortran/regression/dec_static_2.f90 b/Fortran/gfortran/regression/dec_static_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_static_2.f90 @@ -0,0 +1,58 @@ +! { dg-do run } +! { dg-options "-fdec-static -fno-automatic -finit-local-zero" } +! +! Test STATIC and AUTOMATIC with -fno-automatic and recursive subroutines. +! +subroutine assert(s, i1, i2) + implicit none + integer, intent(in) :: i1, i2 + character(*), intent(in) :: s + if (i1 .ne. i2) then + print *, s, ": expected ", i2, " but was ", i1 + STOP 1 + endif +endsubroutine + +function f (x) +implicit none + integer f + integer, intent(in) :: x + integer, static :: a ! should be SAVEd + a = a + x ! should increment by x every time + f = a + return +endfunction + +recursive subroutine g (x) +implicit none + integer, intent(in) :: x + integer, automatic :: a ! should be automatic (in recursive) + a = a + x ! should be set to x every time + call assert ("g%a", a, x) +endsubroutine + +subroutine h (x) +implicit none + integer, intent(in) :: x + integer, automatic :: a ! should be automatic (outside recursive) + a = a + x ! should be set to x every time + call assert ("h%a", a, x) +endsubroutine + +implicit none +integer :: f + +! Should return static value of c; accumulates x +call assert ("f()", f(3), 3) +call assert ("f()", f(4), 7) +call assert ("f()", f(2), 9) + +call g(3) +call g(4) +call g(2) + +call h(3) +call h(4) +call h(2) + +end diff --git a/Fortran/gfortran/regression/dec_static_3.f90 b/Fortran/gfortran/regression/dec_static_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_static_3.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "" } +! +! Check errors for use of STATIC/AUTOMATIC without -fdec-static. +! + +subroutine s() + implicit none + integer, automatic :: a ! { dg-error "is a DEC extension" } + integer, static :: b ! { dg-error "is a DEC extension" } + integer, save :: c + + integer :: auto1, auto2, static1, static2, save1, save2 + automatic auto1 ! { dg-error "is a DEC extension" } + automatic :: auto2 ! { dg-error "is a DEC extension" } + static static1 ! { dg-error "is a DEC extension" } + static :: static2 ! { dg-error "is a DEC extension" } + save save1 + save :: save2 +end subroutine diff --git a/Fortran/gfortran/regression/dec_static_4.f90 b/Fortran/gfortran/regression/dec_static_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_static_4.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! { dg-options "-fdec-static" } +! +! Check for conflicts between STATIC/AUTOMATIC and other attributes. +! + +function s(a, b, x, y) result(z) + implicit none + integer, automatic, intent(IN) :: a ! { dg-error "DUMMY attribute conflicts" } + integer, static, intent(IN) :: b ! { dg-error "DUMMY attribute conflicts" } + integer, intent(OUT) :: x, y + automatic :: x ! { dg-error "DUMMY attribute conflicts" } + static :: y ! { dg-error "DUMMY attribute conflicts" } + + automatic ! { dg-error "Expected entity-list in AUTOMATIC statement" } + automatic :: ! { dg-error "Expected entity-list in AUTOMATIC statement" } + static ! { dg-error "Expected entity-list in STATIC statement" } + static :: ! { dg-error "Expected entity-list in STATIC statement" } + + integer, automatic :: auto1, auto2 + integer, static :: static1, static2 + integer :: auto3, static3 + automatic :: auto3 + static :: static3 + + common /c1/ auto1, auto2 ! { dg-error "COMMON attribute conflicts" } + common /c2/ static1, static2 ! { dg-error "COMMON attribute conflicts" } + common /c3/ auto3, static3 ! { dg-error "COMMON attribute conflicts" } + + integer, static :: z ! { dg-error "RESULT attribute conflicts" } + integer, automatic :: z ! { dg-error "RESULT attribute conflicts" } + static :: z ! { dg-error "RESULT attribute conflicts" } + automatic :: z ! { dg-error "RESULT attribute conflicts" } + + integer, static, automatic :: o ! { dg-error "AUTOMATIC attribute conflicts" } + + integer :: a, b, z ! fall-back decls so we don't get "no implicit type" +end diff --git a/Fortran/gfortran/regression/dec_structure_1.f90 b/Fortran/gfortran/regression/dec_structure_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_structure_1.f90 @@ -0,0 +1,56 @@ +! { dg-do run } +! { dg-options "-fdec-structure" } +! +! Basic STRUCTURE test. +! + +subroutine aborts (s) + character(*), intent(in) :: s + print *, s + STOP 1 +end subroutine + +! Basic structure +structure /s1/ ! type s1 + integer i1 + logical l1 + real r1 + character c1 +end structure ! end type s1 + +record /s1/ r1 ! type (s1) r1 +record /s1/ r1_a(3) ! type (s1) r1_a(3) + +! Basic records +r1.i1 = 13579 ! r1%i1 = ... +r1.l1 = .true. +r1.r1 = 13.579 +r1.c1 = 'F' +r1_a(2) = r1 +r1_a(3).r1 = 135.79 + +if (r1.i1 .ne. 13579) then + call aborts("r1.i1") +endif + +if (r1.l1 .neqv. .true.) then + call aborts("r1.l1") +endif + +if (r1.r1 .ne. 13.579) then + call aborts("r1.r1") +endif + +if (r1.c1 .ne. 'F') then + call aborts("r1.c1") +endif + +if (r1_a(2).i1 .ne. 13579) then + call aborts("r1_a(2).i1") +endif + +if (r1_a(3).r1 .ne. 135.79) then + call aborts("r1_a(3).r1") +endif + +end diff --git a/Fortran/gfortran/regression/dec_structure_10.f90 b/Fortran/gfortran/regression/dec_structure_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_structure_10.f90 @@ -0,0 +1,119 @@ +! { dg-do run } +! { dg-options "-fdec-structure" } +! +! Runtime tests for rules governing dot ('.') as a member accessor, including +! voodoo with aliased user-defined vs. intrinsic operators and nested members. +! See gcc/fortran/match.c (gfc_match_member_sep). +! + +module dec_structure_10 + ! Operator overload tests with .ne. and constant member + structure /s1/ + integer i + integer ne + logical b + end structure + + ! Operator overload tests with .eq., .test. and nested members + structure /s2/ + record /s1/ eq + record /s1/ test + record /s1/ and + integer i + end structure + + ! Deep nested access tests + structure /s3/ + record /s2/ r2 + end structure + structure /s4/ + record /s3/ r3 + end structure + structure /s5/ + record /s4/ r4 + end structure + structure /s6/ + record /s5/ r5 + end structure + structure /s7/ + record /s6/ r6 + end structure + + ! Operator overloads to mess with nested member accesses + interface operator (.ne.) + module procedure ne_func + end interface operator (.ne.) + interface operator (.eq.) + module procedure eq_func + end interface operator (.eq.) + interface operator (.test.) + module procedure tstfunc + end interface operator (.test.) + contains + ! ne_func will be called on (x) .ne. (y) + function ne_func (r, i) + integer, intent(in) :: i + type(s1), intent(in) :: r + integer ne_func + ne_func = r%i + i + end function + ! eq_func will be called on (x) .eq. (y) + function eq_func (r, i) + integer, intent(in) :: i + type(s2), intent(in) :: r + integer eq_func + eq_func = r%eq%i + i + end function eq_func + ! tstfunc will be called on (x) .test. (y) + function tstfunc (r, i) + integer, intent(in) :: i + type(s2), intent(in) :: r + integer tstfunc + tstfunc = r%i + i + end function tstfunc +end module + +use dec_structure_10 + +record /s1/ r +record /s2/ struct +record /s7/ r7 +integer i, j +logical l +struct%eq%i = 5 +i = -5 + +! Nested access: struct has a member and which has a member b +l = struct .and. b ! struct%and%b +l = struct .and. b .or. .false. ! (struct%and%b) .or. (.false.) + +! Intrinsic op: r has no member 'ne' +j = r .ne. i ! ne(r, i) +j = (r) .ne. i ! ne(r, i) + +! Intrinsic op; r has a member 'ne' but it is not a record +j = r .ne. i ! ne(r, i) +j = (r) .ne. i ! ne(r, i) + +! Nested access: struct has a member eq which has a member i +j = struct .eq. i ! struct%eq%i +if ( j .ne. struct%eq%i ) STOP 1 + +! User op: struct is compared to i with eq_func +j = (struct) .eq. i ! eq_func(struct, i) -> struct%eq%i + i +if ( j .ne. struct%eq%i + i ) STOP 2 + +! User op: struct has a member test which has a member i, but test is a uop +j = struct .test. i ! tstfunc(struct, i) -> struct%i + i +if ( j .ne. struct%i + i ) STOP 3 + +! User op: struct is compared to i with eq_func +j = (struct) .test. i ! tstfunc(struct, i) -> struct%i + i +if ( j .ne. struct%i + i ) STOP 4 + +! Deep nested access tests +r7.r6.r5.r4.r3.r2.i = 1337 +j = r7.r6.r5.r4.r3.r2.i +if ( j .ne. 1337 ) STOP 5 + +end diff --git a/Fortran/gfortran/regression/dec_structure_11.f90 b/Fortran/gfortran/regression/dec_structure_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_structure_11.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-fdec-structure" } +! +! Tests for what CAN'T be done with dot ('.') as a member accessor. +! + +structure /s1/ + integer eq +end structure + +record /s1/ r +integer i, j, k + +j = i.j ! { dg-error "nonderived-type variable" } +j = r .eq. i ! { dg-error "Operands of comparison" } +j = r.i ! { dg-error "is not a member of" } +j = r. ! { dg-error "Expected structure component or operator name" } +j = .i ! { dg-error "Invalid character in name" } + +end diff --git a/Fortran/gfortran/regression/dec_structure_12.f90 b/Fortran/gfortran/regression/dec_structure_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_structure_12.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-fdec-structure" } +! +! Test a regression where multiple anonymous structures failed to +! receive unique internal names. +! + +implicit none + +structure /s/ + + structure record0 ! (2) + integer i + end structure + + structure record1 ! regression: Type definition was already defined at (2) + real r + end structure + +end structure + +record /s/ var + +var.record0.i = 0 +var.record1.r = 0.0 + +end diff --git a/Fortran/gfortran/regression/dec_structure_13.f90 b/Fortran/gfortran/regression/dec_structure_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_structure_13.f90 @@ -0,0 +1,81 @@ +! { dg-do compile } +! { dg-options "-fdec-structure" } +! +! Verify that the comparisons in gfc_compare_derived_types can correctly +! match nested anonymous subtypes. +! + +subroutine sub0 (u) + structure /t/ + structure sub + integer i + end structure + endstructure + record /t/ u + u.sub.i = 0 +end subroutine sub0 + +subroutine sub1 () + structure /t/ + structure sub + integer i + end structure + endstructure + record /t/ u + + interface + subroutine sub0 (u) ! regression: Interface mismatch.*Type mismatch + structure /t/ + structure sub + integer i + end structure + endstructure + record /t/ u + end subroutine + end interface + + call sub0(u) ! regression: Type mismatch in argument +end subroutine + +subroutine sub2(u) + structure /tu/ + union + map + integer i + end map + map + real r + end map + end union + end structure + record /tu/ u + u.r = 1.0 +end subroutine + +implicit none + +structure /t/ + structure sub + integer i + end structure +endstructure + +structure /tu/ + union + map + integer i + end map + map + real r + end map + end union +end structure + +record /t/ u +record /tu/ u2 + +call sub0(u) ! regression: Type mismatch in argument +call sub1() +call sub2(u2) + +end diff --git a/Fortran/gfortran/regression/dec_structure_14.f90 b/Fortran/gfortran/regression/dec_structure_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_structure_14.f90 @@ -0,0 +1,18 @@ + ! { dg-do compile } + ! { dg-options "-fdec-structure" } + ! + ! Test that structures inside a common block do not require the + ! SEQUENCE attribute, as derived types do. + ! + +common var + +structure /s/ + integer i + integer j + real r +end structure + +record /s/ var + +end diff --git a/Fortran/gfortran/regression/dec_structure_15.f90 b/Fortran/gfortran/regression/dec_structure_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_structure_15.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-options "" } +! +! PR fortran/77584 +! Regression where "structure" and "record" greedily matched a +! declaration-type-spec in a procedure-declaration-statement (R1212). +! +module dec_structure_15 + abstract interface + double precision function structure_() + end function structure_ + end interface + abstract interface + double precision function record_() + end function record_ + end interface +contains + double precision function a() + procedure(structure_), pointer :: b ! regression: Unclassifiable statement + a = 0.0 + end function + double precision function a2() + procedure(record_), pointer :: b ! regression: Unclassifiable statement + a2 = 0.0 + end function +end module diff --git a/Fortran/gfortran/regression/dec_structure_16.f90 b/Fortran/gfortran/regression/dec_structure_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_structure_16.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! { dg-options "-fdec-structure" } +! +! PR fortran/77782 +! +! Test an ICE where a union might be considered equal to a structure, +! causing the union's backend_decl to be replaced with that of the structure. +! + +program p + +structure /s1/ + union + map + integer(4) a + end map + map + real(4) b + end map + end union +end structure + +structure /s2/ + union ! regression: if this union == s1, we ICE in gfc_get_union_type + map + integer(2) x, y + integer(4) z + end map + end union +end structure + +record /s1/ r1 +r1.a = 0 + +end diff --git a/Fortran/gfortran/regression/dec_structure_17.f90 b/Fortran/gfortran/regression/dec_structure_17.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_structure_17.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-fdec-structure" } +! +! PR fortran/78277 +! +! Fix ICE for invalid structure declaration code. +! + +subroutine sub1() + structure /s/ + structure t + integer i + end structure + end structure + record /s/ u + interface + subroutine sub0(u) + structure /s/ + structure t. ! { dg-error "Syntax error in anonymous structure decl" } + integer i + end structure + end structure + record /s/ u + end + end interface + call sub0(u) +end diff --git a/Fortran/gfortran/regression/dec_structure_18.f90 b/Fortran/gfortran/regression/dec_structure_18.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_structure_18.f90 @@ -0,0 +1,38 @@ + ! { dg-do run } + ! { dg-options "-fdec-structure -ffixed-form" } + ! + ! Test the %FILL component extension. + ! + implicit none + + structure /s/ + character(2) i + character(2) %fill + character(2) j + end structure + + structure /s2/ + character buf(6) + end structure + + record /s/ x + record /s2/ y + equivalence (x, y) + + x.i = '12' + x.j = '34' + + if (y.buf(1) .ne. '1') then + STOP 1 + endif + if (y.buf(2) .ne. '2') then + STOP 2 + endif + if (y.buf(5) .ne. '3') then + STOP 3 + endif + if (y.buf(6) .ne. '4') then + STOP 4 + endif + + end diff --git a/Fortran/gfortran/regression/dec_structure_19.f90 b/Fortran/gfortran/regression/dec_structure_19.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_structure_19.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! { dg-options "-fdec-structure -ffree-form" } +! +! Test the %FILL component extension. +! +implicit none + +structure /s/ + character(2) i + character(2) %fill + character(2) j +end structure + +structure /s2/ + character buf(6) +end structure + +record /s/ x +record /s2/ y +equivalence (x, y) + +x.i = "12" +x.j = "34" + +if (y.buf(1) .ne. '1') then + STOP 1 +endif +if (y.buf(2) .ne. '2') then + STOP 2 +endif +if (y.buf(5) .ne. '3') then + STOP 3 +endif +if (y.buf(6) .ne. '4') then + STOP 4 +endif + +end diff --git a/Fortran/gfortran/regression/dec_structure_2.f90 b/Fortran/gfortran/regression/dec_structure_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_structure_2.f90 @@ -0,0 +1,41 @@ +! { dg-do run } +! { dg-options "-fdec-structure" } +! +! Test STRUCTUREs containin other STRUCTUREs. +! + +subroutine aborts (s) + character(*), intent(in) :: s + print *, s + STOP 1 +end subroutine + +! Basic structure +structure /s1/ + integer i1 + logical l1 + real r1 + character c1 +end structure + +structure /s2/ + integer i + record /s1/ r1 +endstructure + +record /s1/ r1 +record /s2/ r2, r2_a(10) + +! Nested and array records +r2.r1.r1 = 135.79 +r2_a(3).r1.i1 = -13579 + +if (r2.r1.r1 .ne. 135.79) then + call aborts("r1.r1.r1") +endif + +if (r2_a(3).r1.i1 .ne. -13579) then + call aborts("r2_a(3).r1.i1") +endif + +end diff --git a/Fortran/gfortran/regression/dec_structure_20.f90 b/Fortran/gfortran/regression/dec_structure_20.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_structure_20.f90 @@ -0,0 +1,18 @@ + ! { dg-do compile } + ! { dg-options "-fdec-structure" } + ! + ! Test error handling for %FILL + ! + implicit none + + structure /s/ + integer(2) i /3/ + integer(2) %fill /4/ ! { dg-error "cannot have an initializer" } + integer(2), pointer :: %fill ! { dg-error "cannot have attributes" } + end structure + + type t + integer %fill ! { dg-error "not allowed outside STRUCTURE" } + endtype + + end diff --git a/Fortran/gfortran/regression/dec_structure_21.f90 b/Fortran/gfortran/regression/dec_structure_21.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_structure_21.f90 @@ -0,0 +1,10 @@ + ! { dg-do compile } + ! { dg-options "-ffixed-form" } + ! + ! Test errors for %FILL without -fdec-structure. + ! + implicit none + + character(2) %fill ! { dg-error "is a DEC extension" } + + end diff --git a/Fortran/gfortran/regression/dec_structure_22.f90 b/Fortran/gfortran/regression/dec_structure_22.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_structure_22.f90 @@ -0,0 +1,38 @@ + ! { dg-do run } + ! { dg-options "-fdec-structure" } + ! + ! PR fortran/82511 + ! + ! Verify that structure variables with UNION components + ! are accepted in an I/O-list READ. + ! + implicit none + + structure /s/ + union + map + character(16) :: c16_1 + end map + map + character(16) :: c16_2 + end map + end union + end structure + + record /s/ r + character(32) :: instr = "ABCDEFGHIJKLMNOPQRSTUVWXYZ!@#$%^" + + r.c16_1 = ' ' + r.c16_2 = ' ' + ! The record r shall be treated as if its components are listed: + ! read(...) r.c16_1, r.c16_2 + ! This shall correspond to the formatted read of A16,A16 + read(instr, '(A16,A16)') r + + ! r.c16_1 and r.c16_2 are in a union, thus share the same memory + ! and the first 16 bytes of instr are overwritten + if ( r.c16_1 .ne. instr(17:32) .or. r.c16_2 .ne. instr(17:32) ) then + STOP 1 + endif + + end diff --git a/Fortran/gfortran/regression/dec_structure_23.f90 b/Fortran/gfortran/regression/dec_structure_23.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_structure_23.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-fdec-structure" } +! +! PR fortran/78240 +! +! Test a regression where an ICE occurred attempting to create array variables +! with non-constant array-specs in legacy clist initializers. +! +! Error message update with patch for PR fortran/83633 +! +program p + implicit none + integer :: nn + real :: rr + structure /s/ + integer x(n) /1/ ! { dg-error "must be constant of INTEGER type" } + integer xx(nn) /1/ ! { dg-error "array with nonconstant bounds" } + integer xxx(rr) /1.0/ ! { dg-error "must be constant of INTEGER type" } + end structure +end diff --git a/Fortran/gfortran/regression/dec_structure_24.f90 b/Fortran/gfortran/regression/dec_structure_24.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_structure_24.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR fortran/87919 +! +! Should fail to compile without the -fdec or -fdec-structure options. +! +! Contributed by Mark Eggleston + +include 'dec_structure_1.f90' + +! { dg-error "-fdec-structure" " " { target *-*-* } 14 } +! { dg-error "Expecting END PROGRAM" " " { target *-*-* } 19 } +! { dg-error "-fdec-structure" " " { target *-*-* } 21 } +! { dg-error "-fdec-structure" " " { target *-*-* } 22 } +! { dg-error "is not a variable" " " { target *-*-* } 30 } +! { dg-error "Bad character" " " { target *-*-* } 32 } +! { dg-error "Expecting END PROGRAM" " " { target *-*-* } 34 } +! { dg-error "Bad character" " " { target *-*-* } 36 } +! { dg-error "Expecting END PROGRAM" " " { target *-*-* } 38 } +! { dg-error "Bad character" " " { target *-*-* } 40 } +! { dg-error "Expecting END PROGRAM" " " { target *-*-* } 42 } +! { dg-error "Bad character" " " { target *-*-* } 44 } +! { dg-error "Expecting END PROGRAM" " " { target *-*-* } 46 } +! { dg-error "Bad character" " " { target *-*-* } 48 } +! { dg-error "Expecting END PROGRAM" " " { target *-*-* } 50 } +! { dg-error "Bad character" " " { target *-*-* } 52 } +! { dg-error "Expecting END PROGRAM" " " { target *-*-* } 54 } +! { dg-error "function result" " " { target *-*-* } 29 } diff --git a/Fortran/gfortran/regression/dec_structure_25.f90 b/Fortran/gfortran/regression/dec_structure_25.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_structure_25.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! { dg-options "-fdec" } +! +! PR fortran/87919 +! +! Should compile and run with the -fdec option. +! +! Contributed by Mark Eggleston +! + +include 'dec_structure_1.f90' diff --git a/Fortran/gfortran/regression/dec_structure_26.f90 b/Fortran/gfortran/regression/dec_structure_26.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_structure_26.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! { dg-options "-fdec -fno-dec-structure" } +! +! PR fortran/87919 +! +! Should fail to compile with -fdec and -fno-dec-structure. +! +! Contributed by Mark Eggleston +! + +include 'dec_structure_1.f90' + +! { dg-error "-fdec-structure" " " { target *-*-* } 14 } +! { dg-error "Expecting END PROGRAM" " " { target *-*-* } 19 } +! { dg-error "-fdec-structure" " " { target *-*-* } 21 } +! { dg-error "-fdec-structure" " " { target *-*-* } 22 } +! { dg-error "is not a variable" " " { target *-*-* } 30 } +! { dg-error "Bad character" " " { target *-*-* } 32 } +! { dg-error "Expecting END PROGRAM" " " { target *-*-* } 34 } +! { dg-error "Bad character" " " { target *-*-* } 36 } +! { dg-error "Expecting END PROGRAM" " " { target *-*-* } 38 } +! { dg-error "Bad character" " " { target *-*-* } 40 } +! { dg-error "Expecting END PROGRAM" " " { target *-*-* } 42 } +! { dg-error "Bad character" " " { target *-*-* } 44 } +! { dg-error "Expecting END PROGRAM" " " { target *-*-* } 46 } +! { dg-error "Bad character" " " { target *-*-* } 48 } +! { dg-error "Expecting END PROGRAM" " " { target *-*-* } 50 } +! { dg-error "Bad character" " " { target *-*-* } 52 } +! { dg-error "Expecting END PROGRAM" " " { target *-*-* } 54 } +! { dg-error "function result" " " { target *-*-* } 29 } diff --git a/Fortran/gfortran/regression/dec_structure_27.f90 b/Fortran/gfortran/regression/dec_structure_27.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_structure_27.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! { dg-options "-fdec-structure -fno-dec-structure" } +! +! PR fortran/87919 +! +! Should fail to compile with -fdec-structure and -fno-dec-structure. +! +! Contributed by Mark Eggleston +! + +include 'dec_structure_1.f90' + +! { dg-error "-fdec-structure" " " { target *-*-* } 14 } +! { dg-error "Expecting END PROGRAM" " " { target *-*-* } 19 } +! { dg-error "-fdec-structure" " " { target *-*-* } 21 } +! { dg-error "-fdec-structure" " " { target *-*-* } 22 } +! { dg-error "is not a variable" " " { target *-*-* } 30 } +! { dg-error "Bad character" " " { target *-*-* } 32 } +! { dg-error "Expecting END PROGRAM" " " { target *-*-* } 34 } +! { dg-error "Bad character" " " { target *-*-* } 36 } +! { dg-error "Expecting END PROGRAM" " " { target *-*-* } 38 } +! { dg-error "Bad character" " " { target *-*-* } 40 } +! { dg-error "Expecting END PROGRAM" " " { target *-*-* } 42 } +! { dg-error "Bad character" " " { target *-*-* } 44 } +! { dg-error "Expecting END PROGRAM" " " { target *-*-* } 46 } +! { dg-error "Bad character" " " { target *-*-* } 48 } +! { dg-error "Expecting END PROGRAM" " " { target *-*-* } 50 } +! { dg-error "Bad character" " " { target *-*-* } 52 } +! { dg-error "Expecting END PROGRAM" " " { target *-*-* } 54 } +! { dg-error "function result" " " { target *-*-* } 29 } diff --git a/Fortran/gfortran/regression/dec_structure_28.f90 b/Fortran/gfortran/regression/dec_structure_28.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_structure_28.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! { dg-options "-fdec-structure -fdec-static" } +! +! PR fortran/85982 +! +! Test a regression wherein some component attributes were erroneously accepted +! within a DEC structure. +! + +structure /s/ + integer :: a + integer, intent(in) :: b ! { dg-error "is not allowed" } + integer, intent(out) :: c ! { dg-error "is not allowed" } + integer, intent(inout) :: d ! { dg-error "is not allowed" } + integer, dimension(1,1) :: e ! OK + integer, external, pointer :: f ! { dg-error "is not allowed" } + integer, intrinsic :: f ! { dg-error "is not allowed" } + integer, optional :: g ! { dg-error "is not allowed" } + integer, parameter :: h ! { dg-error "is not allowed" } + integer, protected :: i ! { dg-error "is not allowed" } + integer, private :: j ! { dg-error "is not allowed" } + integer, static :: k ! { dg-error "is not allowed" } + integer, automatic :: l ! { dg-error "is not allowed" } + integer, public :: m ! { dg-error "is not allowed" } + integer, save :: n ! { dg-error "is not allowed" } + integer, target :: o ! { dg-error "is not allowed" } + integer, value :: p ! { dg-error "is not allowed" } + integer, volatile :: q ! { dg-error "is not allowed" } + integer, bind(c) :: r ! { dg-error "is not allowed" } + integer, asynchronous :: t ! { dg-error "is not allowed" } + character(len=3) :: v ! OK + integer(kind=4) :: w ! OK +end structure + +end diff --git a/Fortran/gfortran/regression/dec_structure_3.f90 b/Fortran/gfortran/regression/dec_structure_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_structure_3.f90 @@ -0,0 +1,52 @@ +! { dg-do run } +! { dg-options "-fdec-structure" } +! +! Test nested STRUCTURE definitions. +! + +subroutine aborts (s) + character(*), intent(in) :: s + print *, s + STOP 1 +end subroutine + +structure /s3/ + real p + structure /s4/ recrd, recrd_a(3) + integer i, j + end structure + real q +end structure + +record /s3/ r3 +record /s4/ r4 + +r3.p = 1.3579 +r4.i = 0 +r4.j = 1 +r3.recrd = r4 +r3.recrd_a(1) = r3.recrd +r3.recrd_a(2).i = 1 +r3.recrd_a(2).j = 0 + +if (r3.p .ne. 1.3579) then + call aborts("r3.p") +endif + +if (r4.i .ne. 0) then + call aborts("r4.i") +endif + +if (r4.j .ne. 1) then + call aborts("r4.j") +endif + +if (r3.recrd.i .ne. 0 .or. r3.recrd.j .ne. 1) then + call aborts("r3.recrd") +endif + +if (r3.recrd_a(2).i .ne. 1 .or. r3.recrd_a(2).j .ne. 0) then + call aborts("r3.recrd_a(2)") +endif + +end diff --git a/Fortran/gfortran/regression/dec_structure_4.f90 b/Fortran/gfortran/regression/dec_structure_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_structure_4.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! { dg-options "-fdec-structure" } +! +! Test anonymous STRUCTURE definitions. +! + +subroutine aborts (s) + character(*), intent(in) :: s + print *, s + STOP 1 +end subroutine + +structure /s5/ + structure recrd, recrd_a(3) + real x, y + end structure +end structure + +record /s5/ r5 + +r5.recrd.x = 1.3 +r5.recrd.y = 5.7 +r5.recrd_a(1) = r5.recrd +r5.recrd_a(2).x = 5.7 +r5.recrd_a(2).y = 1.3 + +if (r5.recrd.x .ne. 1.3) then + call aborts("r5.recrd.x") +endif + +if (r5.recrd.y .ne. 5.7) then + call aborts("r5.recrd.y") +endif + +if (r5.recrd_a(1).x .ne. 1.3 .or. r5.recrd_a(1).y .ne. 5.7) then + call aborts("r5.recrd_a(1)") +endif + +if (r5.recrd_a(2).x .ne. 5.7 .or. r5.recrd_a(2).y .ne. 1.3) then + call aborts("r5.recrd_a(2)") +endif + +end diff --git a/Fortran/gfortran/regression/dec_structure_5.f90 b/Fortran/gfortran/regression/dec_structure_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_structure_5.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +! { dg-options "-fdec-structure" } +! +! Test STRUCTUREs which share names with variables. +! + +subroutine aborts (s) + character(*), intent(in) :: s + print *, s + STOP 1 +end subroutine + +! Special regression where shared names within a module caused an ICE +! from gfc_get_module_backend_decl +module dec_structure_5m + structure /s6/ + integer i + end structure + + record /s6/ s6 +end module + +program dec_structure_5 + use dec_structure_5m + + structure /s7/ + real r + end structure + + record /s7/ s7(3) + + s6.i = 0 + s7(1).r = 1.0 + s7(2).r = 2.0 + s7(3).r = 3.0 + + if (s6.i .ne. 0) then + call aborts("s6.i") + endif + + if (s7(1).r .ne. 1.0) then + call aborts("s7(1).r") + endif + + if (s7(2).r .ne. 2.0) then + call aborts("s7(2).r") + endif + +end diff --git a/Fortran/gfortran/regression/dec_structure_6.f90 b/Fortran/gfortran/regression/dec_structure_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_structure_6.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! { dg-options "-fdec-structure -fallow-invalid-boz" } +! +! Test old-style CLIST initializers in STRUCTURE. +! + +subroutine aborts (s) + character(*), intent(in) :: s + print *, s + STOP 1 +end subroutine + +integer, parameter :: as = 3 +structure /s8/ + character*20 c /"HELLO"/ ! ok + integer*2 j /300_4/ ! ok, converted + integer k /65536_8/ ! ok, implicit + integer*4 l /200000/ ! ok, types match + integer m(5) /5,4,3,2,1/! ok + integer n(5) /1,3*2,1/ ! ok, with repeat spec (/1,2,2,2,1/) + integer o(as) /as*9/ ! ok, parameter array spec + integer p(2,2) /1,2,3,4/! ok + real q(3) /1_2,3.5,2.4E-12_8/ ! ok, with some implicit conversions + integer :: canary = z'3D3D3D3D' ! { dg-warning "BOZ literal constant" } +end structure + +record /s8/ r8 + +! Old-style (clist) initializers in structures +if ( r8.c /= "HELLO" ) call aborts ("r8.c") +if ( r8.j /= 300 ) call aborts ("r8.j") +if ( r8.k /= 65536 ) call aborts ("r8.k") +if ( r8.l /= 200000 ) call aborts ("r8.l") +if ( r8.m(1) /= 5 .or. r8.m(2) /= 4 .or. r8.m(3) /= 3 & + .or. r8.m(4) /= 2 .or. r8.m(5) /= 1) & + call aborts ("r8.m") +if ( r8.n(1) /= 1 .or. r8.n(2) /= 2 .or. r8.n(3) /= 2 .or. r8.n(4) /= 2 & + .or. r8.n(5) /= 1) & + call aborts ("r8.n") +if ( r8.o(1) /= 9 .or. r8.o(2) /= 9 .or. r8.o(3) /= 9 ) call aborts ("r8.o") +if ( r8.p(1,1) /= 1 .or. r8.p(2,1) /= 2 .or. r8.p(1,2) /= 3 & + .or. r8.p(2,2) /= 4) & + call aborts ("r8.p") +if ( r8.canary /= int(z'3D3D3D3D') ) call aborts ("r8.canary") + +end diff --git a/Fortran/gfortran/regression/dec_structure_7.f90 b/Fortran/gfortran/regression/dec_structure_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_structure_7.f90 @@ -0,0 +1,75 @@ +! { dg-do run } +! { dg-options "-fdec-structure" } +! +! Test passing STRUCTUREs through functions and subroutines. +! + +subroutine aborts (s) + character(*), intent(in) :: s + print *, s + STOP 1 +end subroutine + +module dec_structure_7m + structure /s1/ + integer i1 + logical l1 + real r1 + character c1 + end structure + + structure /s2/ + integer i + record /s1/ r1 + endstructure + +contains + ! Pass structure through subroutine + subroutine sub (rec1, i) + implicit none + integer, intent(in) :: i + record /s1/ rec1 + rec1.i1 = i + end subroutine + + ! Pass structure through function + function func (rec2, r) + implicit none + real, intent(in) :: r + record /s2/ rec2 + real func + rec2.r1.r1 = r + func = rec2.r1.r1 + return + end function +end module + +program dec_structure_7 + use dec_structure_7m + + implicit none + record /s1/ r1 + record /s2/ r2 + real junk + + ! Passing through functions and subroutines + r1.i1 = 0 + call sub (r1, 10) + + r2.r1.r1 = 0.0 + junk = func (r2, -20.14) + + if (r1.i1 .ne. 10) then + call aborts("sub(r1, 10)") + endif + + if (r2.r1.r1 .ne. -20.14) then + call aborts("func(r2, -20.14)") + endif + + if (junk .ne. -20.14) then + print *, junk + call aborts("junk = func()") + endif + +end program diff --git a/Fortran/gfortran/regression/dec_structure_8.f90 b/Fortran/gfortran/regression/dec_structure_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_structure_8.f90 @@ -0,0 +1,60 @@ +! { dg-do compile } +! { dg-options "-fdec-structure -fmax-errors=0" } +! +! Comprehensive compile tests for what structures CAN'T do. +! + +! Old-style (clist) initialization +integer,parameter :: as = 3 +structure /t1/ ! { dg-error "Type definition.*T1" } + integer*1 a /300_2/ ! { dg-error "Arithmetic overflow" } + integer b // ! { dg-error "Empty old style initializer list" } + integer c /2*3/ ! { dg-error "Repeat spec invalid in scalar" } + integer d /1,2,3/ ! { dg-error "End of scalar initializer expected" } + integer e /"HI"/ ! { dg-error "Cannot convert" } + integer f(as) /4*9/ ! { dg-error "Too many elements" } + integer g(3) /1,3/ ! { dg-error "Not enough elements" } + integer h(3) /1,3,5,7/ ! { dg-error "Too many elements" } + integer i(3) /2*1/ ! { dg-error "Not enough elements" } + integer j(3) /10*1/ ! { dg-error "Too many elements" } + integer k(3) /2.5*3/ ! { dg-error "Repeat spec must be an integer" } + integer l(2) /2*/ ! { dg-error "Expected data constant" } + integer m(1) / ! { dg-error "Syntax error in old style" } + integer n(2) /1 ! { dg-error "Syntax error in old style" } + integer o(2) /1, ! { dg-error "Syntax error in old style" } + integer p(1) /x/ ! { dg-error "must be a PARAMETER" } +end structure + +structure ! { dg-error "Structure name expected" } +structure / ! { dg-error "Structure name expected" } +structure // ! { dg-error "Structure name expected" } +structure /.or./ ! { dg-error "Structure name expected" } +structure /integer/ ! { dg-error "Structure name.*cannot be the same" } +structure /foo/ bar ! { dg-error "Junk after" } +structure /t1/ ! { dg-error "Type definition.*T1" } + +record ! { dg-error "Structure name expected" } +record bar ! { dg-error "Structure name expected" } +record / bar ! { dg-error "Structure name expected" } +record // bar ! { dg-error "Structure name expected" } +record foo/ bar ! { dg-error "Structure name expected" } +record /foo bar ! { dg-error "Structure name expected" } +record /foo/ bar ! { dg-error "used before it is defined" } +record /t1/ ! { dg-error "Invalid character in name" } + +structure /t2/ + ENTRY here ! { dg-error "ENTRY statement.*cannot appear" } + integer a ! { dg-error "Component.*already declared" } + integer a ! { dg-error "Component.*already declared" } + structure $z ! { dg-error "Invalid character in name" } + structure // ! { dg-error "Invalid character in name" } + structure // x ! { dg-error "Invalid character in name" } + structure /t3/ ! { dg-error "Invalid character in name" } + structure /t3/ x,$y ! { dg-error "Invalid character in name" } + structure /t4/ y ! { dg-error "Type definition.*T4" } + integer i, j, k + end structure + structure /t4/ z ! { dg-error "Type definition.*T4" } +end structure + +end diff --git a/Fortran/gfortran/regression/dec_structure_9.f90 b/Fortran/gfortran/regression/dec_structure_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_structure_9.f90 @@ -0,0 +1,42 @@ +! { dg-do compile } +! { dg-options "-fdec-structure" } +! +! Basic compile tests for what CAN be done with dot ('.') as a member accessor. +! + +logical :: l, l2 = .true., l3 = .false., and +integer i +character(5) s +real r + +structure /s1/ + integer i + character(5) s + real r +end structure + +record /s1/ r1 + +! Basic +l = l .and. l2 .or. l3 +l = and .and. and .and. and +l = l2 .eqv. l3 +l = (l2) .eqv. l3 + +! Integers +l = .not. (i .eq. 0) +l = .not. (0 .eq. i) +l = .not. (r1.i .eq. 0) +l = .not. (0 .eq. r1.i) +! Characters +l = .not. (s .eq. "hello") +l = .not. ("hello" .eq. s) +l = .not. (r1.s .eq. "hello") +l = .not. ("hello" .eq. r1.s) +! Reals +l = .not. (r .eq. 3.14) +l = .not. (3.14 .eq. r) +l = .not. (r1.r .eq. 3.14) +l = .not. (3.14 .eq. r1.r) + +end diff --git a/Fortran/gfortran/regression/dec_type_print.f90 b/Fortran/gfortran/regression/dec_type_print.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_type_print.f90 @@ -0,0 +1,84 @@ +! { dg-do compile } +! { dg-options "-fdec" } +! +! Test the usage of TYPE as an alias for PRINT. +! +! Note the heavy use of other TYPE statements to test for +! regressions involving ambiguity. +! +program main + +logical bool +integer i /0/, j /1/, k /2/ +character(*), parameter :: fmtstr = "(A11)" +namelist /nmlist/ i, j, k +integer, parameter :: n = 5 +real a(n) + +! derived type declarations +type is + integer i +end type + +type point + real x, y +end type point + +type, extends(point) :: point_3d + real :: z +end type point_3d + +type, extends(point) :: color_point + integer :: color +end type color_point + +! declaration type specification +type(is) x +type(point), target :: p +type(point_3d), target :: p3 +type(color_point), target :: c +class(point), pointer :: p_or_c + +! select type +p_or_c => c +select type ( a => p_or_c ) + class is ( point ) + print *, "point" ! <=== + type is ( point_3d ) + print *, "point 3D" +end select + +! Type as alias for print +type* +type * +type*,'St','ar' +type *, 'St', 'ar' +type 10, 'Integer literal' +type 10, 'Integer variable' +type '(A11)', 'Character literal' +type fmtstr, 'Character variable' +type nmlist ! namelist + +a(1) = 0 +call f(.true., a, n) + +10 format (A11) + +end program + + +subroutine f(b,a,n) + implicit none + logical b + real a(*) + integer n + + integer i + + do i = 2,n + a(i) = 2 * (a(i-1) + 1) + if (b) type*,a(i) ! test TYPE as PRINT inside one-line IF + enddo + + return +end subroutine diff --git a/Fortran/gfortran/regression/dec_type_print_2.f03 b/Fortran/gfortran/regression/dec_type_print_2.f03 --- /dev/null +++ b/Fortran/gfortran/regression/dec_type_print_2.f03 @@ -0,0 +1,59 @@ +! { dg-do run } +! { dg-options "-fdec -fcheck=all" } +! +! Verify that -fdec does not break parsing of PDTs. +! This test code is copied from pdt_1.f03 but compiled with -fdec. +! +program main + implicit none + integer, parameter :: ftype = kind(0.0e0) + integer :: pdt_len = 4 + integer :: i + type :: mytype (a,b) + integer, kind :: a = kind(0.0d0) + integer, LEN :: b + integer :: i + real(kind = a) :: d(b, b) + character (len = b*b) :: chr + end type + + type(mytype(b=4)) :: z(2) + type(mytype(ftype, 4)) :: z2 + + z(1)%i = 1 + z(2)%i = 2 + z(1)%d = reshape ([(real(i), i = 1, 16)],[4,4]) + z(2)%d = 10*z(1)%d + z(1)%chr = "hello pdt" + z(2)%chr = "goodbye pdt" + + z2%d = z(1)%d * 10 - 1 + z2%chr = "scalar pdt" + + call foo (z) + call bar (z) + call foobar (z2) +contains + elemental subroutine foo (arg) + type(mytype(8,*)), intent(in) :: arg + if (arg%i .eq. 1) then + if (trim (arg%chr) .ne. "hello pdt") error stop + if (int (sum (arg%d)) .ne. 136) error stop + else if (arg%i .eq. 2 ) then + if (trim (arg%chr) .ne. "goodbye pdt") error stop + if (int (sum (arg%d)) .ne. 1360) error stop + else + error stop + end if + end subroutine + subroutine bar (arg) + type(mytype(b=4)) :: arg(:) + if (int (sum (arg(1)%d)) .ne. 136) call abort + if (trim (arg(2)%chr) .ne. "goodbye pdt") call abort + end subroutine + subroutine foobar (arg) + type(mytype(ftype, pdt_len)) :: arg + if (int (sum (arg%d)) .ne. 1344) call abort + if (trim (arg%chr) .ne. "scalar pdt") call abort + end subroutine +end diff --git a/Fortran/gfortran/regression/dec_type_print_3.f90 b/Fortran/gfortran/regression/dec_type_print_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_type_print_3.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-fdec -fno-dec" } +! +! PR fortran/87919 +! +! Ensure that -fno-dec disables the usage of TYPE as an alias for PRINT. +! + +include 'dec_type_print.f90' + +! { dg-error "Mangled derived type definition" "" { target *-*-* } 52 } +! { dg-error "Invalid character in name" "" { target *-*-* } 53 } +! { dg-error "Mangled derived type definition" "" { target *-*-* } 54 } +! { dg-error "Invalid character in name" "" { target *-*-* } 55 } +! { dg-error "Invalid character in name" "" { target *-*-* } 56 } +! { dg-error "Invalid character in name" "" { target *-*-* } 57 } +! { dg-error "Invalid character in name" "" { target *-*-* } 58 } +! { dg-error "conflicts with PROCEDURE" "" { target *-*-* } 60 } +! { dg-error "Syntax error in IF-clause" "" { target *-*-* } 80 } + diff --git a/Fortran/gfortran/regression/dec_union_1.f90 b/Fortran/gfortran/regression/dec_union_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_union_1.f90 @@ -0,0 +1,66 @@ +! { dg-do run } +! { dg-options "-fdec-structure" } +! +! Test whether union backend declarations are corrently _not_ copied when they +! are not in fact equal. The structure defined in sub() is seen later, but +! where siz has a different value. +! + +subroutine aborts (s) + character(*), intent(in) :: s + print *, s + STOP 1 +end subroutine + +subroutine sub () + integer, parameter :: siz = 1024 + structure /s6/ + union ! U0 + map ! M0 + integer ibuf(siz) + end map + map ! M1 + character(8) cbuf(siz) + end map + map ! M2 + real rbuf(siz) + end map + end union + end structure + record /s6/ r6 + r6.ibuf(1) = int(z'badbeef') + r6.ibuf(2) = int(z'badbeef') +end subroutine + +! Repeat definition from subroutine sub with different size parameter. +! If the structure definition is copied here the stack may get messed up. +integer, parameter :: siz = 65536 +structure /s6/ + union ! U12 + map + integer ibuf(siz) + end map + map + character(8) cbuf(siz) + end map + map + real rbuf(siz) + end map + end union +end structure + +record /s6/ r6 +integer :: r6_canary = 0 + +! Copied type declaration - this should not cause problems +i = 1 +do while (i < siz) + r6.ibuf(i) = int(z'badbeef') + i = i + 1 +end do + +if ( r6_canary .ne. 0 ) then + call aborts ('copied decls: overflow') +endif + +end diff --git a/Fortran/gfortran/regression/dec_union_10.f90 b/Fortran/gfortran/regression/dec_union_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_union_10.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-fdec-structure" } +! +! Check for regression where gfc_compare_union_types wasn't properly guarded +! against empty unions. +! + +subroutine sub1(r) + structure /s/ + union + end union + end structure + record /s/ r +end subroutine + +subroutine sub2() + structure /s/ + union + end union + end structure + record /s/ r + call sub1(r) +end subroutine + +call sub2() + +end diff --git a/Fortran/gfortran/regression/dec_union_11.f90 b/Fortran/gfortran/regression/dec_union_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_union_11.f90 @@ -0,0 +1,63 @@ +! { dg-do compile } +! { dg-options "-g -fdec-structure -std=legacy" } +! +! Test a regression where typespecs of unions containing character buffers of +! different lengths where copied, resulting in a bad gimple tree state. +! + +subroutine sub2 (otherbuf) + integer, parameter :: L_bbuf = 65536 + integer, parameter :: L_bbuf2 = 24 + + structure /buffer2/ + union + map + character(L_bbuf2) sbuf + end map + end union + end structure + structure /buffer/ + union + map + character(L_bbuf) sbuf + end map + end union + end structure + + record /buffer/ buf1 + record /buffer2/ buf2 + common /c/ buf1, buf2 + + record /buffer2/ otherbuf +end subroutine + +subroutine sub() + integer, parameter :: L_bbuf = 65536 + integer, parameter :: L_bbuf2 = 24 + + structure /buffer2/ + union + map + character(L_bbuf2) sbuf + end map + end union + end structure + structure /buffer/ + union + map + character(L_bbuf) sbuf + end map + end union + end structure + + record /buffer/ buf1 + record /buffer2/ buf2 + common /c/ buf1, buf2 + + call sub2 (buf1) ! { dg-warning "Type mismatch" } + return +end subroutine + +call sub() + +end diff --git a/Fortran/gfortran/regression/dec_union_12.f90 b/Fortran/gfortran/regression/dec_union_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_union_12.f90 @@ -0,0 +1,43 @@ +! { dg-do compile } +! { dg-options "-std=legacy -ffree-form -finit-local-zero -finit-derived -fdec-structure" } +! +! PR fortran/105310 +! +! Test that gfc_conv_union_initializer does not cause an ICE when called +! to build the constructor for a field which triggers a vector resize. +! + +program dec_union_12 + implicit none +STRUCTURE /foo8u/ + ! 8 fields + INTEGER(4) :: a,b,c,d,e,f,g,h + UNION + MAP + ENDMAP + ENDUNION +ENDSTRUCTURE +STRUCTURE /foo16u/ + ! 16 fields + INTEGER(4) :: a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p + UNION + MAP + ENDMAP + ENDUNION +ENDSTRUCTURE +STRUCTURE /foo32u/ + ! 32 fields + INTEGER(4) :: a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p + INTEGER(4) :: aa,ab,ac,ad,ae,af,ag,ah,ai,aj,ak,al,am,an,ao,ap + UNION + MAP + ENDMAP + ENDUNION +ENDSTRUCTURE + record /foo8u/ bar8u + record /foo16u/ bar16u + record /foo32u/ bar32u + bar8u.a = 1 + bar16u.a = 1 + bar32u.a = 1 +end diff --git a/Fortran/gfortran/regression/dec_union_2.f90 b/Fortran/gfortran/regression/dec_union_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_union_2.f90 @@ -0,0 +1,61 @@ +! { dg-do run } +! { dg-options "-fdec-structure" } +! +! Test basic UNION implementation. +! + +subroutine aborts (s) + character(*), intent(in) :: s + print *, s + STOP 1 +end subroutine + +! Empty union +structure /s0/ + union ! U0 + map ! M0 + end map + map ! M1 + end map + end union +end structure + +! Basic unions +structure /s1/ + union ! U1 + map ! M2 + integer(4) a + end map + map ! M3 + real(4) b + end map + end union +end structure + +structure /s2/ + union ! U2 + map ! M4 + integer(2) w1, w2 + end map + map ! M5 + integer(4) long + end map + end union +end structure + +record /s1/ r1 +record /s2/ r2 + +! Basic unions +r1.a = 0 +r1.b = 1.33e7 +if ( r1.a .eq. 0 ) call aborts ("basic union 1") + +! Endian-agnostic runtime check +r2.long = int(z'12345678') +if (.not. ( (r2.w1 .eq. int(z'1234',2) .and. r2.w2 .eq. int(z'5678',2)) & + .or. (r2.w1 .eq. int(z'5678',2) .and. r2.w2 .eq. int(z'1234',2))) ) then + call aborts ("basic union 2") +endif + +end diff --git a/Fortran/gfortran/regression/dec_union_3.f90 b/Fortran/gfortran/regression/dec_union_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_union_3.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! { dg-options "-fdec-structure" } +! +! Test UNIONs with initializations. +! + +subroutine aborts (s) + character(*), intent(in) :: s + print *, s + STOP 1 +end subroutine + +! Initialization expressions +structure /s3/ + integer(4) :: i = 8 + union ! U7 + map + integer(4) :: x = 1600 + integer(4) :: y = 1800 + end map + map + integer(2) a, b, c + end map + end union +end structure + +record /s3/ r3 + +! Initialized unions +if ( r3.x .ne. 1600 .or. r3.y .ne. 1800) then + r3.x = r3.y ! If r3 isn't used the initializations are optimized out + call aborts ("union initialization") +endif + +end diff --git a/Fortran/gfortran/regression/dec_union_4.f90 b/Fortran/gfortran/regression/dec_union_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_union_4.f90 @@ -0,0 +1,63 @@ +! { dg-do run } +! { dg-options "-fdec-structure" } +! +! Test nested UNIONs. +! + +subroutine aborts (s) + character(*), intent(in) :: s + print *, s + STOP 1 +end subroutine + +! Nested unions +structure /s4/ + union ! U0 ! rax + map + character(16) rx + end map + map + character(8) rh ! rah + union ! U1 + map + character(8) rl ! ral + end map + map + character(8) ex ! eax + end map + map + character(4) eh ! eah + union ! U2 + map + character(4) el ! eal + end map + map + character(4) x ! ax + end map + map + character(2) h ! ah + character(2) l ! al + end map + end union + end map + end union + end map + end union +end structure +record /s4/ r4 + + +! Nested unions +r4.rx = 'AAAAAAAA.BBB.C.D' + +if ( r4.rx .ne. 'AAAAAAAA.BBB.C.D' ) call aborts ("rax") +if ( r4.rh .ne. 'AAAAAAAA' ) call aborts ("rah") +if ( r4.rl .ne. '.BBB.C.D' ) call aborts ("ral") +if ( r4.ex .ne. '.BBB.C.D' ) call aborts ("eax") +if ( r4.eh .ne. '.BBB' ) call aborts ("eah") +if ( r4.el .ne. '.C.D' ) call aborts ("eal") +if ( r4.x .ne. '.C.D' ) call aborts ("ax") +if ( r4.h .ne. '.C' ) call aborts ("ah") +if ( r4.l .ne. '.D' ) call aborts ("al") + +end diff --git a/Fortran/gfortran/regression/dec_union_5.f90 b/Fortran/gfortran/regression/dec_union_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_union_5.f90 @@ -0,0 +1,41 @@ +! { dg-do run } +! { dg-options "-fdec-structure" } +! +! Test UNIONs with array components. +! + +subroutine aborts (s) + character(*), intent(in) :: s + print *, s + STOP 1 +end subroutine + +! Unions with arrays +structure /s5/ + union + map + character :: s(5) + end map + map + integer(1) :: a(5) + end map + end union +end structure + +record /s5/ r5 + +! Unions with arrays +r5.a(1) = int(z'41',1) +r5.a(2) = int(z'42',1) +r5.a(3) = int(z'43',1) +r5.a(4) =int( z'44',1) +r5.a(5) = int(z'45',1) +if ( r5.s(1) .ne. 'A' & + .or. r5.s(2) .ne. 'B' & + .or. r5.s(3) .ne. 'C' & + .or. r5.s(4) .ne. 'D' & + .or. r5.s(5) .ne. 'E') then + call aborts ("arrays") +endif + +end diff --git a/Fortran/gfortran/regression/dec_union_6.f90 b/Fortran/gfortran/regression/dec_union_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_union_6.f90 @@ -0,0 +1,59 @@ +! { dg-do run } +! { dg-options "-fdec-structure" } +! +! sub0 and sub1 test a regression where calling gfc_use_derived from +! gfc_find_component on the structure type symbol being parsed caused the +! symbol to be freed and swapped for the previously seen type symbol, leaving +! dangling pointers and causing all sorts of mayhem. +! + +subroutine sub0 (u) + structure /s/ + union ! U0 + map ! M0 + integer i + end map + end union + end structure + record /s/ u + u.i = 0 +end subroutine sub0 + +subroutine sub1 () + structure /s/ + union ! U1 + map ! M1 + integer i + end map + end union + end structure + record /s/ u + interface ! matches the declaration of sub0 above + subroutine sub0 (u) + structure /s/ + union ! U2 + map ! M2 + integer i ! gfc_find_component should not call gfc_use_derived + end map ! here, otherwise this structure's type symbol is freed + end union ! out from under it + end structure + record /s/ u + end subroutine sub0 + end interface + call sub0(u) +end subroutine + +! If sub0 and sub1 aren't used they may be omitted +structure /s/ + union ! U1 + map ! M3 + integer i + end map + end union +end structure +record /s/ u + +call sub0(u) +call sub1() + +end diff --git a/Fortran/gfortran/regression/dec_union_7.f90 b/Fortran/gfortran/regression/dec_union_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_union_7.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! { dg-options "-fdec-structure" } +! +! Comprehensive compile tests for what unions CAN'T do. +! + +! Syntax errors +structure /s0/ + union a b c ! { dg-error "Junk after UNION" } + union + map a b c ! { dg-error "Junk after MAP" } + integer x ! { dg-error "Unexpected" } + structure /s2/ ! { dg-error "Unexpected" } + map + map ! { dg-error "Unexpected" } + end map + end union +end structure + +! Initialization expressions +structure /s1/ + union + map + integer(4) :: x = 1600 ! { dg-error "Conflicting initializers" } + integer(4) :: y = 1800 + end map + map + integer(2) a, b, c, d + integer :: e = 0 ! { dg-error "Conflicting initializers" } + end map + map + real :: p = 1.3, q = 3.7 ! { dg-error "Conflicting initializers" } + end map + end union +end structure +record /s1/ r1 + +end diff --git a/Fortran/gfortran/regression/dec_union_8.f90 b/Fortran/gfortran/regression/dec_union_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_union_8.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-fdec-structure" } +! +! PR fortran/77764 +! +! Test an ICE due to a map with zero components. +! + +program p + +structure /s1/ + union + map + end map + map + real :: a = 2.0 + end map + end union +end structure + +end diff --git a/Fortran/gfortran/regression/dec_union_9.f90 b/Fortran/gfortran/regression/dec_union_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dec_union_9.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-options "-fdec-structure" } +! +! Test a regression where union components could compare equal to structure/map +! components, causing an ICE in gfc_conv_component_ref. +! + +implicit none + +structure /s1/ + integer(4) i +end structure + +structure /s2/ + union + map + record /s1/ r + end map + end union +end structure + +record /s2/ x + +x.r.i = 0 + +end diff --git a/Fortran/gfortran/regression/default_format_1.f90 b/Fortran/gfortran/regression/default_format_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/default_format_1.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! Test XFAILed on Darwin because the system's printf() lacks +! proper support for denormals. +! +! This tests that the default formats for formatted I/O of reals are +! wide enough and have enough precision, by checking that values can +! be written and read back. +! +include "default_format_1.inc" + +program main + use test_default_format + + if (test (1.0_4, 0) /= 0) STOP 1 + if (test (tiny(0.0_4), 1) /= 0) STOP 2 + if (test (-tiny(0.0_4), -1) /= 0) STOP 3 + if (test (huge(0.0_4), -1) /= 0) STOP 4 + if (test (-huge(0.0_4), 1) /= 0) STOP 5 + + if (test (1.0_8, 0) /= 0) STOP 6 + if (test (tiny(0.0_8), 1) /= 0) STOP 7 + if (test (-tiny(0.0_8), -1) /= 0) STOP 8 + if (test (huge(0.0_8), -1) /= 0) STOP 9 + if (test (-huge(0.0_8), 1) /= 0) STOP 10 +end program main +! diff --git a/Fortran/gfortran/regression/default_format_1.inc b/Fortran/gfortran/regression/default_format_1.inc --- /dev/null +++ b/Fortran/gfortran/regression/default_format_1.inc @@ -0,0 +1,74 @@ +module test_default_format + interface test + module procedure test_r4 + module procedure test_r8 + end interface test + + integer, parameter :: count = 200 + +contains + function test_r4 (start, towards) result (res) + integer, parameter :: k = 4 + integer, intent(in) :: towards + real(k), intent(in) :: start + + integer :: res, i + real(k) :: x, y + character(len=100) :: s + + res = 0 + + if (towards >= 0) then + x = start + do i = 0, count + write (s,*) x + read (s,*) y + if (y /= x) res = res + 1 + x = nearest(x,huge(x)) + end do + end if + + if (towards <= 0) then + x = start + do i = 0, count + write (s,*) x + read (s,*) y + if (y /= x) res = res + 1 + x = nearest(x,-huge(x)) + end do + end if + end function test_r4 + + function test_r8 (start, towards) result (res) + integer, parameter :: k = 8 + integer, intent(in) :: towards + real(k), intent(in) :: start + + integer :: res, i + real(k) :: x, y + character(len=100) :: s + + res = 0 + + if (towards >= 0) then + x = start + do i = 0, count + write (s,*) x + read (s,*) y + if (y /= x) res = res + 1 + x = nearest(x,huge(x)) + end do + end if + + if (towards <= 0) then + x = start + do i = 0, count + write (s,*) x + read (s,*) y + if (y /= x) res = res + 1 + x = nearest(x,-huge(x)) + end do + end if + end function test_r8 + +end module test_default_format diff --git a/Fortran/gfortran/regression/default_format_2.f90 b/Fortran/gfortran/regression/default_format_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/default_format_2.f90 @@ -0,0 +1,22 @@ +! { dg-do run { xfail powerpc*-apple-darwin* powerpc*-*-linux* } } +! { dg-require-effective-target fortran_large_real } +! Test XFAILed on these platforms because the system's printf() lacks +! proper support for denormalized long doubles. See PR24685 +! +! This tests that the default formats for formatted I/O of reals are +! wide enough and have enough precision, by checking that values can +! be written and read back. +! +include "default_format_2.inc" + +program main + use test_default_format + + if (test (1.0_kl, 0) /= 0) STOP 1 + if (test (0.0_kl, 0) /= 0) STOP 2 + if (test (tiny(0.0_kl), 1) /= 0) STOP 3 + if (test (-tiny(0.0_kl), -1) /= 0) STOP 4 + if (test (huge(0.0_kl), -1) /= 0) STOP 5 + if (test (-huge(0.0_kl), 1) /= 0) STOP 6 +end program main +! diff --git a/Fortran/gfortran/regression/default_format_2.inc b/Fortran/gfortran/regression/default_format_2.inc --- /dev/null +++ b/Fortran/gfortran/regression/default_format_2.inc @@ -0,0 +1,43 @@ +module test_default_format + interface test + module procedure test_rl + end interface test + + integer, parameter :: kl = selected_real_kind (precision (0.0_8) + 1) + integer, parameter :: count = 200 + +contains + + function test_rl (start, towards) result (res) + integer, parameter :: k = kl + integer, intent(in) :: towards + real(k), intent(in) :: start + + integer :: res, i + real(k) :: x, y + character(len=100) :: s + + res = 0 + + if (towards >= 0) then + x = start + do i = 0, count + write (s,*) x + read (s,*) y + if (y /= x) res = res + 1 + x = nearest(x,huge(x)) + end do + end if + + if (towards <= 0) then + x = start + do i = 0, count + write (s,*) x + read (s,*) y + if (y /= x) res = res + 1 + x = nearest(x,-huge(x)) + end do + end if + end function test_rl + +end module test_default_format diff --git a/Fortran/gfortran/regression/default_format_denormal_1.f90 b/Fortran/gfortran/regression/default_format_denormal_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/default_format_denormal_1.f90 @@ -0,0 +1,25 @@ +! { dg-do run { xfail *-*-darwin[89]* *-*-cygwin* } } +! Test XFAILed on these platforms because the system's printf() lacks +! proper support for denormals. +! +! This tests that the default formats for formatted I/O of reals are +! wide enough and have enough precision, by checking that values can +! be written and read back. +! +! { dg-add-options ieee } + +include "default_format_1.inc" + +program main + use test_default_format + + if (test (tiny(0.0_4), -1) /= 0) STOP 1 + if (test (-tiny(0.0_4), 1) /= 0) STOP 2 + if (test (0.0_4, 0) /= 0) STOP 3 + + if (test (tiny(0.0_8), -1) /= 0) STOP 4 + if (test (-tiny(0.0_8), 1) /= 0) STOP 5 + if (test (0.0_8, 0) /= 0) STOP 6 + +end program main +! diff --git a/Fortran/gfortran/regression/default_format_denormal_2.f90 b/Fortran/gfortran/regression/default_format_denormal_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/default_format_denormal_2.f90 @@ -0,0 +1,20 @@ +! { dg-do run { xfail powerpc*-*-* } } +! { dg-require-effective-target fortran_large_real } +! Test XFAILed on this platform because the system's printf() lacks +! proper support for denormalized long doubles. See PR24685 +! +! This tests that the default formats for formatted I/O of reals are +! wide enough and have enough precision, by checking that values can +! be written and read back. +! +! { dg-add-options ieee } + +include "default_format_2.inc" + +program main + use test_default_format + + if (test (tiny(0.0_kl), -1) /= 0) STOP 1 + if (test (-tiny(0.0_kl), 1) /= 0) STOP 2 +end program main +! diff --git a/Fortran/gfortran/regression/default_initialization_1.f90 b/Fortran/gfortran/regression/default_initialization_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/default_initialization_1.f90 @@ -0,0 +1,19 @@ +! +! { dg-do compile } +! { dg-options "-std=f2003" } +! PR 20845; for F2008: PR fortran/43185 +! +! In ISO/IEC 1539-1:1997(E), 4th constraint in section 11.3: +! +! If an object of a type for which component-initialization is specified +! (R429) appears in the specification-part of a module and does not have +! the ALLOCATABLE or POINTER attribute, the object shall have the SAVE +! attribute. +! +module bad + implicit none + type default_initialization + integer :: x = 42 + end type default_initialization + type (default_initialization) t ! { dg-error "default initialization" } +end module bad diff --git a/Fortran/gfortran/regression/default_initialization_2.f90 b/Fortran/gfortran/regression/default_initialization_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/default_initialization_2.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! This tests the patch for PR29098, in which the presence of the default +! initializer would cause allocate to fail because the latter uses +! the interface assignment. This, in its turn was failing because +! no expressions were found for the other components; and a FAILURE +! was returned from resolve_structure_cons. +! +! Contributed by Olav Vahtras +! + MODULE MAT + TYPE BAS + INTEGER :: R = 0,C = 0 + END TYPE BAS + TYPE BLOCK + INTEGER, DIMENSION(:), POINTER :: R,C + TYPE(BAS), POINTER, DIMENSION(:) :: NO => NULL() + END TYPE BLOCK + INTERFACE ASSIGNMENT(=) + MODULE PROCEDURE BLASSIGN + END INTERFACE + CONTAINS + SUBROUTINE BLASSIGN(A,B) + TYPE(BLOCK), INTENT(IN) :: B + TYPE(BLOCK), INTENT(INOUT) :: A + INTEGER I,N + ! ... + END SUBROUTINE BLASSIGN + END MODULE MAT +PROGRAM TEST +USE MAT +TYPE(BLOCK) MATRIX +POINTER MATRIX +ALLOCATE(MATRIX) +END diff --git a/Fortran/gfortran/regression/default_initialization_3.f90 b/Fortran/gfortran/regression/default_initialization_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/default_initialization_3.f90 @@ -0,0 +1,107 @@ +! { dg-do run } +! Test the fix for PR34438, in which default initializers +! forced the derived type to be static; ie. initialized once +! during the lifetime of the programme. Instead, they should +! be initialized each time they come into scope. +! +! Contributed by Sven Buijssen +! Third test is from Dominique Dhumieres +! +module demo + type myint + integer :: bar = 42 + end type myint +end module demo + +! As the name implies, this was the original testcase +! provided by the contributor.... +subroutine original + use demo + integer val1 (6) + integer val2 (6) + call recfunc (1) + if (any (val1 .ne. (/1, 2, 3, 1, 2, 3/))) STOP 1 + if (any (val2 .ne. (/1, 2, 3, 4, 4, 4/))) STOP 2 +contains + + recursive subroutine recfunc (ivalue) + integer, intent(in) :: ivalue + type(myint) :: foo1 + type(myint) :: foo2 = myint (99) + foo1%bar = ivalue + foo2%bar = ivalue + if (ivalue .le. 3) then + val1(ivalue) = foo1%bar + val2(ivalue) = foo2%bar + call recfunc (ivalue + 1) + val1(ivalue + 3) = foo1%bar + val2(ivalue + 3) = foo2%bar + endif + end subroutine recfunc +end subroutine original + +! ...who came up with this one too. +subroutine func (ivalue, retval1, retval2) + use demo + integer, intent(in) :: ivalue + type(myint) :: foo1 + type(myint) :: foo2 = myint (77) + type(myint) :: retval1 + type(myint) :: retval2 + retval1 = foo1 + retval2 = foo2 + foo1%bar = 999 + foo2%bar = 999 +end subroutine func + +subroutine other + use demo + interface + subroutine func(ivalue, rv1, rv2) + use demo + integer, intent(in) :: ivalue + type(myint) :: foo, rv1, rv2 + end subroutine func + end interface + type(myint) :: val1, val2 + call func (1, val1, val2) + if ((val1%bar .ne. 42) .or. (val2%bar .ne. 77)) STOP 3 + call func (2, val1, val2) + if ((val1%bar .ne. 42) .or. (val2%bar .ne. 999)) STOP 4 + +end subroutine other + +MODULE M1 + TYPE T1 + INTEGER :: i=7 + END TYPE T1 +CONTAINS + FUNCTION F1(d1) RESULT(res) + INTEGER :: res + TYPE(T1), INTENT(OUT) :: d1 + TYPE(T1), INTENT(INOUT) :: d2 + res=d1%i + d1%i=0 + RETURN + ENTRY E1(d2) RESULT(res) + res=d2%i + d2%i=0 + END FUNCTION F1 +END MODULE M1 + +! This tests the fix of a regression caused by the first version +! of the patch. +subroutine dominique () + USE M1 + TYPE(T1) :: D1 + D1=T1(3) + if (F1(D1) .ne. 7) STOP 5 + D1=T1(3) + if (E1(D1) .ne. 3) STOP 6 +END + +! Run both tests. + call original + call other + call dominique +end diff --git a/Fortran/gfortran/regression/default_initialization_4.f90 b/Fortran/gfortran/regression/default_initialization_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/default_initialization_4.f90 @@ -0,0 +1,21 @@ +! +! { dg-do run } +! +! PR fortran/43185 +! +! The following is valid F2008 but not valid Fortran 90/2003 +! Cf. PR 20845 +! +module good + implicit none + type default_initialization + integer :: x = 42 + end type default_initialization + type (default_initialization) t ! OK in F2008 +end module good + +use good +if (t%x /= 42) STOP 1 +t%x = 0 +if (t%x /= 0) STOP 2 +end diff --git a/Fortran/gfortran/regression/default_initialization_5.f90 b/Fortran/gfortran/regression/default_initialization_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/default_initialization_5.f90 @@ -0,0 +1,64 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/51435 +! +! Contributed by darmar.xxl@gmail.com +! +module arr_m + type arr_t + real(8), dimension(:), allocatable :: rsk + end type + type arr_t2 + integer :: a = 77 + end type +end module arr_m +!********************* +module list_m + use arr_m + implicit none + + type(arr_t2), target :: tgt + + type my_list + type(arr_t), pointer :: head => null() + end type my_list + type my_list2 + type(arr_t2), pointer :: head => tgt + end type my_list2 +end module list_m +!*********************** +module worker_mod + use list_m + implicit none + + type data_all_t + type(my_list) :: my_data + end type data_all_t + type data_all_t2 + type(my_list2) :: my_data + end type data_all_t2 +contains + subroutine do_job() + type(data_all_t) :: dum + type(data_all_t2) :: dum2 + + if (associated(dum%my_data%head)) then + STOP 1 + else + print *, 'OK: do_job my_data%head is NOT associated' + end if + + if (dum2%my_data%head%a /= 77) & + STOP 2 + end subroutine +end module +!*************** +program hello + use worker_mod + implicit none + call do_job() +end program + +! { dg-final { scan-tree-dump-times "my_data.head = 0B" 1 "original" } } +! { dg-final { scan-tree-dump-times "my_data.head = &tgt" 1 "original" } } diff --git a/Fortran/gfortran/regression/default_initialization_6.f90 b/Fortran/gfortran/regression/default_initialization_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/default_initialization_6.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! PR fortran/41600 +! + implicit none + type t + integer :: X = -999.0 + end type t + class(t), allocatable :: y(:) + allocate (t :: y(1)) +end diff --git a/Fortran/gfortran/regression/default_initialization_7.f90 b/Fortran/gfortran/regression/default_initialization_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/default_initialization_7.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +! PR fortran/57033 +! ICE on a structure constructor of an extended derived type whose parent +! type last component has a default initializer +! +! Contributed by Tilo Schwarz + +program ice + +type m + integer i + logical :: f = .false. +end type m + +type, extends(m) :: me +end type me + +type(me) meo + +meo = me(1) ! ICE +end program ice diff --git a/Fortran/gfortran/regression/default_numeric_type_1.f90 b/Fortran/gfortran/regression/default_numeric_type_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/default_numeric_type_1.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! Tests the fix for PR 31222, in which the type of the arguments of abs +! and int below were not detected to be of default numeric type.. +! +! Contributed by Tobias Burnus +! +subroutine mysub1(a,b,mode,dis) +! integer :: mode +! real :: dis + dimension a(abs(mode)),b(int(dis)) + print *, mod + write (*,*) abs(mode), nint(dis) +end subroutine + +program testprog + call mysub1((/1.,2./),(/1.,2.,3./),-2, 3.2) +end diff --git a/Fortran/gfortran/regression/deferred_character_1.f90 b/Fortran/gfortran/regression/deferred_character_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_1.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! +! Tests the fix for PR50221 +! +! Contributed by Clive Page +! and Tobias Burnus +! +! This is from comment #2 by Tobias Burnus. +! +module m + character(len=:), save, allocatable :: str(:) + character(len=2), parameter :: const(3) = ["a1", "b2", "c3"] +end + + use m + call test() + if(allocated(str)) deallocate(str) + call foo +contains + subroutine test() + call doit() +! print *, 'strlen=',len(str),' / array size =',size(str) +! print '(3a)', '>',str(1),'<' +! print '(3a)', '>',str(2),'<' +! print '(3a)', '>',str(3),'<' + if (any (str .ne. const)) STOP 1 + end subroutine test + subroutine doit() + str = const + end subroutine doit + subroutine foo +! +! This is the original PR from Clive Page +! + character(:), allocatable, dimension(:) :: array + array = (/'xx', 'yy', 'zz'/) +! print *, 'array=', array, len(array(1)), size(array) + if (any (array .ne. ["xx", "yy", "zz"])) STOP 2 + end subroutine +end diff --git a/Fortran/gfortran/regression/deferred_character_10.f90 b/Fortran/gfortran/regression/deferred_character_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_10.f90 @@ -0,0 +1,52 @@ +! { dg-do run } +! +! Checks that PR60593 is fixed (Revision: 214757) +! +! Contributed by Steve Kargl +! +! Main program added for this test. +! +module stringhelper_m + + implicit none + + type :: string_t + character(:), allocatable :: string + end type + + interface len + function strlen(s) bind(c,name='strlen') + use iso_c_binding + implicit none + type(c_ptr), intent(in), value :: s + integer(c_size_t) :: strlen + end function + end interface + + contains + + function C2FChar(c_charptr) result(res) + use iso_c_binding + type(c_ptr), intent(in) :: c_charptr + character(:), allocatable :: res + character(kind=c_char,len=1), pointer :: string_p(:) + integer i, c_str_len + c_str_len = int(len(c_charptr)) + call c_f_pointer(c_charptr, string_p, [c_str_len]) + allocate(character(c_str_len) :: res) + forall (i = 1:c_str_len) res(i:i) = string_p(i) + end function + +end module + + use stringhelper_m + use iso_c_binding + implicit none + type(c_ptr) :: cptr + character(20), target :: str + + str = "abcdefghij"//char(0) + cptr = c_loc (str) + if (len (C2FChar (cptr)) .ne. 10) STOP 1 + if (C2FChar (cptr) .ne. "abcdefghij") STOP 2 +end diff --git a/Fortran/gfortran/regression/deferred_character_11.f90 b/Fortran/gfortran/regression/deferred_character_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_11.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! +! Test the fix for PR61147. +! +! Contributed by Thomas Clune +! +module B_mod + + type :: B + character(:), allocatable :: string + end type B + +contains + + function toPointer(this) result(ptr) + character(:), pointer :: ptr + class (B), intent(in), target :: this + + ptr => this%string + + end function toPointer + +end module B_mod + +program main + use B_mod + + type (B) :: obj + character(:), pointer :: p + + obj%string = 'foo' + p => toPointer(obj) + + If (len (p) .ne. 3) STOP 1 + If (p .ne. "foo") STOP 2 + +end program main + + diff --git a/Fortran/gfortran/regression/deferred_character_12.f90 b/Fortran/gfortran/regression/deferred_character_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_12.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! +! Tests the fix for PR63232 +! +! Contributed by Balint Aradi +! +module mymod + implicit none + + type :: wrapper + character(:), allocatable :: string + end type wrapper + +contains + + + subroutine sub2(mystring) + character(:), allocatable, intent(out) :: mystring + + mystring = "test" + + end subroutine sub2 + +end module mymod + + +program test + use mymod + implicit none + + type(wrapper) :: mywrapper + + call sub2(mywrapper%string) + if (.not. allocated(mywrapper%string)) STOP 1 + if (trim(mywrapper%string) .ne. "test") STOP 2 + +end program test diff --git a/Fortran/gfortran/regression/deferred_character_13.f90 b/Fortran/gfortran/regression/deferred_character_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_13.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! +! Tests the fix for PR49630 comment #3. +! +! Contributed by Janus Weil +! +module abc + implicit none + + type::abc_type + contains + procedure::abc_function + end type abc_type + +contains + + function abc_function(this) + class(abc_type),intent(in)::this + character(:),allocatable::abc_function + allocate(abc_function,source="hello") + end function abc_function + + subroutine do_something(this) + class(abc_type),intent(in)::this + if (this%abc_function() .ne. "hello") STOP 1 + end subroutine do_something + +end module abc + + + use abc + type(abc_type) :: a + call do_something(a) +end diff --git a/Fortran/gfortran/regression/deferred_character_14.f90 b/Fortran/gfortran/regression/deferred_character_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_14.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! +! Test fix for PR60795 comments #1 and #4 +! +! Contributed by Kergonath +! +module m +contains + subroutine allocate_array(s_array) + character(:), dimension(:), allocatable, intent(out) :: s_array + + allocate(character(2) :: s_array(2)) + s_array = ["ab","cd"] + end subroutine +end module + +program stringtest + use m + character(:), dimension(:), allocatable :: s4 + character(:), dimension(:), allocatable :: s +! Comment #1 + allocate(character(1) :: s(10)) + if (size (s) .ne. 10) STOP 1 + if (len (s) .ne. 1) STOP 2 +! Comment #4 + call allocate_array(s4) + if (size (s4) .ne. 2) STOP 3 + if (len (s4) .ne. 2) STOP 4 + if (any (s4 .ne. ["ab", "cd"])) STOP 5 + end program diff --git a/Fortran/gfortran/regression/deferred_character_15.f90 b/Fortran/gfortran/regression/deferred_character_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_15.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! +! Test the fix for PR69423. +! +! Contributed by Antony Lewis +! +program tester + character(LEN=:), allocatable :: S + S= test(2) + if (len(S) .ne. 4) STOP 1 + if (S .ne. "test") STOP 2 + if (allocated (S)) deallocate (S) + + S= test2(2) + if (len(S) .ne. 4) STOP 3 + if (S .ne. "test") STOP 4 + if (allocated (S)) deallocate (S) +contains + function test(alen) + character(LEN=:), allocatable :: test + integer alen, i + do i = alen, 1, -1 + test = 'test' + exit + end do +! This line would print nothing when compiled with -O1 and higher. +! print *, len(test),test + if (len(test) .ne. 4) STOP 5 + if (test .ne. "test") STOP 6 + end function test + + function test2(alen) result (test) + character(LEN=:), allocatable :: test + integer alen, i + do i = alen, 1, -1 + test = 'test' + exit + end do +! This worked before the fix. +! print *, len(test),test + if (len(test) .ne. 4) STOP 7 + if (test .ne. "test") STOP 8 + end function test2 +end program tester diff --git a/Fortran/gfortran/regression/deferred_character_16.f90 b/Fortran/gfortran/regression/deferred_character_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_16.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! PR70592 dynamically-allocated character array +! Contributed by Peter Knowles +! +PROGRAM main + character(len=7) :: res + CHARACTER(len=:), DIMENSION(:), POINTER :: cp + INTEGER :: i + ALLOCATE(CHARACTER(len=1) :: cp(1:6)) + if (SIZE(cp) /= 6 .or. LBOUND(cp,1) /= 1 .or. UBOUND(cp,1) /= 6) STOP 1 + cp(1)='1' + cp(2)='2' + cp(3)='3' + cp(4)='4' + cp(5)='5' + cp(6)='6' + write (res, *) cp + if (res /= ' 123456') STOP 2 +END PROGRAM main diff --git a/Fortran/gfortran/regression/deferred_character_17.f90 b/Fortran/gfortran/regression/deferred_character_17.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_17.f90 @@ -0,0 +1,13 @@ +!{ dg-do run } + +! Check fix for PR fortran/71623 + +program allocatemvce + implicit none + character(len=:), allocatable :: string + integer, dimension(4), target :: array = [1,2,3,4] + integer, dimension(:), pointer :: array_ptr + array_ptr => array + ! The allocate used to segfault + allocate(character(len=size(array_ptr))::string) +end program allocatemvce diff --git a/Fortran/gfortran/regression/deferred_character_18.f90 b/Fortran/gfortran/regression/deferred_character_18.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_18.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! PR Fortran/82367 +! Contributed by Walter Spector +module cls_allocmod + implicit none + +contains + + subroutine cls_alloc (n, str) + integer, intent(in) :: n + character(*), allocatable, intent(out) :: str +! Note: Star ^ should have been a colon (:) + + allocate (character(n)::str) + + end subroutine + +end module + +program cls + use cls_allocmod + implicit none + + character(:), allocatable :: s + + call cls_alloc(42, s) ! { dg-error "allocatable or pointer dummy argument" } + print *, 'string len =', len(s) + +end program diff --git a/Fortran/gfortran/regression/deferred_character_19.f90 b/Fortran/gfortran/regression/deferred_character_19.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_19.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! +! Test fix for PR80945, in which the character length was fixed at zero. +! +! Contributed by Nicolas Koenig +! +program main + implicit none + integer:: i + integer, parameter:: N = 10 + character(20) :: buffer + character(len=:), dimension(:),allocatable:: ca + character(len=:), dimension(:,:),allocatable:: cb + allocate(character(len=N) :: ca(3)) + ca(1) = "foo" + ca(2) = "bar" + ca(3) = "xyzzy" + write (buffer, '(3A5)') ca(1:3) + if (trim (buffer) .ne. "foo bar xyzzy") stop 1 +end program diff --git a/Fortran/gfortran/regression/deferred_character_2.f90 b/Fortran/gfortran/regression/deferred_character_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_2.f90 @@ -0,0 +1,85 @@ +! { dg-do run } +! +! Tests the fix for PR68216 +! +! Reported on clf: https://groups.google.com/forum/#!topic/comp.lang.fortran/eWQTKfqKLZc +! +PROGRAM hello +! +! This is based on the first testcase, from Francisco (Ayyy LMAO). Original +! lines are commented out. The second testcase from this thread is acalled +! at the end of the program. +! + IMPLICIT NONE + + CHARACTER(LEN=:),DIMENSION(:),ALLOCATABLE :: array_lineas + CHARACTER(LEN=:),DIMENSION(:),ALLOCATABLE :: array_copia + character (3), dimension (2) :: array_fijo = ["abc","def"] + character (100) :: buffer + INTEGER :: largo , cant_lineas , i + + write (buffer, "(2a3)") array_fijo + +! WRITE(*,*) ' Escriba un numero para el largo de cada linea' +! READ(*,*) largo + largo = LEN (array_fijo) + +! WRITE(*,*) ' Escriba la cantidad de lineas' +! READ(*,*) cant_lineas + cant_lineas = size (array_fijo, 1) + + ALLOCATE(CHARACTER(LEN=largo) :: array_lineas(cant_lineas)) + +! WRITE(*,*) 'Escriba el array', len(array_lineas), size(array_lineas) + READ(buffer,"(2a3)") (array_lineas(i),i=1,cant_lineas) + +! WRITE(*,*) 'Array guardado: ' +! DO i=1,cant_lineas +! WRITE(*,*) array_lineas(i) +! ENDDO + if (any (array_lineas .ne. array_fijo)) STOP 1 + +! The following are additional tests beyond that of the original. +! +! Check that allocation with source = another deferred length is OK + allocate (array_copia, source = array_lineas) + if (any (array_copia .ne. array_fijo)) STOP 2 + deallocate (array_lineas, array_copia) + +! Check that allocation with source = a non-deferred length is OK + allocate (array_lineas, source = array_fijo) + if (any (array_lineas .ne. array_fijo)) STOP 3 + deallocate (array_lineas) + +! Check that allocation with MOLD = a non-deferred length is OK + allocate (array_copia, mold = [array_fijo(:)(1:2), array_fijo(:)(1:2)]) + if (size (array_copia, 1) .ne. 4) STOP 4 + if (LEN (array_copia, 1) .ne. 2) STOP 5 + +! Check that allocation with MOLD = another deferred length is OK + allocate (array_lineas, mold = array_copia) + if (size (array_copia, 1) .ne. 4) STOP 6 + if (LEN (array_copia, 1) .ne. 2) STOP 7 + deallocate (array_lineas, array_copia) + +! READ(*,*) + call testdefchar +contains + subroutine testdefchar +! +! This is the testcase in the above thread from Blokbuster +! + implicit none + character(:), allocatable :: test(:) + + allocate(character(3) :: test(2)) + test(1) = 'abc' + test(2) = 'def' + if (any (test .ne. ['abc', 'def'])) STOP 8 + + test = ['aa','bb','cc'] + if (any (test .ne. ['aa', 'bb', 'cc'])) STOP 9 + + end subroutine testdefchar + +END PROGRAM diff --git a/Fortran/gfortran/regression/deferred_character_20.f90 b/Fortran/gfortran/regression/deferred_character_20.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_20.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! +! Test the fix for PR86408. +! +! Contributed by Janus Weil +! +module m + + implicit none + + type, abstract :: t + contains + procedure(ifc), deferred :: tbf + procedure :: tbs + end type + + abstract interface + function ifc(x) result(str) + import :: t + class(t) :: x + character(len=:), allocatable :: str + end function + end interface + +contains + + subroutine tbs(x) + class(t) :: x + print *, x%tbf() + end subroutine + +end diff --git a/Fortran/gfortran/regression/deferred_character_21.f90 b/Fortran/gfortran/regression/deferred_character_21.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_21.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! { dg-options "-O3" } +! +! Tests the fix for PR85954 in which the gimplifier could not determine +! the space required for the dummy argument data types, when inlining the +! subroutines. +! +! Contributed by G.Steinmetz +! +program p + character(kind=1,len=:), allocatable :: z(:) + allocate (z, source = ["xyz"]) + print *, allocated(z), size(z), len(z), z + call s(z) + call t(z) +contains + subroutine s(x) + character(kind=1,len=:), allocatable :: x(:) + x = ['abcd'] + print *, allocated(x), size(x), len(x), x + end + subroutine t(x) + character(kind=1,len=:), allocatable :: x(:) + associate (y => x) + y = ['abc'] + end associate + print *, allocated(x), size(x), len(x), x + end +end diff --git a/Fortran/gfortran/regression/deferred_character_22.f90 b/Fortran/gfortran/regression/deferred_character_22.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_22.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! +! Test the fix for PR77325, which casued an ICE in the gimplifier. The +! segafults in 'contains_struct_check' were found while diagnosing the PR. +! +! Contributed by Gerhard Steinmetz +! +program p + character(3), parameter :: a(3) = ['abc', 'def', 'ghi'] + character(1), parameter :: c(3) = ['a', 'b', 'c'] + character(:), allocatable :: z(:) + z = c([3,2]) ! Vector subscripts caused an iCE in the gimplifier. + if (any (z .ne. ['c', 'b'])) stop 1 + z = c + if (any (z .ne. ['a', 'b', 'c'])) stop 2 + z = c(2:1:-1) + if (any (z .ne. ['b', 'a'])) stop 3 + z = c(3) + if (any (z .ne. ['c', 'c'])) stop 4 + z = a([3,1,2]) + if (any (z .ne. ['ghi', 'abc', 'def'])) stop 5 + z = a(1:2)(2:3) ! Substrings caused a segfault in 'contains_struct_check'. + if (any (z .ne. ['bc', 'ef'])) stop 6 + z = a([2,3,1])(2:3) ! ditto + if (any (z .ne. ['ef', 'hi', 'bc'])) stop 7 + deallocate (z) +end diff --git a/Fortran/gfortran/regression/deferred_character_23.f90 b/Fortran/gfortran/regression/deferred_character_23.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_23.f90 @@ -0,0 +1,68 @@ +! { dg-do run } +! +! Tests the fix for PR85603. +! +! Contributed by Walt Spector +!_____________________________________________ +! Module for a test against a regression that occurred with +! the first patch for this PR. +! +MODULE TN4 + IMPLICIT NONE + PRIVATE + INTEGER,PARAMETER::SH4=KIND('a') + TYPE,PUBLIC::TOP + CHARACTER(:,KIND=SH4),ALLOCATABLE::ROR + CHARACTER(:,KIND=SH4),ALLOCATABLE::VI8 + CONTAINS + PROCEDURE,NON_OVERRIDABLE::SB=>TPX + END TYPE TOP +CONTAINS + SUBROUTINE TPX(TP6,PP4) + CLASS(TOP),INTENT(INOUT)::TP6 + INTEGER,INTENT(IN)::PP4 + TP6%ROR=TP6%ROR(:PP4-1) + TP6%VI8=TP6%ROR(:PP4-1) + END SUBROUTINE TPX +END MODULE TN4 +!_____________________________________________ +! +program strlen_bug + implicit none + + character(:), allocatable :: strings(:) + integer :: maxlen + + strings = [ character(32) :: & + 'short', & + 'somewhat longer' ] + maxlen = maxval (len_trim (strings)) + if (maxlen .ne. 15) stop 1 + +! Used to cause an ICE and in the later version of the problem did not reallocate. + strings = strings(:)(:maxlen) + if (any (strings .ne. ['short ','somewhat longer' ])) stop 2 + if (len (strings) .ne. maxlen) stop 3 + +! Try something a bit more complicated. + strings = strings(:)(2:maxlen - 5) + if (any (strings .ne. ['hort ','omewhat l' ])) stop 4 + if (len (strings) .ne. maxlen - 6) stop 5 + + deallocate (strings) ! To check for memory leaks + +! Test the regression, noted by Dominique d'Humieres is fixed. +! Referenced in https://groups.google.com/forum/#!topic/comp.lang.fortran/nV3TlRlVKBc +! + call foo +contains + subroutine foo + USE TN4 + TYPE(TOP) :: Z + + Z%ROR = 'abcd' + call Z%SB (3) + if (Z%VI8 .ne. 'ab') stop 6 +end + +end program diff --git a/Fortran/gfortran/regression/deferred_character_24.f90 b/Fortran/gfortran/regression/deferred_character_24.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_24.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! +! Test the fix for PR70149 in which the string length for +! 'number_string' was not initialized. +! +! Contributed by Walter Spector +! +module myptr_mod + implicit none + + integer, target, save :: int_data = 42 + character(16), target, save :: char_data = 'forty two' + + integer, pointer :: number => int_data + character(:), pointer :: number_string => char_data + +end module + + use myptr_mod + if (LEN (number_string) .ne. 16) stop 1 + if (trim (number_string) .ne. 'forty two') stop 2 +end + diff --git a/Fortran/gfortran/regression/deferred_character_25.f90 b/Fortran/gfortran/regression/deferred_character_25.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_25.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! +! Test the fix for PR70752 in which the type of the component 'c' is cast +! as character[1:0], which makes it slightly more difficult than usual to +! obtain the element length. This is one and the same bug as PR72709. +! +! Contributed by Gilbert Scott +! +PROGRAM TEST + IMPLICIT NONE + INTEGER, PARAMETER :: I = 3 + character (len = i), parameter :: str(5) = ['abc','cde','fgh','ijk','lmn'] + + TYPE T + CHARACTER(LEN=:), ALLOCATABLE :: C(:) + END TYPE T + TYPE(T), TARGET :: S + CHARACTER (LEN=I), POINTER :: P(:) + + ALLOCATE ( CHARACTER(LEN=I) :: S%C(5) ) + s%c = str + +! This PR uncovered several problems associated with determining the +! element length and indexing. Test fairly thoroughly! + if (SIZE(S%C, 1) .ne. 5) stop 1 + if (LEN(S%C) .ne. 3) stop 2 + if (any (s%c .ne. str)) stop 3 + if (s%c(3) .ne. str(3)) stop 4 + P => S%C + if (SIZE(p, 1) .ne. 5) stop 5 + if (LEN(p) .ne. 3) stop 6 + if (any (p .ne. str)) stop 7 + if (p(5) .ne. str(5)) stop 8 +END PROGRAM TEST diff --git a/Fortran/gfortran/regression/deferred_character_26.f90 b/Fortran/gfortran/regression/deferred_character_26.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_26.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +! +! Test the fix for PR72709 in which the type of the component 'header' is cast +! as character[1:0], which makes it slightly more difficult than usual to +! obtain the element length. This is one and the same bug as PR70752. +! +! Contributed by 'zmi' +! +program read_exp_data + implicit none + + type experimental_data_t + integer :: nh = 0 + character(len=:), dimension(:), allocatable :: header + + end type experimental_data_t + + character(*), parameter :: str(3) = ["#Generated by X ", & + "#from file 'Y' ", & + "# Experimental 4 mg/g"] + type(experimental_data_t) :: ex + integer :: nh_len + integer :: i + + + nh_len = 255 + ex % nh = 3 + allocate(character(len=nh_len) :: ex % header(ex % nh)) + + ex % header(1) = str(1) + ex % header(2) = str(2) + ex % header(3) = str(3) + +! Test that the string length is OK + if (len (ex%header) .ne. nh_len) stop 1 + +! Test the array indexing + do i = 1, ex % nh + if (trim (ex%header(i)) .ne. trim (str(i))) stop i + 1 + enddo + +end program read_exp_data diff --git a/Fortran/gfortran/regression/deferred_character_27.f90 b/Fortran/gfortran/regression/deferred_character_27.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_27.f90 @@ -0,0 +1,87 @@ +! { dg-do compile } +! +! Make sure that PR82617 remains fixed. The first attempt at a +! fix for PR70752 cause this to ICE at the point indicated below. +! +! Contributed by Ogmundur Petersson +! +MODULE test + + IMPLICIT NONE + + PRIVATE + PUBLIC str_words + + !> Characters that are considered whitespace. + CHARACTER(len=*), PARAMETER :: strwhitespace = & + char(32)//& ! space + char(10)//& ! new line + char(13)//& ! carriage return + char( 9)//& ! horizontal tab + char(11)//& ! vertical tab + char(12) ! form feed (new page) + + CONTAINS + + ! ------------------------------------------------------------------- + !> Split string into words separated by arbitrary strings of whitespace + !> characters (space, tab, newline, return, formfeed). + FUNCTION str_words(str,white) RESULT(items) + CHARACTER(len=:), DIMENSION(:), ALLOCATABLE :: items + CHARACTER(len=*), INTENT(in) :: str !< String to split. + CHARACTER(len=*), INTENT(in) :: white ! Whitespace characters. + + items = strwords_impl(str,white) + + END FUNCTION str_words + + ! ------------------------------------------------------------------- + !>Implementation of str_words + !> characters (space, tab, newline, return, formfeed). + FUNCTION strwords_impl(str,white) RESULT(items) + CHARACTER(len=:), DIMENSION(:), ALLOCATABLE :: items + CHARACTER(len=*), INTENT(in) :: str !< String to split. + CHARACTER(len=*), INTENT(in) :: white ! Whitespace characters. + + INTEGER :: i0,i1,n + INTEGER :: l_item,i_item,n_item + + n = verify(str,white,.TRUE.) + IF (n>0) THEN + n_item = 0 + l_item = 0 + i1 = 0 + DO + i0 = verify(str(i1+1:n),white)+i1 + i1 = scan(str(i0+1:n),white) + n_item = n_item+1 + IF (i1>0) THEN + l_item = max(l_item,i1) + i1 = i0+i1 + ELSE + l_item = max(l_item,n-i0+1) + EXIT + END IF + END DO + ALLOCATE(CHARACTER(len=l_item)::items(n_item)) + i_item = 0 + i1 = 0 + DO + i0 = verify(str(i1+1:n),white)+i1 + i1 = scan(str(i0+1:n),white) + i_item = i_item+1 + IF (i1>0) THEN + i1 = i0+i1 + items(i_item) = str(i0:i1-1) + ELSE + items(i_item) = str(i0:n) + EXIT + END IF + END DO + ELSE + ALLOCATE(CHARACTER(len=0)::items(0)) + END IF + + END FUNCTION strwords_impl + +END MODULE test diff --git a/Fortran/gfortran/regression/deferred_character_28.f90 b/Fortran/gfortran/regression/deferred_character_28.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_28.f90 @@ -0,0 +1,60 @@ +! { dg-do run } +! +! Test the fix for PR80931, which was nearly fix by the patch for PR87151. +! However, the 'span' for 'temp' was not being set and so a segfault +! occurred in the assignment at line 39. +! +! Contributed by Tiziano Mueller +! +module input_section_types + type :: section + character(len=:), allocatable :: keywords_(:) + + contains + procedure, pass :: add_keyword + end type + + interface section + procedure constructor + end interface + +contains + + type(section) function constructor () + allocate (character(len=255) :: constructor%keywords_(0)) + end function + + subroutine add_keyword (this, name) + class(section), intent(inout) :: this + character(*), intent(in) :: name + character(len=:), allocatable :: temp(:) + + integer :: n_elements + + n_elements = size (this%keywords_) + allocate (character(len=255) :: temp(n_elements+1)) + temp(:n_elements) = this%keywords_ + call move_alloc (temp, this%keywords_) + + this%keywords_(n_elements+1) = name + end subroutine +end module + + use input_section_types + type(section) :: s + character(*), parameter :: hello = "Hello World" + character(*), parameter :: bye = "Goodbye World" + + s = constructor () + + call s%add_keyword (hello) + if (len (s%keywords_) .ne. 255) stop 1 + if (size (s%keywords_, 1) .ne. 1) stop 2 + if (trim (s%keywords_(1)) .ne. hello) stop 3 + + call s%add_keyword (bye) + if (len (s%keywords_) .ne. 255) stop 4 + if (size (s%keywords_, 1) .ne. 2) stop 5 + if (trim (s%keywords_(1)) .ne. hello) stop 6 + if (trim (s%keywords_(2)) .ne. bye) stop 7 +end diff --git a/Fortran/gfortran/regression/deferred_character_29.f90 b/Fortran/gfortran/regression/deferred_character_29.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_29.f90 @@ -0,0 +1,197 @@ +! { dg-do compile } +! +! Test the fix for PR83196 comment #4 (there by mistake) +! +! Contributed by Arjen Markus +!____________________________________________________________ +! keyindex.f90 -- +! Class implementing a straightforward keyword/index list +! The idea is to have a very simple implementation to +! store keywords (strings) and return the position in the +! list or vice versa. +!____________________________________________________________ +module keyindices + implicit none + + private + + integer, parameter :: default_keylength = 40 + + type keyindex + integer :: keylength + integer :: lastindex = 0 + character(len=:), dimension(:), allocatable :: keyword + contains + procedure :: init => init_keyindex + procedure :: get_index => get_index_from_list + procedure :: get_key => get_keyword_from_list + procedure :: has_key => has_keyword_in_list + end type keyindex + + public :: keyindex +contains + +! init_keyindex -- +! Initialise the object +! +! Arguments: +! this Keyindex object +! initial_size Initial size of the list (optimisation) +! keylength Maximum length of a keyword (optional) +! +subroutine init_keyindex( this, initial_size, keylength ) + class(keyindex), intent(inout) :: this + integer, intent(in) :: initial_size + integer, intent(in), optional :: keylength + + integer :: keylength_ + + if ( present(keylength) ) then + keylength_ = keylength + else + keylength_ = default_keylength + endif + + ! + ! Allocate the list of keywords + ! + if ( allocated(this%keyword) ) then + deallocate( this%keyword ) + endif + + + allocate( character(len=keylength_):: this%keyword(initial_size) ) + + this%lastindex = 0 + this%keylength = keylength_ +end subroutine init_keyindex + +! get_index_from_list -- +! Look up the keyword in the list and return its index +! +! Arguments: +! this Keyindex object +! keyword Keyword to be looked up +! +! Returns: +! Index in the list +! +! Note: +! If the keyword does not yet exist, add it to the list +! +integer function get_index_from_list( this, keyword ) + class(keyindex), intent(inout) :: this + character(len=*), intent(in) :: keyword + + integer :: i + character(len=this%keylength), dimension(:), allocatable :: newlist + + if ( .not. allocated(this%keyword) ) then + call this%init( 50 ) + endif + + get_index_from_list = 0 + + do i = 1,this%lastindex + if ( this%keyword(i) == keyword ) then + get_index_from_list = i + exit + endif + enddo + + ! + ! Do we need to add it? + ! + if ( get_index_from_list == 0 ) then + if ( size(this%keyword) <= this%lastindex ) then + ! + ! Allocate a larger list + ! + allocate( character(len=this%keylength):: newlist(2*size(this%keyword)) ) + + newlist(1:size(this%keyword)) = this%keyword + call move_alloc( newlist, this%keyword ) + endif + + get_index_from_list = this%lastindex + 1 + this%lastindex = get_index_from_list + this%keyword(get_index_from_list) = keyword + endif +end function get_index_from_list + +! get_keyword_from_list -- +! Look up the keyword in the list by the given index +! +! Arguments: +! this Keyindex object +! idx Index of the keyword +! +! Returns: +! Keyword as stored in the list +! +! Note: +! If the index does not exist, an empty string is returned +! +function get_keyword_from_list( this, idx ) + class(keyindex), intent(inout) :: this + integer, intent(in) :: idx + + character(len=this%keylength) :: get_keyword_from_list + + get_keyword_from_list = ' ' + + if ( idx >= 1 .and. idx <= this%lastindex ) then + get_keyword_from_list = this%keyword(idx) + endif +end function get_keyword_from_list + +! has_keyword_in_list -- +! Look up whether the keyword is stored in the list or not +! +! Arguments: +! this Keyindex object +! keyword Keyword to be looked up +! +! Returns: +! True if the keyword is in the list or false if not +! +logical function has_keyword_in_list( this, keyword ) + class(keyindex), intent(inout) :: this + character(len=*), intent(in) :: keyword + + integer :: i + + has_keyword_in_list = .false. + + do i = 1,this%lastindex + if ( this%keyword(i) == keyword ) then + has_keyword_in_list = .true. + exit + endif + enddo +end function has_keyword_in_list + +end module keyindices + + use keyindices + type(keyindex) :: idx + + call idx%init (3, 8) + + if (idx%get_index ("one") .ne. 1) stop 1 + if (idx%get_index ("two") .ne. 2) stop 2 + if (idx%get_index ("three") .ne. 3) stop 3 + +! Check that new span is generated as list is extended. + if (idx%get_index ("four") .ne. 4) stop 4 + if (idx%get_index ("five") .ne. 5) stop 5 + if (idx%get_index ("six") .ne. 6) stop 6 + +! Search by keyword + if (.not.idx%has_key ("four")) stop 7 + if (idx%has_key ("seven")) stop 8 + +! Search by index + if (idx%get_key (4) .ne. "four") stop 9 + if (idx%get_key (10) .ne. "") stop 10 +end \ No newline at end of file diff --git a/Fortran/gfortran/regression/deferred_character_3.f90 b/Fortran/gfortran/regression/deferred_character_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_3.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! +! Tests the fix for PR67674 +! +! Contributed by Kristopher Kuhlman +! +program test + implicit none + + type string_type + character(len=:), allocatable :: name + end type string_type + type(string_type), allocatable :: my_string_type + + allocate(my_string_type) + allocate(character(len=0) :: my_string_type%name) + +! print *, 'length main program before',len(my_string_type%name) + + call inputreadword1(my_string_type%name) + +! print *, 'length main program after',len(my_string_type%name) +! print *, 'final result:',my_string_type%name + if (my_string_type%name .ne. 'here the word is finally set') STOP 1 + +contains + subroutine inputreadword1(word_intermediate) + character(len=:), allocatable :: word_intermediate + +! print *, 'length intermediate before',len(word_intermediate) + call inputreadword2(word_intermediate) +! print *, 'length intermediate after',len(word_intermediate) +! print *, word_intermediate + + end subroutine inputreadword1 + + subroutine inputreadword2(word) + character(len=:), allocatable :: word + +! print *, 'length inner before',len(word) + word = 'here the word is finally set' ! want automatic reallocation to happen here +! print *, 'length inner after',len(word) +! print *, word + + end subroutine inputreadword2 +end program test diff --git a/Fortran/gfortran/regression/deferred_character_30.f90 b/Fortran/gfortran/regression/deferred_character_30.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_30.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! +! Fix a regression introduced by the patch for PR70149. +! + character (:), pointer :: ptr => NULL() ! The NULL () caused an ICE. + character (6), target :: tgt = 'lmnopq' + ptr => tgt + print *, len (ptr), ptr +end diff --git a/Fortran/gfortran/regression/deferred_character_31.f90 b/Fortran/gfortran/regression/deferred_character_31.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_31.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! +! Test the fix for PR71880 in which the string length for 'p' +! was not set for the pointer assignment. +! +! Contributed by Valery Weber +! +program t + character(:), dimension(:), allocatable, target :: c + character(:), dimension(:), pointer :: p => NULL () + allocate(c, source = ['ABC','DEF','GHI']) + p => c + if (len(p) .ne. len (c)) stop 1 + if (size (p, 1) .ne. size (c, 1)) stop 2 + if (any (p .ne. c)) stop 3 +end program t diff --git a/Fortran/gfortran/regression/deferred_character_32.f90 b/Fortran/gfortran/regression/deferred_character_32.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_32.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! +! Test the fix for PR88117. +! +! Contributed by Gerhard Steinmetz +! +program p + character(:), pointer :: z(:) + allocate (z, source = ['abcd', 'bcde']) + z = (z) ! gimplifier choked here. + if (any (z .ne. ['abcd', 'bcde'])) stop 1 + deallocate (z) +end diff --git a/Fortran/gfortran/regression/deferred_character_33.f90 b/Fortran/gfortran/regression/deferred_character_33.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_33.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! { dg-additional-sources deferred_character_33a.f90 } +! PR fortran/90744 - this used to pass a wrong length +! to an external function without a prototype. +! Original test case by Tomáš Trnka. +module StringModule + implicit none + +contains + function getstr() + character(:), allocatable :: getstr + + getstr = 'OK' + end function +end module +module TestModule + use StringModule + implicit none + +contains + subroutine DoTest() + if (.false.) then + call convrs('A',getstr()) + else + call convrs('B',getstr()) + end if + end subroutine +end module +program external_char_length + use TestModule + + implicit none + + call DoTest() +end program diff --git a/Fortran/gfortran/regression/deferred_character_33a.f90 b/Fortran/gfortran/regression/deferred_character_33a.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_33a.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +subroutine convrs(quanty,fromto) + implicit none + + character(*), intent(in) :: quanty,fromto + + if (len(fromto) /= 2) stop 1 + if (fromto /= 'OK') stop 2 +end subroutine diff --git a/Fortran/gfortran/regression/deferred_character_34.f90 b/Fortran/gfortran/regression/deferred_character_34.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_34.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! PR fortran/90561 +! This used to ICE. +! Original test case by Gerhard Steinmetz. +program p + character(:), allocatable :: z(:) + z = [character(2):: 'ab', 'xy'] + z = z(2) + if (any(z /= 'xy')) stop 1 +end diff --git a/Fortran/gfortran/regression/deferred_character_35.f90 b/Fortran/gfortran/regression/deferred_character_35.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_35.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! +! Test the fix for PR93794, where the ASSOCIATE statement ICED on the +! deferred character length, pointer component. +! +! Contributed by Gerhard Steinmetz +! +program p + type t + character(:), pointer :: a + end type + type(t) :: z + character(4), target :: c = 'abcd' + z%a => c + associate (y => z%a) + print *, y + end associate +end diff --git a/Fortran/gfortran/regression/deferred_character_36.f90 b/Fortran/gfortran/regression/deferred_character_36.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_36.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! +! Test the fix for PR93833, which ICEd as shown. +! +! Contributed by Gerhard Steinmetz +! +program p + character(:), allocatable :: c + c = "wxyz" +contains + subroutine s + associate (y => [c]) + if (any(y /= [c])) stop 1 + end associate + end +end diff --git a/Fortran/gfortran/regression/deferred_character_4.f90 b/Fortran/gfortran/regression/deferred_character_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_4.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! +! Check that PR50221 comment #4 is fixed. +! +! Contributed by Arjen Makus +! +program chk_alloc_string + implicit none + + character(len=:), dimension(:), allocatable :: strings + character(20) :: buffer + integer :: i + + allocate( character(10):: strings(1:3) ) + + strings = [ "A ", "C ", "ABCD", "V " ] + + if (len(strings) .ne. 4) STOP 1 + if (size(strings, 1) .ne. 4) STOP 2 + if (any (strings .ne. [character(len=4) :: "A", "C", "ABCD", "V"])) STOP 3 + + strings = [character(len=4) :: "A", "C", "ABCDE", "V", "zzzz"] + + if (len(strings) .ne. 4) STOP 4 + if (size(strings, 1) .ne. 5) STOP 5 + if (any (strings .ne. [character(len=4) :: "A", "C", "ABCD", "V", "zzzz"])) STOP 6 + + write (buffer, "(5a4)") strings + if (buffer .ne. "A C ABCDV zzzz") STOP 7 +end program chk_alloc_string diff --git a/Fortran/gfortran/regression/deferred_character_5.f90 b/Fortran/gfortran/regression/deferred_character_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_5.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! +! Tests that PR63932 stays fixed. +! +! Contributed by Valery Weber +! +module mod + type :: t + character(:), allocatable :: c + integer :: i + contains + procedure, pass :: get + end type t + type :: u + character(:), allocatable :: c + end type u +contains + subroutine get(this, a) + class(t), intent(in) :: this + character(:), allocatable, intent(out), optional :: a + if (present (a)) a = this%c + end subroutine get +end module mod + +program test + use mod + type(t) :: a + type(u) :: b + a%c = 'something' + call a%get (a = b%c) + if (b%c .ne. 'something') STOP 1 +end program test diff --git a/Fortran/gfortran/regression/deferred_character_6.f90 b/Fortran/gfortran/regression/deferred_character_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_6.f90 @@ -0,0 +1,54 @@ +! { dg-do run } +! +! Tests that PR66408 stays fixed. +! +! Contributed by +! +module mytest + + implicit none + + type vary + character(:), allocatable :: string + end type vary + + interface assignment(=) + module procedure char_eq_vary + end interface assignment(=) + +contains + + subroutine char_eq_vary(my_char,my_vary) + character(:), allocatable, intent(out) :: my_char + type(vary), intent(in) :: my_vary + my_char = my_vary%string + end subroutine char_eq_vary + +end module mytest + + +program thistest + + use mytest, only: vary, assignment(=) + implicit none + + character(:), allocatable :: test_char + character(14), parameter :: str = 'example string' + type(vary) :: test_vary + type(vary) :: my_stuff + + + test_vary%string = str + if (test_vary%string .ne. str) STOP 1 + +! This previously gave a blank string. + my_stuff%string = test_vary + if (my_stuff%string .ne. str) STOP 2 + + test_char = test_vary + if (test_char .ne. str) STOP 3 + + my_stuff = test_vary + if (my_stuff%string .ne. str) STOP 4 + +end program thistest diff --git a/Fortran/gfortran/regression/deferred_character_7.f90 b/Fortran/gfortran/regression/deferred_character_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_7.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! +! Tests the fix for pr49954, in which concatenation to deferred length character +! arrays, at best, did not work correctly. +! +! +! +implicit none + character(len=:), allocatable :: a1(:) + character(len=:), allocatable :: a2(:), a3(:) + character(len=:), allocatable :: b1 + character(len=:), allocatable :: b2 + character(8) :: chr = "IJKLMNOP" + character(48) :: buffer + + a1 = ["ABCDEFGH","abcdefgh"] + a2 = "_"//a1//chr//"_" + if (any (a2 .ne. ["_ABCDEFGHIJKLMNOP_","_abcdefghIJKLMNOP_"])) STOP 1 + +! Check that the descriptor dtype is OK - the array write needs it. + write (buffer, "(2a18)") a2 + if (trim (buffer) .ne. "_ABCDEFGHIJKLMNOP__abcdefghIJKLMNOP_") STOP 2 + +! Make sure scalars survived the fix! + b1 = "ABCDEFGH" + b2 = "_"//b1//chr//"_" + if (b2 .ne. "_ABCDEFGHIJKLMNOP_") STOP 3 + +! Check the dependency is detected and dealt with by generation of a temporary. + a1 = "?"//a1//"?" + if (any (a1 .ne. ["?ABCDEFGH?","?abcdefgh?"])) STOP 4 +! With an array reference... + a1 = "?"//a1(1:2)//"?" + if (any (a1 .ne. ["??ABCDEFGH??","??abcdefgh??"])) STOP 5 +!... together with a substring. + a1 = "?"//a1(1:1)(2:4)//"?" + if (any (a1 .ne. ["??AB?"])) STOP 6 +contains +end diff --git a/Fortran/gfortran/regression/deferred_character_8.f90 b/Fortran/gfortran/regression/deferred_character_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_8.f90 @@ -0,0 +1,84 @@ +! { dg-do run } +! +! Test the fix for all the remaining issues in PR54070. These were all +! concerned with deferred length characters being returned as function results, +! except for comment #23 where the descriptor dtype was not correctly set and +! array IO failed in consequence. +! +! Contributed by Tobias Burnus +! +! The original comment #1 with an allocate statement. +! Allocatable, deferred length scalar resul. +function f() + character(len=:),allocatable :: f + allocate (f, source = "abc") + f ="ABC" +end function +! +! Allocatable, deferred length, explicit, array result +function g(a) result (res) + character(len=*) :: a(:) + character(len (a)) :: b(size (a)) + character(len=:),allocatable :: res(:) + integer :: i + allocate (character(len(a)) :: res(2*size(a))) + do i = 1, len (a) + b(:)(i:i) = char (ichar (a(:)(i:i)) + 4) + end do + res = [a, b] +end function +! +! Allocatable, deferred length, array result +function h(a) + character(len=*) :: a(:) + character(len(a)) :: b (size(a)) + character(len=:),allocatable :: h(:) + integer :: i + allocate (character(len(a)) :: h(size(a))) + do i = 1, len (a) + b(:)(i:i) = char (ichar (a(:)(i:i)) + 32) + end do + h = b +end function + +module deferred_length_char_array +contains + function return_string(argument) + character(*) :: argument + character(:), dimension(:), allocatable :: return_string + allocate (character (len(argument)) :: return_string(2)) + return_string = argument + end function +end module + + use deferred_length_char_array + character(len=3) :: chr(3) + character(:), pointer :: s(:) + character(6) :: buffer + interface + function f() + character(len=:),allocatable :: f + end function + function g(a) result(res) + character(len=*) :: a(:) + character(len=:),allocatable :: res(:) + end function + function h(a) + character(len=*) :: a(:) + character(len=:),allocatable :: h(:) + end function + end interface + + if (f () .ne. "ABC") STOP 1 + if (any (g (["ab","cd"]) .ne. ["ab","cd","ef","gh"])) STOP 2 + chr = h (["ABC","DEF","GHI"]) + if (any (chr .ne. ["abc","def","ghi"])) STOP 3 + if (any (return_string ("abcdefg") .ne. ["abcdefg","abcdefg"])) STOP 4 + +! Comment #23 + allocate(character(3)::s(2)) + s(1) = 'foo' + s(2) = 'bar' + write (buffer, '(2A3)') s + if (buffer .ne. 'foobar') STOP 5 +end diff --git a/Fortran/gfortran/regression/deferred_character_9.f90 b/Fortran/gfortran/regression/deferred_character_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_9.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! +! Test the fix for PR64324 in which deferred length user ops +! were being mistaken as assumed length and so rejected. +! +! Contributed by Ian Harvey +! +MODULE m + IMPLICIT NONE + INTERFACE OPERATOR(.ToString.) + MODULE PROCEDURE tostring + END INTERFACE OPERATOR(.ToString.) +CONTAINS + FUNCTION tostring(arg) + INTEGER, INTENT(IN) :: arg + CHARACTER(:), ALLOCATABLE :: tostring + allocate (character(5) :: tostring) + write (tostring, "(I5)") arg + END FUNCTION tostring +END MODULE m + + use m + character(:), allocatable :: str + integer :: i = 999 + str = .ToString. i + if (str .ne. " 999") STOP 1 +end + diff --git a/Fortran/gfortran/regression/deferred_character_assignment_1.f90 b/Fortran/gfortran/regression/deferred_character_assignment_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_character_assignment_1.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! +! Checks the fix for PR67977 in which automatic reallocation on assignment +! was performed when the lhs had a substring reference. +! +! Contributed by Anton Shterenlikht +! + character(:), allocatable :: z + integer :: length + z = "cockatoo" + length = len (z) + z(:) = '' + if (len(z) .ne. length) STOP 1 + if (trim (z) .ne. '') STOP 2 + z(:3) = "foo" + if (len(z) .ne. length) STOP 3 + if (trim (z) .ne. "foo") STOP 4 + z(4:) = "__bar" + if (len(z) .ne. length) STOP 5 + if (trim (z) .ne. "foo__bar") STOP 6 + deallocate (z) +end diff --git a/Fortran/gfortran/regression/deferred_type_component_1.f90 b/Fortran/gfortran/regression/deferred_type_component_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_type_component_1.f90 @@ -0,0 +1,60 @@ +! { dg-do run } +! +! PR 51976: [F2003] Support deferred-length character components of derived types (allocatable string length) +! +! Contributed by Tobias Burnus + + type t + character(len=:), allocatable :: str_comp + character(len=:), allocatable :: str_comp1 + end type t + type(t) :: x + type(t), allocatable, dimension(:) :: array + + ! Check scalars + allocate (x%str_comp, source = "abc") + call check (x%str_comp, "abc") + deallocate (x%str_comp) + allocate (x%str_comp, source = "abcdefghijklmnop") + call check (x%str_comp, "abcdefghijklmnop") + x%str_comp = "xyz" + call check (x%str_comp, "xyz") + x%str_comp = "abcdefghijklmnop" + x%str_comp1 = "lmnopqrst" + call foo (x%str_comp1, "lmnopqrst") + call bar (x, "abcdefghijklmnop", "lmnopqrst") + + ! Check arrays and structure constructors + allocate (array(2), source = [t("abcedefg","hi"), t("jkl","mnop")]) + call check (array(1)%str_comp, "abcedefg") + call check (array(1)%str_comp1, "hi") + call check (array(2)%str_comp, "jkl") + call check (array(2)%str_comp1, "mnop") + deallocate (array) + allocate (array(3), source = [x, x, x]) + array(2)%str_comp = "blooey" + call bar (array(1), "abcdefghijklmnop", "lmnopqrst") + call bar (array(2), "blooey", "lmnopqrst") + call bar (array(3), "abcdefghijklmnop", "lmnopqrst") + +contains + + subroutine foo (chr1, chr2) + character (*) :: chr1, chr2 + call check (chr1, chr2) + end subroutine + + subroutine bar (a, chr1, chr2) + character (*) :: chr1, chr2 + type(t) :: a + call check (a%str_comp, chr1) + call check (a%str_comp1, chr2) + end subroutine + + subroutine check (chr1, chr2) + character (*) :: chr1, chr2 + if (len(chr1) .ne. len (chr2)) STOP 1 + if (chr1 .ne. chr2) STOP 2 + end subroutine + +end diff --git a/Fortran/gfortran/regression/deferred_type_component_2.f90 b/Fortran/gfortran/regression/deferred_type_component_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_type_component_2.f90 @@ -0,0 +1,60 @@ +! { dg-do run } +! +! PR 51976: [F2003] Support deferred-length character components of derived types (allocatable string length) +! +! Contributed by Tobias Burnus + + type t + character(len=:,kind=4), allocatable :: str_comp + character(len=:,kind=4), allocatable :: str_comp1 + end type t + type(t) :: x + type(t), allocatable, dimension(:) :: array + + ! Check scalars + allocate (x%str_comp, source = 4_"abc") + call check (x%str_comp, 4_"abc") + deallocate (x%str_comp) + allocate (x%str_comp, source = 4_"abcdefghijklmnop") + call check (x%str_comp, 4_"abcdefghijklmnop") + x%str_comp = 4_"xyz" + call check (x%str_comp, 4_"xyz") + x%str_comp = 4_"abcdefghijklmnop" + x%str_comp1 = 4_"lmnopqrst" + call foo (x%str_comp1, 4_"lmnopqrst") + call bar (x, 4_"abcdefghijklmnop", 4_"lmnopqrst") + + ! Check arrays and structure constructors + allocate (array(2), source = [t(4_"abcedefg",4_"hi"), t(4_"jkl",4_"mnop")]) + call check (array(1)%str_comp, 4_"abcedefg") + call check (array(1)%str_comp1, 4_"hi") + call check (array(2)%str_comp, 4_"jkl") + call check (array(2)%str_comp1, 4_"mnop") + deallocate (array) + allocate (array(3), source = [x, x, x]) + array(2)%str_comp = 4_"blooey" + call bar (array(1), 4_"abcdefghijklmnop", 4_"lmnopqrst") + call bar (array(2), 4_"blooey", 4_"lmnopqrst") + call bar (array(3), 4_"abcdefghijklmnop", 4_"lmnopqrst") + +contains + + subroutine foo (chr1, chr2) + character (len=*,kind=4) :: chr1, chr2 + call check (chr1, chr2) + end subroutine + + subroutine bar (a, chr1, chr2) + character (len=*,kind=4) :: chr1, chr2 + type(t) :: a + call check (a%str_comp, chr1) + call check (a%str_comp1, chr2) + end subroutine + + subroutine check (chr1, chr2) + character (len=*,kind=4) :: chr1, chr2 + if (len(chr1) .ne. len (chr2)) STOP 1 + if (chr1 .ne. chr2) STOP 2 + end subroutine + +end diff --git a/Fortran/gfortran/regression/deferred_type_component_3.f90 b/Fortran/gfortran/regression/deferred_type_component_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_type_component_3.f90 @@ -0,0 +1,71 @@ +! { dg-do run } +! +! Test the fix for PR87151 by exercising deferred length character +! array components. +! +! Based on the contribution by Valery Weber +! +module bvec + type, public :: bvec_t + private + character(:), dimension(:), allocatable :: vc + contains + PROCEDURE, PASS :: create + PROCEDURE, PASS :: test_bvec + PROCEDURE, PASS :: delete + end type bvec_t +contains + subroutine create (this, switch) + class(bvec_t), intent(inout) :: this + logical :: switch + if (switch) then + allocate (character(2)::this%vc(3)) + if (len (this%vc) .ne. 2) stop 1 ! The orignal problem. Gave 0. + +! Check that reallocation on assign does what it should do as required by +! F2003 7.4.1.3. ie. reallocation occurs because LEN has changed. + this%vc = ['abcd','efgh','ijkl'] + else + allocate (this%vc, source = ['abcd','efgh','ijkl']) + endif + end subroutine create + + subroutine test_bvec (this) + class(bvec_t), intent(inout) :: this + character(20) :: buffer + if (allocated (this%vc)) then + if (len (this%vc) .ne. 4) stop 2 + if (size (this%vc) .ne. 3) stop 3 +! Check array referencing and scalarized array referencing + if (this%vc(2) .ne. 'efgh') stop 4 + if (any (this%vc .ne. ['abcd','efgh','ijkl'])) stop 5 +! Check full array io + write (buffer, *) this%vc + if (trim (buffer(2:)) .ne. 'abcdefghijkl') stop 6 +! Make sure that substrings work correctly + write (buffer, *) this%vc(:)(2:3) + if (trim (buffer(2:)) .ne. 'bcfgjk') stop 7 + write (buffer, *) this%vc(2:)(2:3) + if (trim (buffer(2:)) .ne. 'fgjk') stop 8 + endif + end subroutine test_bvec + + subroutine delete (this) + class(bvec_t), intent(inout) :: this + if (allocated (this%vc)) then + deallocate (this%vc) + endif + end subroutine delete +end module bvec + +program test + use bvec + type(bvec_t) :: a + call a%create (.false.) + call a%test_bvec + call a%delete + + call a%create (.true.) + call a%test_bvec + call a%delete +end program test diff --git a/Fortran/gfortran/regression/deferred_type_param_1.f90 b/Fortran/gfortran/regression/deferred_type_param_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_type_param_1.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! PR fortran/45170 +! +! Character deferred type parameter +! +implicit none +character(len=:), allocatable :: str(:) ! { dg-error "Fortran 2003: deferred type parameter" } + +character(len=4) :: str2*(:) ! { dg-error "Fortran 2003: deferred type parameter" } +end diff --git a/Fortran/gfortran/regression/deferred_type_param_2.f90 b/Fortran/gfortran/regression/deferred_type_param_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_type_param_2.f90 @@ -0,0 +1,62 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +! PR fortran/45170 +! +! Character deferred type parameter +! + +subroutine one(x, y) ! { dg-error "Entity .y. at .1. has a deferred type parameter" } + implicit none + character(len=:), pointer :: x + character(len=:) :: y + character(len=:), allocatable, target :: str2 + character(len=:), target :: str ! { dg-error "deferred type parameter" } +end subroutine one + +subroutine two() + implicit none + character(len=:), allocatable, target :: str1(:) + character(len=5), save, target :: str2 + character(len=:), pointer :: pstr => str2 + character(len=:), pointer :: pstr2(:) +end subroutine two + +subroutine three() +! implicit none ! Disabled because of PR 46152 + character(len=:), allocatable, target :: str1(:) + character(len=5), save, target :: str2 + character(len=:), pointer :: pstr + character(len=:), pointer :: pstr2(:) + + pstr => str2 + pstr2 => str1 + str1 = ["abc"] + pstr2 => str1 + + allocate (character(len=77) :: str1(1)) + allocate (pstr, source=str2) + allocate (pstr, mold=str2) + allocate (pstr) ! { dg-error "requires either a type-spec or SOURCE tag" } + allocate (character(len=:) :: str1(1)) ! { dg-error "cannot contain a deferred type parameter" } + + str1 = [ character(len=2) :: "abc" ] + str1 = [ character(len=:) :: "abc" ] ! { dg-error "cannot contain a deferred type parameter" } +end subroutine three + +subroutine four() + implicit none + character(len=:), allocatable, target :: str + character(len=:), pointer :: pstr + pstr => str + str = "abc" + if(len(pstr) /= len(str) .or. len(str)/= 3) STOP 1 + str = "abcd" + if(len(pstr) /= len(str) .or. len(str)/= 4) STOP 2 +end subroutine four + +subroutine five() +character(len=4) :: str*(:) +allocatable :: str +end subroutine five + diff --git a/Fortran/gfortran/regression/deferred_type_param_3.f90 b/Fortran/gfortran/regression/deferred_type_param_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_type_param_3.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! PR fortran/45170 +! PR fortran/52158 +! +! Contributed by Damian Rouson + +module speaker_class + type speaker + contains + procedure :: speak + end type +contains + function speak(this) + class(speaker) ,intent(in) :: this + character(:) ,allocatable :: speak + end function + subroutine say_something(somebody) + class(speaker) :: somebody + print *,somebody%speak() + end subroutine +end module + diff --git a/Fortran/gfortran/regression/deferred_type_param_4.f90 b/Fortran/gfortran/regression/deferred_type_param_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_type_param_4.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! +! PR fortran/51055 +! PR fortran/49110 +! +! +program test + implicit none + character(len=:), allocatable :: str + integer :: i + i = 5 + str = f() + call printIt () + i = 7 + str = repeat('X', i) + call printIt () +contains + function f() + character(len=i) :: f + f = '1234567890' + end function f + subroutine printIt +! print *, len(str) +! print '(3a)', '>',str,'<' + if (i == 5) then + if (str /= "12345" .or. len(str) /= 5) STOP 1 + else if (i == 7) then + if (str /= "XXXXXXX" .or. len(str) /= 7) STOP 2 + else + STOP 3 + end if + end subroutine +end diff --git a/Fortran/gfortran/regression/deferred_type_param_5.f90 b/Fortran/gfortran/regression/deferred_type_param_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_type_param_5.f90 @@ -0,0 +1,51 @@ +! { dg-do compile } +! +! PR fortran/49110 +! PR fortran/52843 +! +! Based on a contributed code by jwmwalrus@gmail.com +! +! Before, character(len=:) result variable were rejected in PURE functions. +! +module mod1 + use iso_c_binding + implicit none + +contains + pure function c_strlen(str) + character(KIND = C_CHAR), intent(IN) :: str(*) + integer :: c_strlen,i + + i = 1 + do + if (i < 1) then + c_strlen = 0 + return + end if + if (str(i) == c_null_char) exit + i = i + 1 + end do + c_strlen = i - 1 + end function c_strlen + pure function c2fstring(cbuffer) result(string) + character(:), allocatable :: string + character(KIND = C_CHAR), intent(IN) :: cbuffer(*) + integer :: i + + continue + string = REPEAT(' ', c_strlen(cbuffer)) + + do i = 1, c_strlen(cbuffer) + if (cbuffer(i) == C_NULL_CHAR) exit + string(i:i) = cbuffer(i) + enddo + + string = TRIM(string) + end function +end module mod1 + +use mod1 +character(len=:), allocatable :: str +str = c2fstring("ABCDEF"//c_null_char//"GHI") +if (len(str) /= 6 .or. str /= "ABCDEF") STOP 1 +end diff --git a/Fortran/gfortran/regression/deferred_type_param_6.f90 b/Fortran/gfortran/regression/deferred_type_param_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_type_param_6.f90 @@ -0,0 +1,52 @@ +! { dg-do run } +! +! PR fortran/51055 +! PR fortran/49110 +! PR fortran/60334 + +subroutine test() + implicit none + integer :: i = 5 + character(len=:), allocatable :: s1 + character(len=:), pointer :: s2 + character(len=5), target :: fifeC = 'FIVEC' + call sub(s1, i) + if (len(s1) /= 5) STOP 1 + if (s1 /= "ZZZZZ") STOP 2 + s2 => subfunc() + if (len(s2) /= 5) STOP 3 + if (s2 /= "FIVEC") STOP 4 + s1 = addPrefix(subfunc()) + if (len(s1) /= 7) STOP 5 + if (s1 /= "..FIVEC") STOP 6 +contains + subroutine sub(str,j) + character(len=:), allocatable :: str + integer :: j + str = REPEAT("Z",j) + if (len(str) /= 5) STOP 7 + if (str /= "ZZZZZ") STOP 8 + end subroutine sub + function subfunc() result(res) + character(len=:), pointer :: res + res => fifec + if (len(res) /= 5) STOP 9 + if (res /= "FIVEC") STOP 10 + end function subfunc + function addPrefix(str) result(res) + character(len=:), pointer :: str + character(len=:), allocatable :: res + res = ".." // str + end function addPrefix +end subroutine test + +program a + character(len=:),allocatable :: s + integer :: j=2 + s = repeat ('x', j) + if (len(repeat(' ',j)) /= 2) STOP 11 + if (repeat('y',j) /= "yy") STOP 12 + if (len(s) /= 2) STOP 13 + if (s /= "xx") STOP 14 + call test() +end program a diff --git a/Fortran/gfortran/regression/deferred_type_param_8.f90 b/Fortran/gfortran/regression/deferred_type_param_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_type_param_8.f90 @@ -0,0 +1,54 @@ +! { dg-do run } +! +! PR fortran/53642 +! PR fortran/45170 (comments 24, 34, 37) +! + +PROGRAM helloworld + implicit none + character(:),allocatable::string + character(11), parameter :: cmp = "hello world" + real::rnd + integer :: n, i + do i = 1, 10 + call random_number(rnd) + n = ceiling(11*rnd) + call hello(n, string) +! print '(A,1X,I0)', '>' // string // '<', len(string) + if (n /= len (string) .or. string /= cmp(1:n)) STOP 1 + end do + + call test_PR53642() + +contains + + subroutine hello (n,string) + character(:), allocatable, intent(out) :: string + integer,intent(in) :: n + character(11) :: helloworld="hello world" + + string=helloworld(:n) ! Didn't work +! string=(helloworld(:n)) ! Works. +! allocate(string, source=helloworld(:n)) ! Fixed for allocate_with_source_2.f90 +! allocate(string, source=(helloworld(:n))) ! Works. + end subroutine hello + + subroutine test_PR53642() + character(len=4) :: string="123 " + character(:), allocatable :: trimmed + + trimmed = trim(string) + if (len_trim(string) /= len(trimmed)) STOP 2 + if (len(trimmed) /= 3) STOP 3 + if (trimmed /= "123") STOP 4 +! print *,len_trim(string),len(trimmed) + + ! Clear + trimmed = "XXXXXX" + if (trimmed /= "XXXXXX" .or. len(trimmed) /= 6) STOP 5 + + trimmed = string(1:len_trim(string)) + if (len_trim(trimmed) /= 3) STOP 6 + if (trimmed /= "123") STOP 7 + end subroutine test_PR53642 +end PROGRAM helloworld diff --git a/Fortran/gfortran/regression/deferred_type_param_9.f90 b/Fortran/gfortran/regression/deferred_type_param_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_type_param_9.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! +! PR fortran/57596 +! +! Contributed by Valery Weber +! +PROGRAM main + IMPLICIT NONE + call get () + call get2 () +contains + SUBROUTINE get (c_val) + CHARACTER( : ), INTENT( INOUT ), ALLOCATABLE, OPTIONAL :: c_val + CHARACTER( 10 ) :: c_val_tmp + if(present(c_val)) STOP 1 + END SUBROUTINE get + SUBROUTINE get2 (c_val) + CHARACTER( : ), INTENT( OUT ), ALLOCATABLE, OPTIONAL :: c_val + CHARACTER( 10 ) :: c_val_tmp + if(present(c_val)) STOP 2 + END SUBROUTINE get2 +END PROGRAM main diff --git a/Fortran/gfortran/regression/deferred_type_proc_pointer_1.f90 b/Fortran/gfortran/regression/deferred_type_proc_pointer_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_type_proc_pointer_1.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! PR fortran/45170 +! PR fortran/52158 +! +! Contributed by Tobias Burnus + +module test + implicit none + type t + procedure(deferred_len), pointer, nopass :: ppt + end type t +contains + function deferred_len() + character(len=:), allocatable :: deferred_len + deferred_len = 'abc' + end function deferred_len + subroutine doIt() + type(t) :: x + x%ppt => deferred_len + if ("abc" /= x%ppt()) STOP 1 + end subroutine doIt +end module test + +use test +call doIt () +end diff --git a/Fortran/gfortran/regression/deferred_type_proc_pointer_2.f90 b/Fortran/gfortran/regression/deferred_type_proc_pointer_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deferred_type_proc_pointer_2.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! PR fortran/45170 +! PR fortran/52158 + +module test + implicit none + type t + procedure(deferred_len), pointer, nopass :: ppt + end type t +contains + function deferred_len() + character(len=:), allocatable :: deferred_len + deferred_len = 'abc' + end function deferred_len + subroutine doIt() + type(t) :: x + character(:), allocatable :: temp + x%ppt => deferred_len + temp = deferred_len() + if ("abc" /= temp) STOP 1 + end subroutine doIt +end module test + +use test +call doIt () +end diff --git a/Fortran/gfortran/regression/defined_assignment_1.f90 b/Fortran/gfortran/regression/defined_assignment_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/defined_assignment_1.f90 @@ -0,0 +1,90 @@ +! { dg-do run } +! Test the fix for PR46897. +! +! Contributed by Rouson Damian +! +module m0 + implicit none + type component + integer :: i = 0 + contains + procedure :: assign0 + generic :: assignment(=)=>assign0 + end type + type parent + type(component) :: foo + end type + type, extends(parent) :: child + integer :: j + end type +contains + subroutine assign0(lhs,rhs) + class(component), intent(out) :: lhs + class(component), intent(in) :: rhs + lhs%i = 20 + end subroutine + type(child) function new_child() + end function +end module + +module m1 + implicit none + type component1 + integer :: i = 1 + contains + procedure :: assign1 + generic :: assignment(=)=>assign1 + end type + type t + type(component1) :: foo + end type +contains + subroutine assign1(lhs,rhs) + class(component1), intent(out) :: lhs + class(component1), intent(in) :: rhs + lhs%i = 21 + end subroutine +end module + +module m2 + implicit none + type component2 + integer :: i = 2 + end type + interface assignment(=) + module procedure assign2 + end interface + type t2 + type(component2) :: foo + end type +contains + subroutine assign2(lhs,rhs) + type(component2), intent(out) :: lhs + type(component2), intent(in) :: rhs + lhs%i = 22 + end subroutine +end module + +program main + use m0 + use m1 + use m2 + implicit none + type(child) :: infant0 + type(t) :: infant1, newchild1 + type(t2) :: infant2, newchild2 + +! Test the reported problem. + infant0 = new_child() + if (infant0%parent%foo%i .ne. 20) STOP 1 + +! Test the case of comment #1 of the PR. + infant1 = newchild1 + if (infant1%foo%i .ne. 21) STOP 2 + +! Test the case of comment #2 of the PR. + infant2 = newchild2 + if (infant2%foo%i .ne. 2) STOP 3 +end + + diff --git a/Fortran/gfortran/regression/defined_assignment_10.f90 b/Fortran/gfortran/regression/defined_assignment_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/defined_assignment_10.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! +! PR fortran/57697 +! +! Further test of typebound defined assignment +! +module m0 + implicit none + type component + integer :: i = 42 + contains + procedure :: assign0 + generic :: assignment(=) => assign0 + end type + type parent + type(component) :: foo + end type +contains + elemental subroutine assign0(lhs,rhs) + class(component), intent(INout) :: lhs + class(component), intent(in) :: rhs + lhs%i = 20 + end subroutine +end module + +program main + use m0 + implicit none + type(parent), allocatable :: left + type(parent) :: right +! print *, right%foo + left = right +! print *, left%foo + if (left%foo%i /= 20) STOP 1 +end diff --git a/Fortran/gfortran/regression/defined_assignment_11.f90 b/Fortran/gfortran/regression/defined_assignment_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/defined_assignment_11.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! +! PR fortran/57697 +! +! Further test of typebound defined assignment +! +module m0 + implicit none + type :: component + integer :: i = 42 + integer, allocatable :: b + contains + procedure :: assign0 + generic :: assignment(=) => assign0 + end type + type, extends(component) :: comp2 + real :: aa + end type comp2 + type parent + type(component) :: foo + real :: cc + end type + type p2 + type(parent) :: x + end type p2 +contains + elemental subroutine assign0(lhs,rhs) + class(component), intent(INout) :: lhs + class(component), intent(in) :: rhs + lhs%i = 20 + end subroutine +end module + +program main + use m0 + implicit none + type(p2), allocatable :: left + type(p2) :: right +! print *, right%x%foo%i + left = right +! print *, left%x%foo%i + if (left%x%foo%i /= 20) STOP 1 +end diff --git a/Fortran/gfortran/regression/defined_assignment_2.f90 b/Fortran/gfortran/regression/defined_assignment_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/defined_assignment_2.f90 @@ -0,0 +1,74 @@ +! { dg-do run } +! Test the fix for PR46897. defined_assignment_1.f90 checks that the PR +! testcases run correctly, this checks that other requirements of the +! standard are satisfied. +! +module m0 + implicit none + type component + integer :: i = 0 + integer, allocatable :: j(:) + contains + procedure :: assign0 + generic :: assignment(=)=>assign0 + end type + type parent + type(component) :: foo1 + end type + type, extends(parent) :: child + integer :: k = 1000 + integer, allocatable :: l(:) + type(component) :: foo2 + end type +contains + subroutine assign0(lhs,rhs) + class(component), intent(inout) :: lhs + class(component), intent(in) :: rhs + if (lhs%i .eq. 0) then + lhs%i = rhs%i + lhs%j = rhs%j + else + lhs%i = rhs%i*2 + lhs%j = [rhs%j, rhs%j*2] + end if + end subroutine + type(child) function new_child() + new_child%parent%foo1%i = 20 + new_child%foo2%i = 21 + new_child%parent%foo1%j = [99,199] + new_child%foo2%j = [199,299] + new_child%l = [299,399] + new_child%k = 1001 + end function +end module + +program main + use m0 + implicit none + type(child) :: infant0 + +! Check that the INTENT(INOUT) of assign0 is respected and that the +! correct thing is done with allocatable components. + infant0 = new_child() + if (infant0%parent%foo1%i .ne. 20) STOP 1 + if (infant0%foo2%i .ne. 21) STOP 2 + if (any (infant0%parent%foo1%j .ne. [99,199])) STOP 3 + if (any (infant0%foo2%j .ne. [199,299])) STOP 4 + if (infant0%foo2%i .ne. 21) STOP 5 + if (any (infant0%l .ne. [299,399])) STOP 6 + +! Now, since the defined assignment depends on whether or not the 'i' +! component is the default initialization value, the result will be +! different. + infant0 = new_child() + if (infant0%parent%foo1%i .ne. 40) STOP 7 + if (any (infant0%parent%foo1%j .ne. [99,199,198,398])) STOP 8 + if (any (infant0%foo2%j .ne. [199,299,398,598])) STOP 9 + if (infant0%foo2%i .ne. 42) STOP 10 + if (any (infant0%l .ne. [299,399])) STOP 11 + +! Finally, make sure that normal components of the declared type survive. + if (infant0%k .ne. 1001) STOP 12 +end + + diff --git a/Fortran/gfortran/regression/defined_assignment_3.f90 b/Fortran/gfortran/regression/defined_assignment_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/defined_assignment_3.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! Test the fix for PR46897. defined_assignment_1.f90 checks that the PR +! testcases run correctly, this checks array components are OK. +! +module m0 + implicit none + type component + integer :: i = 0 + contains + procedure :: assign0 + generic :: assignment(=)=>assign0 + end type + type parent + type(component) :: foo(2) + end type + type, extends(parent) :: child + integer :: j + end type +contains + impure elemental subroutine assign0(lhs,rhs) + class(component), intent(out) :: lhs + class(component), intent(in) :: rhs + lhs%i = 20 + end subroutine +end module + + +program main + use m0 + implicit none + type(child) :: infant0, infant1(2) + + infant0 = child([component(1),component(2)], 99) + if (any (infant0%parent%foo%i .ne. [20, 20])) STOP 1 + +end + + diff --git a/Fortran/gfortran/regression/defined_assignment_4.f90 b/Fortran/gfortran/regression/defined_assignment_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/defined_assignment_4.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! Test the fix for PR46897. First patch did not run this case correctly. +! Contributed by Tobias Burnus +! +module a_mod + type :: a + integer :: i = 99 + contains + procedure :: a_ass + generic :: assignment(=) => a_ass + end type a + + type c + type(a) :: ta + end type c + + type :: b + type(c) :: tc + end type b + +contains + elemental subroutine a_ass(out, in) + class(a), intent(INout) :: out + type(a), intent(in) :: in + out%i = 2*in%i + end subroutine a_ass +end module a_mod + +program assign + use a_mod + type(b) :: tt + type(b) :: tb1 + tt = tb1 + if (tt%tc%ta%i .ne. 198) STOP 1 +end program assign diff --git a/Fortran/gfortran/regression/defined_assignment_5.f90 b/Fortran/gfortran/regression/defined_assignment_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/defined_assignment_5.f90 @@ -0,0 +1,76 @@ +! { dg-do run } +! Further test of typebound defined assignment +! +module m0 + implicit none + type component + integer :: i = 0 + contains + procedure :: assign0 + generic :: assignment(=)=>assign0 + end type + type parent + type(component) :: foo(2) + end type + type, extends(parent) :: child + integer :: j + end type +contains + elemental subroutine assign0(lhs,rhs) + class(component), intent(INout) :: lhs + class(component), intent(in) :: rhs + lhs%i = 20 + end subroutine +end module + +module m1 + implicit none + type component1 + integer :: i = 0 + contains + procedure :: assign1 + generic :: assignment(=)=>assign1 + end type + type parent1 + type(component1) :: foo + end type + type, extends(parent1) :: child1 + integer :: j = 7 + end type +contains + impure elemental subroutine assign1(lhs,rhs) + class(component1), intent(out) :: lhs + class(component1), intent(in) :: rhs + lhs%i = 30 + end subroutine +end module + + +program main + use m0 + use m1 + implicit none + type(child) :: infant(2) + type(parent) :: dad, mum + type(child1) :: orphan(5) + type(child1), allocatable :: annie(:) + integer :: i, j, k + + dad = parent ([component (3), component (4)]) + mum = parent ([component (5), component (6)]) + infant = [child(dad, 999), child(mum, 9999)] ! { dg-warning "multiple part array references" } + +! Check that array sections are OK + i = 3 + j = 4 + orphan(i:j) = child1(component1(777), 1) + if (any (orphan%parent1%foo%i .ne. [0,0,30,30,0])) STOP 1 + if (any (orphan%j .ne. [7,7,1,1,7])) STOP 2 + +! Check that allocatable lhs's work OK. + annie = [(child1(component1(k), 2*k), k = 1,3)] + if (any (annie%parent1%foo%i .ne. [30,30,30])) STOP 3 + if (any (annie%j .ne. [2,4,6])) STOP 4 +end + + diff --git a/Fortran/gfortran/regression/defined_assignment_6.f90 b/Fortran/gfortran/regression/defined_assignment_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/defined_assignment_6.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! +! PR fortran/57364 +! +! Contributed by Damian Rouson +! +module ref_counter_implementation + type ref_counter + contains + procedure :: assign + generic :: assignment(=) => assign + end type +contains + subroutine assign (lhs, rhs) + class (ref_counter), intent(inout) :: lhs + class (ref_counter), intent(in) :: rhs + end subroutine +end module +module foo_parent_implementation + use ref_counter_implementation ,only: ref_counter + type :: foo_parent + type(ref_counter) :: counter + end type +contains + type(foo_parent) function new_foo_parent() + end function +end module +module foo_implementation + use foo_parent_implementation ,only: foo_parent,new_foo_parent + type, extends(foo_parent) :: foo + end type +contains + type(foo) function new_foo() + new_foo%foo_parent = new_foo_parent() + end function +end module diff --git a/Fortran/gfortran/regression/defined_assignment_7.f90 b/Fortran/gfortran/regression/defined_assignment_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/defined_assignment_7.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! +! PR fortran/57508 +! +module ForTrilinos_ref_counter + type ref_counter + contains + procedure :: assign + generic :: assignment(=) => assign + end type +contains + subroutine assign (lhs, rhs) + class (ref_counter), intent(inout) :: lhs + class (ref_counter), intent(in) :: rhs + end subroutine +end module +module FEpetra_BlockMap + use ForTrilinos_ref_counter, only : ref_counter + type :: Epetra_BlockMap + type(ref_counter) :: counter + end type +contains + function from_struct() result(new_Epetra_BlockMap) + type(Epetra_BlockMap) :: new_Epetra_BlockMap + end function + type(Epetra_BlockMap) function create_arbitrary() + create_arbitrary = from_struct() + end function +end module diff --git a/Fortran/gfortran/regression/defined_assignment_8.f90 b/Fortran/gfortran/regression/defined_assignment_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/defined_assignment_8.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! +! PR fortran/58469 +! +! Related: PR fortran/57697 +! +! Was ICEing before +! +module m0 + implicit none + type :: component + integer :: i = 42 + contains + procedure :: assign0 + generic :: assignment(=) => assign0 + end type + type, extends(component) :: comp2 + real :: aa + end type comp2 + type parent + type(comp2) :: foo + end type +contains + elemental subroutine assign0(lhs,rhs) + class(component), intent(INout) :: lhs + class(component), intent(in) :: rhs + lhs%i = 20 + end subroutine +end module + +program main + use m0 + implicit none + type(parent), allocatable :: left + type(parent) :: right + print *, right%foo + left = right + print *, left%foo + if (left%foo%i /= 42) STOP 1 +end diff --git a/Fortran/gfortran/regression/defined_assignment_9.f90 b/Fortran/gfortran/regression/defined_assignment_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/defined_assignment_9.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! +! PR fortran/57697 +! +! Further test of typebound defined assignment +! +module m0 + implicit none + type component + integer :: i = 42 + contains + procedure :: assign0 + generic :: assignment(=) => assign0 + end type + type parent + type(component) :: foo + end type +contains + elemental subroutine assign0(lhs,rhs) + class(component), intent(INout) :: lhs + class(component), intent(in) :: rhs + lhs%i = 20 + end subroutine +end module + +program main + use m0 + implicit none + block + type(parent), allocatable :: left + type(parent) :: right +! print *, right%foo + left = right +! print *, left%foo + if (left%foo%i /= 20) STOP 1 + end block + block + type(parent), allocatable :: left(:) + type(parent) :: right(5) +! print *, right%foo + left = right +! print *, left%foo + if (any (left%foo%i /= 20)) STOP 2 + end block +end diff --git a/Fortran/gfortran/regression/defined_operators_1.f90 b/Fortran/gfortran/regression/defined_operators_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/defined_operators_1.f90 @@ -0,0 +1,68 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! Tests the fix for PR27122, in which the requirements of 12.3.2.1.1 +! for defined operators were not enforced. +! +! Based on PR test by Thomas Koenig +! +module mymod + interface operator (.foo.) + module procedure foo_0 + module procedure foo_1 + module procedure foo_2 + module procedure foo_3 + module procedure foo_1_OK + module procedure foo_2_OK + function foo_chr (chr) ! { dg-error "cannot be assumed character length" } + character(*) :: foo_chr + character(*), intent(in) :: chr + end function foo_chr + end interface + + ! + ! PR fortran/33117 + ! PR fortran/46478 + ! Mixing FUNCTIONs and SUBROUTINEs in an INTERFACE hides the + ! errors that should be tested here. Hence split out subroutine + ! to test separately. + ! + interface operator (.bar.) + subroutine bad_foo (chr) ! { dg-error "must be a FUNCTION" } + character(*), intent(in) :: chr + end subroutine bad_foo + end interface + +contains + function foo_0 () ! { dg-error "must have at least one argument" } + integer :: foo_1 + foo_0 = 1 + end function foo_0 + function foo_1 (a) ! { dg-error "Ambiguous interfaces" } + integer :: foo_1 + integer, intent(in) :: a + foo_1 = 1 + end function foo_1 + function foo_1_OK (a) ! { dg-error "Ambiguous interfaces" } + integer :: foo_1_OK + integer, intent (in) :: a + foo_1_OK = 1 + end function foo_1_OK + function foo_2 (a, b) ! { dg-error "cannot be optional" } + integer :: foo_2 + integer, intent(in) :: a + integer, intent(in), optional :: b + foo_2 = 2 * a + b + end function foo_2 + function foo_2_OK (a, b) + real :: foo_2_OK + real, intent(in) :: a + real, intent(in) :: b + foo_2_OK = 2.0 * a + b + end function foo_2_OK + function foo_3 (a, b, c) ! { dg-error "must have, at most, two arguments" } + integer :: foo_3 + integer, intent(in) :: a, b, c + foo_3 = a + 3 * b - c + end function foo_3 +end module mymod + diff --git a/Fortran/gfortran/regression/deftype_1.f90 b/Fortran/gfortran/regression/deftype_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/deftype_1.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! Checks for excess errors. +implicit none +dimension i(10) ! { dg-error "has no IMPLICIT type" } +i = 2 +end diff --git a/Fortran/gfortran/regression/dependency_1.f90 b/Fortran/gfortran/regression/dependency_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR23906 +! Dependency analysis was using the stride from the wrong expression and +! segfaulting +subroutine foo(a) + real, dimension(:) :: a + + a(1:3:2) = a(1:2) + a(1:2) = a(1:3:2) +end subroutine + diff --git a/Fortran/gfortran/regression/dependency_10.f90 b/Fortran/gfortran/regression/dependency_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_10.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } +subroutine foo(a) + integer, dimension (4) :: a + integer :: n + + n = 3 + where (a(:n) .ne. 0) + a(:n) = 1 + endwhere +end subroutine +! { dg-final { scan-tree-dump-times "malloc" 0 "original" } } diff --git a/Fortran/gfortran/regression/dependency_11.f90 b/Fortran/gfortran/regression/dependency_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_11.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } +subroutine foo(a) + integer, dimension (4) :: a + integer :: n + + n = 3 + where (a(:n-1) .ne. 0) + a(:n-1) = 1 + endwhere +end subroutine +! { dg-final { scan-tree-dump-times "malloc" 0 "original" } } diff --git a/Fortran/gfortran/regression/dependency_12.f90 b/Fortran/gfortran/regression/dependency_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_12.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } +subroutine foo(a,b) + integer, pointer, dimension (:,:) :: a + real, dimension(:,:) :: b + + where (a == 0) + b = 0.0 + endwhere +end subroutine +! { dg-final { scan-tree-dump-times "malloc" 0 "original" } } diff --git a/Fortran/gfortran/regression/dependency_13.f90 b/Fortran/gfortran/regression/dependency_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_13.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } + integer :: i(5) + real(4) :: x(5) + equivalence(x,i) + + i = (/ 1, 0, 3, 5, 0 /) + where (i(1:4) .ne. 0) + x(2:5) = -42. + end where + end +! { dg-final { scan-tree-dump-times "temp" 3 "original" } } diff --git a/Fortran/gfortran/regression/dependency_14.f90 b/Fortran/gfortran/regression/dependency_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_14.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } +subroutine foo(a,i) + integer, dimension (4,4) :: a + integer :: i + + where (a(i,1:3) .ne. 0) + a(i+1,2:4) = 1 + endwhere +end subroutine +! { dg-final { scan-tree-dump-times "malloc" 0 "original" } } diff --git a/Fortran/gfortran/regression/dependency_15.f90 b/Fortran/gfortran/regression/dependency_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_15.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } +subroutine foo(a,i) + integer, dimension (4,4) :: a + integer :: i + + where (a(i,1:3) .ne. 0) + a(i-1,2:4) = 1 + endwhere +end subroutine +! { dg-final { scan-tree-dump-times "malloc" 0 "original" } } diff --git a/Fortran/gfortran/regression/dependency_16.f90 b/Fortran/gfortran/regression/dependency_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_16.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } +subroutine foo(a,i) + integer, dimension (4,4) :: a + integer :: i + + where (a(i+1,1:3) .ne. 0) + a(i+2,2:4) = 1 + endwhere +end subroutine +! { dg-final { scan-tree-dump-times "malloc" 0 "original" } } diff --git a/Fortran/gfortran/regression/dependency_17.f90 b/Fortran/gfortran/regression/dependency_17.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_17.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } +subroutine foo(a,i) + integer, dimension (3,3,4) :: a + integer :: i + + where (a(1,1:2,1:3) .ne. 0) + a(2:3,3,2:4) = 1 + endwhere +end subroutine +! { dg-final { scan-tree-dump-times "malloc" 0 "original" } } diff --git a/Fortran/gfortran/regression/dependency_18.f90 b/Fortran/gfortran/regression/dependency_18.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_18.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } +subroutine foo(a,i,j,k) + integer, dimension (10) :: a + integer :: i, j, k + + a(1:5:2) = a(8:6:-1) + + a(1:8) = a(2:9) + + a(4:7) = a(4:1:-1) + + a(i:i+2) = a(i+4:i+6) + + a(j:1:-1) = a(j:5) + + a(k:k+2) = a(k+1:k+3) +end subroutine +! { dg-final { scan-tree-dump-times "malloc" 0 "original" } } diff --git a/Fortran/gfortran/regression/dependency_19.f90 b/Fortran/gfortran/regression/dependency_19.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_19.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! Tests the fix for PR30273, in which the pointer assignment was +! wrongly determined to have dependence because NULL() was not +! recognised by the analysis. +! +! Contributed by Harald Anlauf +! +module gfcbug49 + implicit none + + type spot_t + integer, pointer :: vm(:,:,:) + end type spot_t + + type rc_t + integer :: n + type(spot_t), pointer :: spots(:) => NULL() + end type rc_t + +contains + + subroutine construct (rc, n) + type(rc_t), intent(out) :: rc + integer , intent(in) :: n + integer :: k + rc% n = n + allocate (rc% spots (n)) + forall (k=1:n) + rc% spots (k)% vm => NULL() ! gfortran didn't swallow this + end forall + end subroutine construct + +end module gfcbug49 diff --git a/Fortran/gfortran/regression/dependency_2.f90 b/Fortran/gfortran/regression/dependency_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_2.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! Tests the fix for PR20938 in which dependencies between equivalenced +! arrays were not detected. +! +real, dimension (3) :: a = (/1., 2., 3./), b, c +equivalence (a(2), b), (a(1), c) +b = a; +if (any(b .ne. (/1., 2., 3./))) STOP 1 +b = c +if (any(b .ne. (/1., 1., 2./))) STOP 2 +end diff --git a/Fortran/gfortran/regression/dependency_20.f90 b/Fortran/gfortran/regression/dependency_20.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_20.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } + integer :: a(4) + + where (a(:) .ne. 0) + a(:) = (/ 1, 2, 3, 4 /) + endwhere +end +! { dg-final { scan-tree-dump-times "temp" 0 "original" } } diff --git a/Fortran/gfortran/regression/dependency_21.f90 b/Fortran/gfortran/regression/dependency_21.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_21.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! Test the fix for PR31711 in which the dependency in the assignment +! at line 18 was detected and then ignored. +! +! Contributed by Tobias Ivarsson +! +program laplsolv + IMPLICIT NONE + integer, parameter :: n = 2 + double precision,dimension(0:n+1, 0:n+1) :: T + integer :: i + + T=0.0 + T(0:n+1 , 0) = 1.0 + T(0:n+1 , n+1) = 1.0 + T(n+1 , 0:n+1) = 2.0 + + T(1:n,1)=(T(0:n-1,1)+T(1:n,1+1)+1d0) + + if (any (T(1:n,1) .ne. 1d0 )) STOP 1 +end program laplsolv diff --git a/Fortran/gfortran/regression/dependency_22.f90 b/Fortran/gfortran/regression/dependency_22.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_22.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! +! Test the fix for PR37723 in which the array element reference masked the dependency +! by inhibiting the test. +! +! Contributed by Dick Hendrickson +! + program try_cg0071 + type seq + integer ia(10) + end type + TYPE(SEQ) UDA1R + type(seq) uda(1) + + do j1 = 1,10 + uda1r%ia(j1) = j1 + enddo + + uda = uda1r + UDA(1)%IA(1:9) = UDA(1)%IA(9:1:-1)+1 + + DO J1 = 1,9 + if (UDA1R%IA(10-J1)+1 /= Uda(1)%IA(J1)) STOP 1 + ENDDO + + end + + diff --git a/Fortran/gfortran/regression/dependency_23.f90 b/Fortran/gfortran/regression/dependency_23.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_23.f90 @@ -0,0 +1,54 @@ +! { dg-do run } +! Test the fix for PR38863, in which an unnecessary temporary +! generated results that are not consistent with other compilers. +! +! Contributed by Dick Hendrickson +! +module rg0045_stuff + type unseq + integer :: i + logical :: l + end type unseq + interface assignment(=) + module procedure l_to_t, i_to_t + end interface +contains + elemental subroutine l_to_t (arg1, arg2) + type(unseq), intent(inout) :: arg1 + logical, intent(in) :: arg2 + arg1%l = arg2 + end subroutine l_to_t + elemental subroutine i_to_t (arg1, arg2) + type(unseq), intent(inout) :: arg1 + integer, intent(in) :: arg2 + arg1%i = arg2 + end subroutine i_to_t + subroutine rg0045(nf1, nf2, nf3) + type(unseq) :: tla2l(nf3, nf2) + type(unseq) :: tda2l(3,2) + logical :: lda(nf3,nf2) + tda2l%l = reshape ([.true.,.false.,.true.,.false.,.true.,.false.],[3,2]) + tda2l%i = reshape ([1, -1, 3, -1, 5, -1],[3,2]) + lda = tda2l%l + tla2l%l = lda + tla2l%i = reshape ([1, 2, 3, 4, 5, 6], [3,2]) +! +! The problem occurred here: gfortran was producing a temporary for these +! assignments because the dependency checking was too restrictive. Since +! a temporary was used, the integer component was reset in the first assignment +! rather than being carried over. +! + where(lda) + tla2l = tla2l(1:3, 1:2)%l + tla2l = tla2l(1:3, 1:2)%i + elsewhere + tla2l = -1 + endwhere + if (any (tla2l%i .ne. tda2l%i)) STOP 1 + if (any (tla2l%l .neqv. tda2l%l)) STOP 2 + end subroutine +end module rg0045_stuff + + use rg0045_stuff + call rg0045(1, 2, 3) +end diff --git a/Fortran/gfortran/regression/dependency_24.f90 b/Fortran/gfortran/regression/dependency_24.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_24.f90 @@ -0,0 +1,80 @@ +! { dg-do run } +! Check the fix for PR38863 comment #1, where defined assignment +! to derived types was not treating components correctly that were +! not set explicitly. +! +! Contributed by Mikael Morin +! +module m + type t + integer :: i,j + end type t + type ti + integer :: i,j = 99 + end type ti + interface assignment (=) + module procedure i_to_t, i_to_ti + end interface +contains + elemental subroutine i_to_ti (p, q) + type(ti), intent(out) :: p + integer, intent(in) :: q + p%i = q + end subroutine + elemental subroutine i_to_t (p, q) + type(t), intent(out) :: p + integer, intent(in) :: q + p%i = q + end subroutine +end module + + use m + call test_t ! Check original problem + call test_ti ! Default initializers were treated wrongly +contains + subroutine test_t + type(t), target :: a(3) + type(t), target :: b(3) + type(t), dimension(:), pointer :: p + logical :: l(3) + + a%i = 1 + a%j = [101, 102, 103] + b%i = 3 + b%j = 4 + + p => b + l = .true. + + where (l) + a = p%i ! Comment #1 of PR38863 concerned WHERE assignment + end where + if (any (a%j .ne. [101, 102, 103])) STOP 1 + + a = p%i ! Ordinary assignment was wrong too. + if (any (a%j .ne. [101, 102, 103])) STOP 2 + end subroutine + + subroutine test_ti + type(ti), target :: a(3) + type(ti), target :: b(3) + type(ti), dimension(:), pointer :: p + logical :: l(3) + + a%i = 1 + a%j = [101, 102, 103] + b%i = 3 + b%j = 4 + + p => b + l = .true. + + where (l) + a = p%i + end where + if (any (a%j .ne. 99)) STOP 3 + + a = p%i + if (any (a%j .ne. 99)) STOP 4 + end subroutine +end diff --git a/Fortran/gfortran/regression/dependency_25.f90 b/Fortran/gfortran/regression/dependency_25.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_25.f90 @@ -0,0 +1,93 @@ +! { dg-do run } +! Test the fix for PR42736, in which an excessively rigorous dependency +! checking for the assignment generated an unnecessary temporary, whose +! rank was wrong. When accessed by the scalarizer, a segfault ensued. +! +! Contributed by Tobias Burnus +! Reported by Armelius Cameron +! +module UnitValue_Module + + implicit none + private + + public :: & + operator(*), & + assignment(=) + + type, public :: UnitValue + real :: & + Value = 1.0 + character(31) :: & + Label + end type UnitValue + + interface operator(*) + module procedure ProductReal_LV + end interface operator(*) + + interface assignment(=) + module procedure Assign_LV_Real + end interface assignment(=) + +contains + + elemental function ProductReal_LV(Multiplier, Multiplicand) result(P_R_LV) + + real, intent(in) :: & + Multiplier + type(UnitValue), intent(in) :: & + Multiplicand + type(UnitValue) :: & + P_R_LV + + P_R_LV%Value = Multiplier * Multiplicand%Value + P_R_LV%Label = Multiplicand%Label + + end function ProductReal_LV + + + elemental subroutine Assign_LV_Real(LeftHandSide, RightHandSide) + + real, intent(inout) :: & + LeftHandSide + type(UnitValue), intent(in) :: & + RightHandSide + + LeftHandSide = RightHandSide%Value + + end subroutine Assign_LV_Real + +end module UnitValue_Module + +program TestProgram + + use UnitValue_Module + + implicit none + + type :: TableForm + real, dimension(:,:), allocatable :: & + RealData + end type TableForm + + type(UnitValue) :: & + CENTIMETER + + type(TableForm), pointer :: & + Table + + allocate(Table) + allocate(Table%RealData(10,5)) + + CENTIMETER%value = 42 + Table%RealData = 1 + Table%RealData(:,1) = Table%RealData(:,1) * CENTIMETER + Table%RealData(:,2) = Table%RealData(:,2) * CENTIMETER + Table%RealData(:,3) = Table%RealData(:,3) * CENTIMETER + Table%RealData(:,5) = Table%RealData(:,5) * CENTIMETER + +! print *, Table%RealData + if (any (abs(Table%RealData(:,4) - 1) > epsilon(1.0))) STOP 1 + if (any (abs(Table%RealData(:,[1,2,3,5]) - 42) > epsilon(1.0))) STOP 2 +end program TestProgram diff --git a/Fortran/gfortran/regression/dependency_26.f90 b/Fortran/gfortran/regression/dependency_26.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_26.f90 @@ -0,0 +1,51 @@ +! { dg-do compile } +! { dg-options "-finline-matmul-limit=0 -fdump-tree-original" } +! +! Test the fix for PR36932 and PR36933, in which unnecessary +! temporaries were being generated. The module m2 tests the +! additional testcase in comment #3 of PR36932. +! +! Contributed by Joost VandeVondele +! +MODULE M2 + IMPLICIT NONE + TYPE particle + REAL :: r(3) + END TYPE +CONTAINS + SUBROUTINE S1(p) + TYPE(particle), POINTER, DIMENSION(:) :: p + REAL :: b(3) + INTEGER :: i + b=pbc(p(i)%r) + END SUBROUTINE S1 + FUNCTION pbc(b) + REAL :: b(3) + REAL :: pbc(3) + pbc=b + END FUNCTION +END MODULE M2 + +MODULE M1 + IMPLICIT NONE + TYPE cell_type + REAL :: h(3,3) + END TYPE +CONTAINS + SUBROUTINE S1(cell) + TYPE(cell_type), POINTER :: cell + REAL :: a(3) + REAL :: b(3) = [1, 2, 3] + a=MATMUL(cell%h,b) + if (ANY (INT (a) .ne. [30, 36, 42])) STOP 1 + END SUBROUTINE S1 +END MODULE M1 + + use M1 + TYPE(cell_type), POINTER :: cell + allocate (cell) + cell%h = reshape ([(real(i), i = 1, 9)], [3, 3]) + call s1 (cell) +end +! { dg-final { scan-tree-dump-times "&a" 1 "original" } } +! { dg-final { scan-tree-dump-times "pack" 0 "original" } } diff --git a/Fortran/gfortran/regression/dependency_27.f90 b/Fortran/gfortran/regression/dependency_27.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_27.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-Warray-temporaries" } +! PR 36928 - optimize array interleaving array temporaries +program main + real, dimension(20) :: a + read (10) a + a(2:10:2) = a (1:9:2) + write (11) a + read (10) a + a(2:10:4) = a(1:5:2) + write (11) a + read (10) a + a(2:10:4) = a(5:1:-2) + write (11) a +end program main diff --git a/Fortran/gfortran/regression/dependency_28.f90 b/Fortran/gfortran/regression/dependency_28.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_28.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-Warray-temporaries" } +module foobar + type baz + integer :: i + integer :: j + integer :: k + integer :: m + end type baz +contains + subroutine foo(a,b,c,i) + real, dimension(10) :: a,b + type(baz) :: c + integer, dimension(10) :: i + a(i(1):i(2)) = a(i(1):i(2)) + b(i(1):i(2)) + a(i(1):i(2)) = a(i(3):i(5)) ! { dg-warning "Creating array temporary" } + a(c%i:c%j) = a(c%i:c%j) + b(c%k:c%m) + a(c%k:c%m) = a(c%i:c%j) + b(c%k:c%m) ! { dg-warning "Creating array temporary" } + end subroutine foo +end module foobar diff --git a/Fortran/gfortran/regression/dependency_29.f90 b/Fortran/gfortran/regression/dependency_29.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_29.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-Warray-temporaries" } + +subroutine t1(n1,n2, gfft, ufft) + implicit none + integer :: n1, n2, i + real :: gfft(n1,n2), ufft(n2) + DO i=1, n1 + gfft(i,:)=gfft(i,:)*ufft(i) + END DO +end subroutine t1 diff --git a/Fortran/gfortran/regression/dependency_3.f90 b/Fortran/gfortran/regression/dependency_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_3.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! Tests the fix for PR24519, in which assignments with the same +! range of an assumed shape array, on the lhs and rhs, would be +! treated as causing a dependency. +! +! Contributed by Paul.Thomas +! + integer, parameter :: n = 100 + real :: x(n, n), v + x = 1 + v = 0.1 + call foo (x, v) + if (abs(sum (x) - 91.10847) > 1e-3) print *, sum (x) +contains + subroutine foo (b, d) + real :: b(:, :) + real :: temp(n), c, d + integer :: j, k + do k = 1, n + temp = b(:,k) + do j = 1, n + c = b(k,j)*d + b(:,j) = b(:,j)-temp*c ! This was the offending assignment. + b(k,j) = c + end do + end do + end subroutine foo +end diff --git a/Fortran/gfortran/regression/dependency_30.f90 b/Fortran/gfortran/regression/dependency_30.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_30.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-Warray-temporaries" } +! PR 45159 - make sure no temporary is created for this. +subroutine foo(a,b,i,j,k,n) + implicit none + integer, intent(in) :: i, j, k, n + real, dimension(n) :: a,b + a(k:i-1) = a(i:j) +end subroutine foo diff --git a/Fortran/gfortran/regression/dependency_31.f90 b/Fortran/gfortran/regression/dependency_31.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_31.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-Warray-temporaries" } +! PR 45159 - make sure no temporary is created for this. +subroutine foo(a,n,i,j) + implicit none + integer, intent(in) :: i,j,n + real, dimension(20) :: a + a(1:10) = a(i:j) + a(20:n:-3) = a(n:i:-3) +end subroutine foo diff --git a/Fortran/gfortran/regression/dependency_32.f90 b/Fortran/gfortran/regression/dependency_32.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_32.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-Warray-temporaries" } +! PR 44235 +! No temporary should be created for this, as the upper bounds +! are effectively identical. +program main + real a(10) + a = 0. + a(1:10:4) = a(1:9:4) +end program main diff --git a/Fortran/gfortran/regression/dependency_33.f90 b/Fortran/gfortran/regression/dependency_33.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_33.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-Warray-temporaries" } +! No temporary should be created for this, as a missing stride and +! a stride equal to one should be equal. +program main + integer a(100) + a(10:16) = a(11:17) + a(10:16) = a(11:17:1) + a(10:16:1) = a(11:17) + a(10:16:1) = a(11:17:1) +end program main diff --git a/Fortran/gfortran/regression/dependency_34.f90 b/Fortran/gfortran/regression/dependency_34.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_34.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-Warray-temporaries" } +module foo + implicit none +contains + integer pure function bar(i,j) + integer, intent(in) :: i,j + bar = 3 - i + 1 * abs(i) + j + end function bar +end module foo + +program main + use foo + implicit none + real a(10) + integer :: i + read (*,*) a, i + a(i:abs(i)) = a(i:abs(i)) + a(bar(i,i+2):2) = a(bar(i,i+2):2) + a(int(i,kind=2):5) = a(int(i,kind=2)+1:6) +end program main diff --git a/Fortran/gfortran/regression/dependency_35.f90 b/Fortran/gfortran/regression/dependency_35.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_35.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-Warray-temporaries -O" } +module foo + implicit none +contains + pure function bar(i,j) + integer, intent(in) :: i,j + integer, dimension(2,2) :: bar + bar = 33 + end function bar +end module foo + +program main + use foo + implicit none + integer a(2,2), b(2,2),c(2,2), d(2,2), e(2) + + read (*,*) b, c, d + a = matmul(b,c) + d + a = b + bar(3,4) + a = bar(3,4)*5 + b + e = sum(b,1) + 3 +end program main diff --git a/Fortran/gfortran/regression/dependency_36.f90 b/Fortran/gfortran/regression/dependency_36.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_36.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-options "-O -Warray-temporaries" } +! PR 45744 - this used to ICE because of type mismatch +! in the generated temporary. +MODULE m +CONTAINS + FUNCTION rnd(n) + INTEGER, INTENT(in) :: n + REAL(8), DIMENSION(n) :: rnd + CALL RANDOM_NUMBER(rnd) + END FUNCTION rnd + + SUBROUTINE GeneticOptimize(n) + INTEGER :: n + LOGICAL :: mask(n) + REAL(8) :: popcross=0 + REAL(4) :: foo(n) + real(4) :: a(n,n), b(n,n) + real(8) :: c(n,n) + integer(4) :: x(n,n) + integer(8) :: bar(n) + mask = (rnd(n) < popcross) ! { dg-warning "Creating array temporary" } + foo = rnd(n) ! { dg-warning "Creating array temporary" } + bar = rnd(n) ! { dg-warning "Creating array temporary" } + c = matmul(a,b) ! { dg-warning "Creating array temporary" } + x = matmul(a,b) ! { dg-warning "Creating array temporary" } + END SUBROUTINE GeneticOptimize +END MODULE m diff --git a/Fortran/gfortran/regression/dependency_37.f90 b/Fortran/gfortran/regression/dependency_37.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_37.f90 @@ -0,0 +1,48 @@ +! { dg-do compile } +! { dg-options "-Warray-temporaries" } +! PR 48231 - this used to create an unnecessary temporary. +module UnitValue_Module + type :: UnitValue + real :: Value = 1.0 + end type + + interface operator(*) + module procedure ProductReal_LV + end interface operator(*) + + interface assignment(=) + module procedure Assign_LV_Real + end interface assignment(=) +contains + + elemental function ProductReal_LV(Multiplier, Multiplicand) result(P_R_LV) + real, intent(in) :: Multiplier + type(UnitValue), intent(in) :: Multiplicand + type(UnitValue) :: P_R_LV + P_R_LV%Value = Multiplier * Multiplicand%Value + end function ProductReal_LV + + elemental subroutine Assign_LV_Real(LeftHandSide, RightHandSide) + real, intent(inout) :: LeftHandSide + type(UnitValue), intent(in) :: RightHandSide + LeftHandSide = RightHandSide%Value + end subroutine Assign_LV_Real +end module UnitValue_Module + +program TestProgram + use UnitValue_Module + + type :: TableForm + real, dimension(:,:), allocatable :: RealData + end type TableForm + + REAL :: CENTIMETER + type(TableForm), pointer :: Table + + allocate(Table) + allocate(Table%RealData(10,5)) + + CENTIMETER = 42 + Table%RealData = 1 + Table%RealData(:,1) = Table%RealData(:,1) * CENTIMETER +end program TestProgram diff --git a/Fortran/gfortran/regression/dependency_38.f90 b/Fortran/gfortran/regression/dependency_38.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_38.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-Warray-temporaries" } +! PR 45159 - No temporary should be created for this. +program main + integer a(100) + a(10:16:2) = a(10:16:2) + a(10:16:2) = a(10:19:3) + a(10:18:2) = a(12:20:2) + a(1:10) = a(2:20:2) + a(16:10:-2) = a(16:10:-2) + a(19:10:-1) = a(19:1:-2) + a(19:10:-1) = a(18:9:-1) + a(19:11:-1) = a(18:2:-2) +end program main diff --git a/Fortran/gfortran/regression/dependency_39.f90 b/Fortran/gfortran/regression/dependency_39.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_39.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! PR 45777 - component ref aliases when both are pointers +module m1 + type t1 + integer, dimension(:), allocatable :: data + end type t1 +contains + subroutine s1(t,d) + integer, dimension(:), pointer :: d + type(t1), pointer :: t + d(1:5)=t%data(3:7) + end subroutine s1 + subroutine s2(d,t) + integer, dimension(:), pointer :: d + type(t1), pointer :: t + t%data(3:7) = d(1:5) + end subroutine s2 +end module m1 + +program main + use m1 + type(t1), pointer :: t + integer, dimension(:), pointer :: d + allocate(t) + allocate(t%data(10)) + t%data=(/(i,i=1,10)/) + d=>t%data(5:9) + call s1(t,d) + if (any(d.ne.(/3,4,5,6,7/))) STOP 1 + t%data=(/(i,i=1,10)/) + d=>t%data(1:5) + call s2(d,t) + if (any(t%data.ne.(/1,2,1,2,3,4,5,8,9,10/))) STOP 1 + deallocate(t%data) + deallocate(t) +end program main diff --git a/Fortran/gfortran/regression/dependency_4.f90 b/Fortran/gfortran/regression/dependency_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_4.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } +subroutine foo(a) + integer, dimension (4) :: a + + where (a .ne. 0) + a = 1 + endwhere +end subroutine +! { dg-final { scan-tree-dump-times "malloc" 0 "original" } } diff --git a/Fortran/gfortran/regression/dependency_40.f90 b/Fortran/gfortran/regression/dependency_40.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_40.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! PR 48955 - missing array temporary when there was both a forward +! and a backward dependency. +! Test case slightly modified from the original one by Kacper Kowalik. +program ala + implicit none + + integer, parameter :: n = 6 + real, dimension(n), parameter :: result = [1.,10.,30.,90.,270., 243.]; + real, dimension(n) :: v0, v1 + character(len=80) :: line1, line2 + + v0 = [1.0, 3.0, 9.0, 27.0, 81.0, 243.0] + v1 = v0 + + v1(2:n-1) = v1(1:n-2) + v1(3:n) + if (any(v1 /= result)) STOP 1 + v1 = v0 + v1(2:n-1) = v0(1:n-2) + v0(3:n) + if (any(v1 /= result)) STOP 2 + + v1 = v0 + v1(2:n-1) = v1(3:n) + v1(1:n-2) + if (any(v1 /= result)) STOP 3 + v1 = v0 + v1(2:n-1) = v0(3:n) + v0(1:n-2) + if (any(v1 /= result)) STOP 4 + +end program ala diff --git a/Fortran/gfortran/regression/dependency_41.f90 b/Fortran/gfortran/regression/dependency_41.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_41.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-options "-Warray-temporaries" } +! No temporary should be generated in this case. +program main + implicit none + integer :: i,n + integer :: a(10) + integer :: b(10) + do i=1,10 + a(i) = i + b(i) = i + end do + n = 1 + ! Same result when assigning to a or b + b(n+1:10:4) = a(n+2:8:2) + a(n+1:10:4) = a(n+2:8:2) + if (any (a/=b)) STOP 1 +end program main + diff --git a/Fortran/gfortran/regression/dependency_42.f90 b/Fortran/gfortran/regression/dependency_42.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_42.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-Warray-temporaries" } +! PR fortran/56937 - unnecessary temporaries with vector indices +program main + real :: q(4), r(4), p(3) + integer :: idx(3) + p = [0.5, 1.0, 2.0] + idx = [4,3,1] + r = 1.0 + r(idx) = r(idx) + p + q = 1.0 + q(4) = q(4) + p(1) + q(3) = q(3) + p(2) + q(1) = q(1) + p(3) + if (any (q - r /= 0)) STOP 1 +end diff --git a/Fortran/gfortran/regression/dependency_43.f90 b/Fortran/gfortran/regression/dependency_43.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_43.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! { dg-options "-Warray-temporaries" } +! PR fortran/56937 - unnecessary temporaries with vector indices +program main + integer, dimension(3) :: i1, i2 + real :: a(3,2) + + data a / 1.0, 2.0, 3.0, 4.0, 5.0, 6.0 / + i1 = [ 1, 2, 3 ] + i2 = [ 3, 2, 1 ] + a (i1,1) = a (i2,2) + if (a(1,1) /= 6.0 .or. a(2,1) /= 5.0 .or. a(3,1) /= 4.0) STOP 1 + if (a(1,2) /= 4.0 .or. a(2,2) /= 5.0 .or. a(3,2) /= 6.0) STOP 2 +end program main diff --git a/Fortran/gfortran/regression/dependency_44.f90 b/Fortran/gfortran/regression/dependency_44.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_44.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! Tests fix for PR61780 in which the loop reversal mechanism was +! not accounting for the first index being an element so that no +! loop in this dimension is created. +! +! Contributed by Manfred Tietze on clf. +! +program prgm3 + implicit none + integer, parameter :: n = 10, k = 3 + integer :: i, j + integer, dimension(n,n) :: y + integer :: res1(n), res2(n) + +1 format(10i5) + +!initialize + do i=1,n + do j=1,n + y(i,j) = n*i + j + end do + end do + res2 = y(k,:) + +!shift right + y(k,4:n) = y(k,3:n-1) + y(k,3) = 0 + res1 = y(k,:) + y(k,:) = res2 + y(k,n:4:-1) = y(k,n-1:3:-1) + y(k,3) = 0 + res2 = y(k,:) +! print *, res1 +! print *, res2 + if (any(res1 /= res2)) STOP 1 +end program prgm3 diff --git a/Fortran/gfortran/regression/dependency_45.f90 b/Fortran/gfortran/regression/dependency_45.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_45.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! { dg-options "-Warray-temporaries" } +! PR 56867 - substrings were not checked for dependency. +program main + character(len=4) :: a + character(len=4) :: c(3) + c(1) = 'abcd' + c(2) = '1234' + c(3) = 'wxyz' + c(:)(1:2) = c(2)(2:3) ! { dg-warning "array temporary" } + if (c(3) .ne. '23yz') STOP 1 +end program main diff --git a/Fortran/gfortran/regression/dependency_46.f90 b/Fortran/gfortran/regression/dependency_46.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_46.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR 71783 - this used to ICE due to a missing charlen for the temporary. +! Test case by Toon Moene. + +SUBROUTINE prtdata(ilen) + INTEGER :: ilen + character(len=ilen), allocatable :: cline(:) + allocate(cline(2)) + cline(1) = 'a' + cline(2) = cline(1) +END SUBROUTINE prtdata diff --git a/Fortran/gfortran/regression/dependency_47.f90 b/Fortran/gfortran/regression/dependency_47.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_47.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! Make sure there is only one instance of a temporary variable here. +! { dg-options "-fdump-tree-original" } + +SUBROUTINE prtdata(ilen) + INTEGER :: ilen + character(len=ilen), allocatable :: cline(:) + allocate(cline(2)) + cline(1) = 'a' + cline(1)(2:3) = cline(1)(1:2) + cline(2) = cline(1) + print *,c +END SUBROUTINE prtdata +! { dg-final { scan-tree-dump-not "__var_" "original" } } diff --git a/Fortran/gfortran/regression/dependency_48.f90 b/Fortran/gfortran/regression/dependency_48.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_48.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-options "-frepack-arrays -Warray-temporaries -O" } + +! Same as dependency_35 but with repack-arrays + +module foo + implicit none +contains + pure function bar(i,j) ! { dg-warning "Creating array temporary at \\(1\\)" } + integer, intent(in) :: i,j + integer, dimension(2,2) :: bar + bar = 33 + end function bar +end module foo + +program main + use foo + implicit none + integer a(2,2), b(2,2),c(2,2), d(2,2), e(2) + + read (*,*) b, c, d + a = matmul(b,c) + d + a = b + bar(3,4) + a = bar(3,4)*5 + b + e = sum(b,1) + 3 +end program main diff --git a/Fortran/gfortran/regression/dependency_49.f90 b/Fortran/gfortran/regression/dependency_49.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_49.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! PR fortran/71902 - make sure that component references are followed +! for dependency analysis. +program main + type foo + character(len=:), allocatable :: x + end type foo + type(foo) :: a + a%x = 'asdf' + a%x = a%x(2:3) + print *,a%x +end program main +! The temporary var appears three times: declaration, copy-in and copy-out +! { dg-final { scan-tree-dump-times "__var_1" 3 "original" } } diff --git a/Fortran/gfortran/regression/dependency_5.f90 b/Fortran/gfortran/regression/dependency_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_5.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } +subroutine foo(a) + integer, dimension (4) :: a + + where (a(:) .ne. 0) + a(:) = 1 + endwhere +end subroutine +! { dg-final { scan-tree-dump-times "malloc" 0 "original" } } diff --git a/Fortran/gfortran/regression/dependency_50.f90 b/Fortran/gfortran/regression/dependency_50.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_50.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! PR 83224 - dependency mishandling with an array constructor +! Original test case by Urban Jost +program dusty_corner + implicit none + character(len=:),allocatable :: words(:) + + words=[character(len=3) :: 'one', 'two'] + words=[character(len=5) :: words, 'three'] + if (any(words /= [ "one ", "two ", "three"])) STOP 1 + +end program dusty_corner diff --git a/Fortran/gfortran/regression/dependency_51.f90 b/Fortran/gfortran/regression/dependency_51.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_51.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! PR 83224 - dependency mishandling with an array constructor +! Original test case by Urban Jost +program dusty_corner + implicit none + character(len=:),allocatable :: words(:) + integer :: n + + words=[character(len=3) :: 'one', 'two'] + n = 5 + words=[character(len=n) :: words, 'three'] + if (any(words /= [ "one ", "two ", "three"])) STOP 1 + +end program dusty_corner diff --git a/Fortran/gfortran/regression/dependency_52.f90 b/Fortran/gfortran/regression/dependency_52.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_52.f90 @@ -0,0 +1,59 @@ +! { dg-do run } +! +! Test the fix for PR65677, in which the dependency was missed and +! the string length of 'text' was decremented twice. The rhs string +! length is now fixed after the function call so that the dependency +! on the length of 'text' is removed for later evaluations. +! +!Contributed by John +! +module mod1 + implicit none +contains + subroutine getKeyword(string, keyword, rest, use_adjustl) + character(:), allocatable, intent(IN) :: string + character(:), allocatable, intent(OUT) :: keyword, rest + integer :: idx + character(:), allocatable :: text + logical :: use_adjustl + + keyword = '' + rest = '' + text = string + if (use_adjustl) then + text = ADJUSTL(text(2:)) ! Note dependency. + else + text = text(2:) ! Check the old workaround. + endif + idx = INDEX(text, ' ') + + if (idx == 0) then + keyword = TRIM(text) + else + keyword = text(:idx-1) + rest = TRIM(ADJUSTL(text(idx+1:))) + endif + end subroutine +end module mod1 + + use mod1 + implicit none + + character(:), allocatable :: line, keyword, rest + + line = '@HERE IT IS' + + call getKeyword(line, keyword, rest, use_adjustl = .true.) + + if (keyword .ne. 'HERE') stop 1 + if (rest .ne. 'IT IS') stop 2 + deallocate (line, keyword, rest) + + line = '@HERE IT IS' + + call getKeyword(line, keyword, rest, use_adjustl = .false.) + + if (keyword .ne. 'HERE') stop 3 + if (rest .ne. 'IT IS') stop 4 + deallocate (line, keyword, rest) +end diff --git a/Fortran/gfortran/regression/dependency_53.f90 b/Fortran/gfortran/regression/dependency_53.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_53.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! PR fortran/66089 - used to ICE and, after that ICE was fixed, +! gave wrong results. + type :: t + integer :: c + end type t + + class(t), dimension(:), allocatable :: b,c + + allocate (b(5), source=t(7)) + allocate(c(5), source=t(13)) + c = plus(c(1), b) + if (any(c%c /= 20)) stop 1 + c = t(13) + c = plus(b, c(1)) + if (any(c%c /= 20)) stop 2 +contains + + elemental function plus(lhs, rhs) + class(t), intent(in) :: lhs, rhs + type(t) :: plus + plus%c = lhs%c + rhs%c + end function plus + +end diff --git a/Fortran/gfortran/regression/dependency_54.f90 b/Fortran/gfortran/regression/dependency_54.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_54.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original -ffrontend-optimize" } +! PR 65819 - this used to cause a temporary in matmul inlining. +! Check that these are absent by looking for the names of the +! temporary variables. +program main + implicit none + real, dimension(3,3,3) :: f + real, dimension(3,3) :: res + real, dimension(2,3,3) :: backup + integer :: three + integer :: i + + data f(1,:,:) /9*-42./ + data f(2:3,:,:) /2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 53, 59, 61/ + data res /652, 772, 984, 2010, 2406, 3082, 3402, 4086, 5242/ + three = 3 + backup = f(2:3,:,:) + f(1, 1:three, :) = matmul(f(2,1:3,2:3), f(3,2:3,:)) + if (any (res /= f(1,:,:))) stop 1 + if (any (f(2:3,:,:) /= backup)) stop 2 +end program main +! { dg-final { scan-tree-dump-not "mma" "original" } } +! { dg-final { scan-tree-dump-not "mmb" "original" } } diff --git a/Fortran/gfortran/regression/dependency_55.f90 b/Fortran/gfortran/regression/dependency_55.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_55.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! +! Test the fix for PR91717 in which the concatenation operation ICEd. +! +! Contributed by Damian Rouson +! + type core + character (len=:), allocatable :: msg + end type + + type(core) :: my_core + + my_core%msg = "" + my_core%msg = my_core%msg//"my message is: " + my_core%msg = my_core%msg//"Hello!" + + if (my_core%msg .ne. "my message is: Hello!") stop 1 +end diff --git a/Fortran/gfortran/regression/dependency_56.f90 b/Fortran/gfortran/regression/dependency_56.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_56.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! PR 91783 - used to cause an ICE in dependency checking. +! Test case by Gerhard Steinmetz. +program p + class(*), allocatable :: a(:) + a = [1, 2, 3] + a = f(a) +contains + function f(x) result(y) + class(*), allocatable, intent(in) :: x(:) + class(*), allocatable :: y(:) + y = x + end +end diff --git a/Fortran/gfortran/regression/dependency_57.f90 b/Fortran/gfortran/regression/dependency_57.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_57.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! PR 92755 - this used to cause an ICE. +! Original test case by Gerhard Steinmetz +program p + type t + end type + type t2 + class(t), allocatable :: a(:) + end type + type(t2) :: z + z%a = [z%a] +end diff --git a/Fortran/gfortran/regression/dependency_58.f90 b/Fortran/gfortran/regression/dependency_58.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_58.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! { dg-additional-options "-ffrontend-optimize -Warray-temporaries" } +! PR 93113 - this used to ICE, and should not generate a temporary. +program main + integer, parameter :: n = 10 + complex, dimension(n,n) :: a, b, c + real, dimension(n,n) :: r + call random_number (r) + c%re = r + call random_number (r) + c%im = r + + a = c + b = c + b%re = a%re - 0.5 + b%im = a%im - 0.5 + a%re = a%re - 0.5 + a%im = a%im - 0.5 + if (any (a /= b)) stop 1 + b%im = a%re + a%im = a%re + if (any (a /= b)) stop 2 + a = c + b = c + b(2:n,:)%re = a(1:n-1,:)%re + a(2:n,:)%re = a(1:n-1,:)%re + if (any (a /= b)) stop 3 + a = c + b = c + b(1:n-1,:)%im = a(2:,:)%im + a(1:n-1,:)%im = a(2:,:)%im + if (any (a /= b)) stop 3 +end program main diff --git a/Fortran/gfortran/regression/dependency_59.f90 b/Fortran/gfortran/regression/dependency_59.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_59.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! PR 95812 - this caused an ICE. +! Test case by Jakub Jelinek. + +module test +contains + subroutine foo() + integer :: a(3) + a = 1 + print *, matmul(1*reshape(a,(/3,1/)), reshape((/1,1,1/),(/1,3/))) + end subroutine foo + subroutine bar() + call foo() + end subroutine bar +end module test diff --git a/Fortran/gfortran/regression/dependency_6.f90 b/Fortran/gfortran/regression/dependency_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_6.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } +subroutine foo(a) + integer, dimension (4) :: a + + where (a(:4) .ne. 0) + a(:4) = 1 + endwhere +end subroutine +! { dg-final { scan-tree-dump-times "malloc" 0 "original" } } diff --git a/Fortran/gfortran/regression/dependency_60.f90 b/Fortran/gfortran/regression/dependency_60.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_60.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! PR 92755 - this used to cause an ICE (see dependency_57.f90) +! PR83118 - fixed so that it would run :-) +! Original test case by Gerhard Steinmetz +program p + type t + integer :: i + end type + type t2 + class(t), allocatable :: a(:) + end type + type(t2) :: z + z%a = [t(1),t(2),t(3)] + z%a = [z%a] + select type (y => z%a) + type is (t) + if (any (y%i .ne. [1, 2, 3])) stop 1 + end select +end diff --git a/Fortran/gfortran/regression/dependency_7.f90 b/Fortran/gfortran/regression/dependency_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_7.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } +subroutine foo(a) + integer, dimension (4) :: a + + where (a(1:4) .ne. 0) + a(1:4) = 1 + endwhere +end subroutine +! { dg-final { scan-tree-dump-times "malloc" 0 "original" } } diff --git a/Fortran/gfortran/regression/dependency_8.f90 b/Fortran/gfortran/regression/dependency_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_8.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } +subroutine foo(a,i,j) + integer, dimension (4,4) :: a + integer :: i + integer :: j + + where (a(i,1:3) .ne. 0) + a(j,2:4) = 1 + endwhere +end subroutine +! { dg-final { scan-tree-dump-times "temp" 3 "original" } } diff --git a/Fortran/gfortran/regression/dependency_9.f90 b/Fortran/gfortran/regression/dependency_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependency_9.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } +subroutine foo(a,i,j) + integer, dimension (4,4) :: a + integer :: i + integer :: j + + where (a(i,:) .ne. 0) + a(j,:) = 1 + endwhere +end subroutine +! { dg-final { scan-tree-dump-times "malloc" 0 "original" } } diff --git a/Fortran/gfortran/regression/dependent_decls_1.f90 b/Fortran/gfortran/regression/dependent_decls_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dependent_decls_1.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! Tests the fix for pr28660 in which the order of dependent declarations +! would get scrambled in the compiled code. +! +! Contributed by Erik Edelmann +! +program bar + implicit none + real :: x(10) + call foo1 (x) + call foo2 (x) + call foo3 (x) +contains + subroutine foo1 (xmin) + real, intent(inout) :: xmin(:) + real :: x(size(xmin)+1) ! The declaration for r would be added + real :: r(size(x)-1) ! to the function before that of x + xmin = r + if (size(r) .ne. 10) STOP 1 + if (size(x) .ne. 11) STOP 2 + end subroutine foo1 + subroutine foo2 (xmin) ! This version was OK because of the + real, intent(inout) :: xmin(:) ! renaming of r which pushed it up + real :: x(size(xmin)+3) ! the symtree. + real :: zr(size(x)-3) + xmin = zr + if (size(zr) .ne. 10) STOP 3 + if (size(x) .ne. 13) STOP 4 + end subroutine foo2 + subroutine foo3 (xmin) + real, intent(inout) :: xmin(:) + character(size(x)+2) :: y ! host associated x + character(len(y)+3) :: z ! This did not work for any combination + real :: r(len(z)-5) ! of names. + xmin = r + if (size(r) .ne. 10) STOP 5 + if (len(z) .ne. 15) STOP 6 + end subroutine foo3 +end program bar diff --git a/Fortran/gfortran/regression/der_array_1.f90 b/Fortran/gfortran/regression/der_array_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/der_array_1.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! Test derived type constructors for derived types containing arrays. +! PR16919 +program der_array_1 + implicit none + integer n + integer m + ! The 4 components here test known shape array, unknown shape array, + ! multi-dimensional arrays and array pointers + type t + integer :: a(2) + integer :: b(2) + integer, dimension(2, 3) :: c + integer, pointer, dimension(:) :: p + end type + type(t) :: v + integer, dimension(2, 3) :: d + integer, dimension(:), pointer :: e + integer, dimension(2) :: f + + m = 2 + f = (/3, 4/) + d = reshape ((/5, 6, 7, 8, 9, 10/), (/2, 3/)); + allocate (e(2)) + + v = t((/1, 2/), reshape (f, (/m/)), d, e); + if (any (v%a .ne. (/1, 2/)) .or. any (v%b .ne. (/3, 4/)) & + .or. any (v%c .ne. d) .or. .not. associated (v%p, e)) & + STOP 1 + + deallocate(e) +end program + diff --git a/Fortran/gfortran/regression/der_array_io_1.f90 b/Fortran/gfortran/regression/der_array_io_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/der_array_io_1.f90 @@ -0,0 +1,26 @@ +! Test IO of arrays of integers in derived types +! { dg-do run } +! { dg-options "-std=legacy" } +! +program main + + character* 10000 :: buf1, buf2 + type xyz + integer :: x, y(3), z + end type xyz + + type (xyz) :: foo(4) + + do i=1,ubound(foo,1) + foo(i)%x = 100*i + do j=1,3 + foo(i)%y(j) = 100*i + 10*j + enddo + foo(i)%z = 100*i+40 + enddo + + write (buf1, '(20i4)') foo + write (buf2, '(20i4)') (foo(i)%x, (foo(i)%y(j), j=1,3), foo(i)%z, i=1,4) + + if (buf1.ne.buf2) STOP 1 +end program main diff --git a/Fortran/gfortran/regression/der_array_io_2.f90 b/Fortran/gfortran/regression/der_array_io_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/der_array_io_2.f90 @@ -0,0 +1,31 @@ +! Test IO of arrays in derived type arrays +! { dg-do run } +! { dg-options "-std=legacy" } +! +program main + + character *1000 buf1, buf2 + + type :: foo_type + integer x(3) + integer y(4) + integer z(5) + character*11 a(3) + end type foo_type + + type (foo_type) :: foo(2) + + foo(1)%x = 3 + foo(1)%y = 4 + foo(1)%z = 5 + foo(1)%a = "hello world" + + foo(2)%x = 30 + foo(2)%y = 40 + foo(2)%z = 50 + foo(2)%a = "HELLO WORLD" + + write (buf1,*) foo + write (buf2,*) ((foo(i)%x(j),j=1,3), (foo(i)%y(j),j=1,4), (foo(i)%z(j),j=1,5), (foo(i)%a(j),j=1,3), i=1,2) + if (buf1.ne.buf2) STOP 1 +end program main diff --git a/Fortran/gfortran/regression/der_array_io_3.f90 b/Fortran/gfortran/regression/der_array_io_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/der_array_io_3.f90 @@ -0,0 +1,15 @@ +! Test IO of character arrays in derived types. +! { dg-do run } +! { dg-options "-std=legacy" } +! +program main + character*1000 buf1, buf2 + type :: foo_type + character(12), dimension(13) :: name = "hello world " + end type foo_type + type (foo_type) :: foo +! foo = foo_type("hello world ") + write (buf1,*) foo + write (buf2,*) (foo%name(i), i=1,13) + if (buf1.ne.buf2) STOP 1 +end program main diff --git a/Fortran/gfortran/regression/der_charlen_1.f90 b/Fortran/gfortran/regression/der_charlen_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/der_charlen_1.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! PR 18990 +! we used to ICE on these examples +module core + type, public :: T + character(len=I) :: str ! { dg-error "needs to be a constant specification expression" } + end type T + private +CONTAINS + subroutine FOO(X) + type(T), intent(in) :: X + end subroutine +end module core + +module another_core + type :: T + character(len=*) :: s ! { dg-error "needs to be a constant specification expr" } + end type T + private +CONTAINS + subroutine FOO(X) + type(T), intent(in) :: X + end subroutine +end module another_core diff --git a/Fortran/gfortran/regression/der_io_1.f90 b/Fortran/gfortran/regression/der_io_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/der_io_1.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! PR 16404 Nr. 8 +! IO of derived types containing pointers is not allowed +program der_io_1 + type t + integer, pointer :: p + end type + integer, target :: i + type (t) v + character(4) :: s + + v%p => i + i = 42 + write (unit=s, fmt='(I2)') v ! { dg-error "POINTER components" } + if (s .ne. '42') STOP 1 +end program + diff --git a/Fortran/gfortran/regression/der_io_2.f90 b/Fortran/gfortran/regression/der_io_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/der_io_2.f90 @@ -0,0 +1,53 @@ +! { dg-do compile } +! PR 23843 +! IO of derived types with private components is allowed in the module itself, +! but not elsewhere +module gfortran2 + type :: tp1 + private + integer :: i + end type tp1 + + type :: tp1b + integer :: i + end type tp1b + + type :: tp2 + real :: a + type(tp1) :: t + end type tp2 + +contains + + subroutine test() + type(tp1) :: x + type(tp2) :: y + + write (*, *) x + write (*, *) y + end subroutine test + +end module gfortran2 + +program prog + + use gfortran2 + + implicit none + type :: tp3 + type(tp2) :: t + end type tp3 + type :: tp3b + type(tp1b) :: t + end type tp3b + + type(tp1) :: x + type(tp2) :: y + type(tp3) :: z + type(tp3b) :: zb + + write (*, *) x ! { dg-error "PRIVATE components" } + write (*, *) y ! { dg-error "PRIVATE components" } + write (*, *) z ! { dg-error "PRIVATE components" } + write (*, *) zb +end program prog diff --git a/Fortran/gfortran/regression/der_io_3.f90 b/Fortran/gfortran/regression/der_io_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/der_io_3.f90 @@ -0,0 +1,43 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +! PR23843 +! Make sure derived type I/O with PRIVATE components works where it's allowed +module m1 + type t1 + integer i + end type t1 +end module m1 + +module m2 + use m1 + + type t2 + private + type (t1) t + end type t2 + + type t3 + private + integer i + end type t3 + +contains + subroutine test + character*20 c + type(t2) :: a + type(t3) :: b + + a % t % i = 31337 + b % i = 255 + + write(c,*) a + if (trim(adjustl(c)) /= "31337") STOP 1 + write(c,*) b + if (trim(adjustl(c)) /= "255") STOP 2 + end subroutine test +end module m2 + +use m2 +call test +end diff --git a/Fortran/gfortran/regression/der_io_4.f90 b/Fortran/gfortran/regression/der_io_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/der_io_4.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR41859 ICE on invalid expression involving DT with pointer components in I/O. +! The parens around p below are significant. + TYPE :: ptype + character, pointer, dimension(:) :: x => null() + END TYPE + TYPE(ptype) :: p + print *, ((((p)))) ! { dg-error "Data transfer element" } +end diff --git a/Fortran/gfortran/regression/der_io_5.f90 b/Fortran/gfortran/regression/der_io_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/der_io_5.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! PR fortran/100971 - ICE: Bad IO basetype (7) +! Contributed by G.Steinmetz + +program p + implicit none + type t + end type + class(t), allocatable :: a, b(:) + type(t) :: x, y(1) + integer :: i + allocate (a,b(1)) + print *, [a] ! { dg-error "Data transfer element at .1. cannot be polymorphic" } + print *, [(b(i),i=1,1)] ! { dg-error "Data transfer element at .1. cannot be polymorphic" } + print *, [x] + print *, [(y(i),i=1,1)] +end diff --git a/Fortran/gfortran/regression/der_pointer_1.f90 b/Fortran/gfortran/regression/der_pointer_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/der_pointer_1.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! PR13010 +! Arrays of self-referential pointers +module test + type list_t + type(list_t), pointer :: next + end type list_t + + type listptr_t + type(list_t), pointer :: this + end type listptr_t + + type x_t + type(listptr_t), pointer :: arr(:) + end type x_t + + type(x_t), pointer :: x +end module test diff --git a/Fortran/gfortran/regression/der_pointer_2.f90 b/Fortran/gfortran/regression/der_pointer_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/der_pointer_2.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! PR 15975, PR 16606 +! Pointers to derived types with initialized components +! +! Contributed by Erik Edelmann +! +SUBROUTINE N + TYPE T + INTEGER :: I = 99 + END TYPE T + TYPE(T), POINTER :: P + TYPE(T), TARGET :: Q + P => Q + if (P%I.ne.99) STOP 1 +END SUBROUTINE N + +program test_pr15975 + call n () +end program test_pr15975 + diff --git a/Fortran/gfortran/regression/der_pointer_3.f90 b/Fortran/gfortran/regression/der_pointer_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/der_pointer_3.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! PR 18568 +! Find pointer-to-array components +module ints + type :: bar + integer, pointer :: th(:) + end type bar +contains + function foo(b) + type(bar), intent(in) :: b + integer :: foo(size(b%th)) + foo = 0 + end function foo +end module ints + +program size_test + use ints +end program size_test diff --git a/Fortran/gfortran/regression/der_pointer_4.f90 b/Fortran/gfortran/regression/der_pointer_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/der_pointer_4.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR 24426 +! Pointer-components of derived type with initialized components +module crash + implicit none + type foo + integer :: i = 0 + type (foo), pointer :: next + end type foo + type (foo), save :: bar +end module crash diff --git a/Fortran/gfortran/regression/der_ptr_component_1.f90 b/Fortran/gfortran/regression/der_ptr_component_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/der_ptr_component_1.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR 19929 +! Deallocation of pointer components of derived type arrays +program der_ptr_component + type :: t + integer, pointer :: p + end type t + type(t) :: a(1) + + allocate(a(1)%p) + deallocate(a(1)%p) + +end program der_ptr_component diff --git a/Fortran/gfortran/regression/der_ptr_component_2.f90 b/Fortran/gfortran/regression/der_ptr_component_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/der_ptr_component_2.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! +! Freeing the width_data lead to double free. This testcase tests that +! pr79230 is fixed now. + +program main_ut + implicit none + + type :: data_t + character, allocatable :: c1 + end type + + type :: t1_t + character, allocatable :: c2 + class(data_t), pointer :: width_data + end type + + call evaluator + +contains + + subroutine evaluator + type(data_t), target :: par_real + type(t1_t) :: field + field%width_data => par_real + end subroutine + +end + + diff --git a/Fortran/gfortran/regression/derived_array_intrinisics_1.f90 b/Fortran/gfortran/regression/derived_array_intrinisics_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_array_intrinisics_1.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! Test the fix for PR45081 in which derived type array valued intrinsics failed +! to simplify, which caused an ICE in trans-array.c +! +! Contributed by Thorsten Ohl +! + module m + implicit none + integer :: i + type t + integer :: i + end type t + type(t), dimension(4), parameter :: t1 = [( t(i), i = 1, 4)] + type(t), dimension(4), parameter :: t2 = [( t(i), i = 8, 11)] + type(t), dimension(2,2), parameter :: a = reshape ( t1, [ 2, 2 ] ) + type(t), dimension(2,2), parameter :: b = transpose (a) + type(t), dimension(4), parameter :: c = reshape ( b, [ 4 ] ) + type(t), dimension(2), parameter :: d = pack ( c, [.false.,.true.,.false.,.true.]) + type(t), dimension(4), parameter :: e = unpack (d, [.false.,.true.,.false.,.true.], t2) + type(t), dimension(4,2), parameter :: f = spread (e, 2, 2) + type(t), dimension(8), parameter :: g = reshape ( f, [ 8 ] ) + integer, parameter :: total = sum(g%i) + end module m + + use m + integer :: j + j = total + end +! { dg-final { scan-tree-dump-times "j = 50" 1 "original" } } diff --git a/Fortran/gfortran/regression/derived_comp_array_ref_1.f90 b/Fortran/gfortran/regression/derived_comp_array_ref_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_comp_array_ref_1.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! Tests the fix for PR27411, in which the array reference on line +! 18 caused an ICE because the derived type, rather than its integer +! component, was appearing in the index expression. +! +! Contributed by Richard Maine <1fhcwee02@sneakemail.com> +! +module gd_calc + type calc_signal_type + integer :: dummy + logical :: used + integer :: signal_number + end type +contains + subroutine activate_gd_calcs (used, outputs) + logical, intent(inout) :: used(:) + type(calc_signal_type), pointer :: outputs(:) + outputs%used = used(outputs%signal_number) + return + end subroutine activate_gd_calcs +end module gd_calc + + use gd_calc + integer, parameter :: ndim = 4 + integer :: i + logical :: used_(ndim) + type(calc_signal_type), pointer :: outputs_(:) + allocate (outputs_(ndim)) + forall (i = 1:ndim) outputs_(i)%signal_number = ndim + 1 - i + used_ = (/.true., .false., .true., .true./) + call activate_gd_calcs (used_, outputs_) + if (any (outputs_(ndim:1:-1)%used .neqv. used_)) STOP 1 +end diff --git a/Fortran/gfortran/regression/derived_comp_array_ref_2.f90 b/Fortran/gfortran/regression/derived_comp_array_ref_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_comp_array_ref_2.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! Tests the fix for PR31564, in which the actual argument to +! the call for set_bound was simplified when it should not be. +! +! Contributed by Michael Richmond +! +MODULE cdf_aux_mod + TYPE :: the_distribution + INTEGER :: parameters(2) + END TYPE the_distribution + TYPE (the_distribution), PARAMETER :: the_beta = the_distribution((/99,999/)) +CONTAINS + SUBROUTINE set_bound(arg_name, test) + INTEGER, INTENT (IN) :: arg_name, test + if (arg_name .ne. test) STOP 1 + END SUBROUTINE set_bound +END MODULE cdf_aux_mod + +MODULE cdf_beta_mod +CONTAINS + SUBROUTINE cdf_beta(which, test) + USE cdf_aux_mod + INTEGER :: which, test + CALL set_bound(the_beta%parameters(which), test) + END SUBROUTINE cdf_beta +END MODULE cdf_beta_mod + + use cdf_beta_mod + call cdf_beta (1, 99) + call cdf_beta (2, 999) +end diff --git a/Fortran/gfortran/regression/derived_comp_array_ref_3.f90 b/Fortran/gfortran/regression/derived_comp_array_ref_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_comp_array_ref_3.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! Tests the fix for PR33337, which was partly associated with +! the problem in PR31564 and, in addition, the parentheses in +! the initialization expression for the_chi_square. +! +! Contributed by Michael Richmond +! +MODULE cdf_nc_chisq_mod + PUBLIC + TYPE :: one_parameter + INTEGER :: high_bound + END TYPE one_parameter + TYPE :: the_distribution + TYPE (one_parameter) :: parameters(1) + END TYPE the_distribution + TYPE (the_distribution), PARAMETER :: the_chi_square = & + the_distribution((/(one_parameter(99))/)) +CONTAINS + SUBROUTINE local_cum_nc_chisq() + integer :: df0 + df0 = the_chi_square%parameters(1)%high_bound + print *, df0 + END SUBROUTINE local_cum_nc_chisq +END MODULE cdf_nc_chisq_mod + + use cdf_nc_chisq_mod + call local_cum_nc_chisq +end diff --git a/Fortran/gfortran/regression/derived_comp_array_ref_4.f90 b/Fortran/gfortran/regression/derived_comp_array_ref_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_comp_array_ref_4.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! Tests the fix for PR33376, which was a regression caused by the +! fix for PR31564. +! +! Contributed by Harald Anlauf +! +module foo + implicit none + public chk + + type mytype + character(len=4) :: str + end type mytype + type (mytype) ,parameter :: chk (2) & + = (/ mytype ("abcd") , mytype ("efgh") /) +end module foo + +module gfcbug70 + use foo, only: chk_ => chk + implicit none +contains + + subroutine chk (i) + integer, intent(in) :: i + if (i .eq. 1) then + if (chk_(i)% str .ne. "abcd") STOP 1 + else + if (chk_(i)% str .ne. "efgh") STOP 2 + end if + + end subroutine chk +end module gfcbug70 + + use gfcbug70 + call chk (2) + call chk (1) +end diff --git a/Fortran/gfortran/regression/derived_comp_array_ref_5.f90 b/Fortran/gfortran/regression/derived_comp_array_ref_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_comp_array_ref_5.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! Tests the fix for PR33566, in which the first variable array ref +! to v1 would cause an incompatible ranks error and the second an ICE. +! +! Contributed by Mikael Morin +! + program test_vec + + implicit none + + + integer :: i + real :: x + + type vec3 + real, dimension(3) :: coords + end type vec3 + + type(vec3),parameter :: v1 = vec3((/ 1.0, 2.0, 3.0 /)) + type(vec3) :: v2 + + v2 = vec3((/ 1.0, 2.0, 3.0 /)) + + + x = v1%coords(1) + + do i=1,3 + x = v1%coords(i) ! used to fail + x = v2%coords(i) + end do + + i = 2 + + v2 = vec3 (v1%coords ((/i+1, i, i-1/))) ! also broken + + end program test_vec diff --git a/Fortran/gfortran/regression/derived_comp_array_ref_6.f90 b/Fortran/gfortran/regression/derived_comp_array_ref_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_comp_array_ref_6.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! Check the fix for PR32129 in which the argument 'vec(vy(i, :))' was +! incorrectly simplified, resulting in an ICE and a missed error. +! +! Reported by Tobias Burnus +! + MODULE cdf_aux_mod + TYPE :: the_distribution + INTEGER :: parameters(1) + END TYPE the_distribution + TYPE (the_distribution), PARAMETER :: the_beta = the_distribution((/0/)) + CONTAINS + SUBROUTINE set_bound(arg_name) + INTEGER, INTENT (IN) :: arg_name + END SUBROUTINE set_bound + END MODULE cdf_aux_mod + MODULE cdf_beta_mod + CONTAINS + SUBROUTINE cdf_beta() + USE cdf_aux_mod + INTEGER :: which + which = 1 + CALL set_bound(the_beta%parameters(1:which)) ! { dg-error "Rank mismatch" } + END SUBROUTINE cdf_beta + END MODULE cdf_beta_mod diff --git a/Fortran/gfortran/regression/derived_comp_array_ref_7.f90 b/Fortran/gfortran/regression/derived_comp_array_ref_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_comp_array_ref_7.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! Check the fix for PR32129 #4 in which the argument 'vec(vy(i, :))' was +! incorrectly simplified, resulting in an ICE. +! +! Reported by Francois-Xavier Coudert +! +program testCode + implicit none + type vec + real, dimension(2) :: coords + end type + integer :: i + real, dimension(2,2), parameter :: vy = reshape ((/1,2,3,4/),(/2,2/)) + i = 1 + if (any (foo(vec(vy(i, :))) /= vy(i, :))) STOP 1 + +contains + + function foo (xin) + type(vec) :: xin + real, dimension (2) :: foo + intent(in) xin + foo = xin%coords + end function +end program diff --git a/Fortran/gfortran/regression/derived_comp_array_ref_8.f90 b/Fortran/gfortran/regression/derived_comp_array_ref_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_comp_array_ref_8.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! +! PR fortran/52325 +! +real :: f +cc%a = 5 ! { dg-error "Symbol 'cc' at .1. has no IMPLICIT type" } +f%a = 5 ! { dg-error "Unexpected '%' for nonderived-type variable 'f' at" } +end diff --git a/Fortran/gfortran/regression/derived_constructor_char_1.f90 b/Fortran/gfortran/regression/derived_constructor_char_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_constructor_char_1.f90 @@ -0,0 +1,49 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/44857 +! +! + Type :: t5 + character (len=5) :: txt(2) + End Type t5 + + character (len=3), parameter :: str3(2) = [ "ABC", "ZYX" ] + character (len=5), parameter :: str5(2) = [ "AbCdE", "ZyXwV" ] + character (len=5), parameter :: str7(2) = [ "aBcDeFg", "zYxWvUt" ] + + Type (t5) :: one = t5((/ "12345", "67890" /)) + Type (t5) :: two = t5((/ "123", "678" /)) + Type (t5) :: three = t5((/ "1234567", "abcdefg" /)) + Type (t5) :: four = t5(str3) + Type (t5) :: five = t5(str5) + Type (t5) :: six = t5(str7) + print '(2a)', one, two, three, four, five, six +End + +subroutine wasICEing() + implicit none + + Type :: Err_Text_Type + integer :: nlines + character (len=132), dimension(5) :: txt + End Type Err_Text_Type + + Type (Err_Text_Type) :: Mess_FindFMT = & + Err_Text_Type(0, (/" "," "," "," "," "/)) +end subroutine wasICEing + +subroutine anotherCheck() + Type :: t + character (len=3) :: txt(2) + End Type + Type (t) :: tt = t((/ character(len=5) :: "12345", "67890" /)) + print *, tt +end subroutine + +! { dg-final { scan-tree-dump-times "one = ..txt=..12345., .67890...;" 1 "original" } } +! { dg-final { scan-tree-dump-times "two = ..txt=..123 ., .678 ...;" 1 "original" } } +! { dg-final { scan-tree-dump-times "three = ..txt=..12345., .abcde...;" 1 "original" } } +! { dg-final { scan-tree-dump-times "four = ..txt=..ABC ., .ZYX ...;" 1 "original" } } +! { dg-final { scan-tree-dump-times "five = ..txt=..AbCdE., .ZyXwV...;" 1 "original" } } +! { dg-final { scan-tree-dump-times "six = ..txt=..aBcDe., .zYxWv...;" 1 "original" } } diff --git a/Fortran/gfortran/regression/derived_constructor_char_2.f90 b/Fortran/gfortran/regression/derived_constructor_char_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_constructor_char_2.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/44857 +! +! + + Type :: t + character (len=5) :: txt(2) + End Type + character (len=5) :: str(2) = [ "12345", "67890" ] + Type (t) :: tt = t( [str] ) ! { dg-error "does not reduce to a constant" } +End diff --git a/Fortran/gfortran/regression/derived_constructor_char_3.f90 b/Fortran/gfortran/regression/derived_constructor_char_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_constructor_char_3.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! +! PR fortran/51966 +! +! Contributed by Peter Wind +! + + type :: Deriv + character(len=10) :: name + end type + character(len=8), dimension(2), parameter :: & + DEF_ECOSYSTEMS = (/ "Gridxxxx", "StringYY" /) + + type(Deriv), save :: DepEcoSystem = Deriv(DEF_ECOSYSTEMS(1)) + + if (DepEcoSystem%name /= "Gridxxxx" & + .or. DepEcoSystem%name(9:9) /= ' ' & + .or. DepEcoSystem%name(10:10) /= ' ') STOP 1 + DepEcoSystem%name = 'ABCDEFGHIJ' + call Init_EcoSystems() + if (DepEcoSystem%name /= "StringYY" & + .or. DepEcoSystem%name(9:9) /= ' ' & + .or. DepEcoSystem%name(10:10) /= ' ') STOP 2 + +contains + subroutine Init_EcoSystems() + integer :: i =2 + DepEcoSystem = Deriv(DEF_ECOSYSTEMS(i)) + end subroutine Init_EcoSystems +end diff --git a/Fortran/gfortran/regression/derived_constructor_comps_1.f90 b/Fortran/gfortran/regression/derived_constructor_comps_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_constructor_comps_1.f90 @@ -0,0 +1,56 @@ +! { dg-do run } +! +! Tests fix for PR28425 in which anything other than a constructor would +! not work for derived type components in a structure constructor. +! +! Original version sent by Vivek Rao on 18 Jan 06 +! Modified by Steve Kargl to remove IO +! +module foo_mod + + implicit none + + type :: date_m + integer :: month + end type date_m + + type :: file_info + type(date_m) :: date + end type file_info + +end module foo_mod + +program prog + + use foo_mod + + implicit none + type(date_m) :: dat + type(file_info) :: xx + + type(date_m), parameter :: christmas = date_m (12) + + dat = date_m(1) + + xx = file_info(date_m(-1)) ! This always worked - a constructor + if (xx%date%month /= -1) STOP 1 + + xx = file_info(dat) ! This was the original PR - a variable + if (xx%date%month /= 1) STOP 2 + + xx = file_info(foo(2)) ! ...functions were also broken + if (xx%date%month /= 2) STOP 3 + + xx = file_info(christmas) ! ...and parameters + if (xx%date%month /= 12) STOP 4 + + +contains + + function foo (i) result (ans) + integer :: i + type(date_m) :: ans + ans = date_m(i) + end function foo + +end program prog diff --git a/Fortran/gfortran/regression/derived_constructor_comps_2.f90 b/Fortran/gfortran/regression/derived_constructor_comps_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_constructor_comps_2.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! Tests fix for PR29115, in which an ICE would be produced by +! non-pointer elements being supplied to the pointer components +! in a derived type constructor. +! +! Contributed by Paul Thomas +! + type :: homer + integer, pointer :: bart(:) + end type homer + type(homer) :: marge + integer :: duff_beer + marge = homer (duff_beer) ! { dg-error "should be a POINTER or a TARGET" } +end + +! +! The following yield an ICE, see PR 34083 +! +subroutine foo + type ByteType + character(len=1) :: singleByte + end type + type (ByteType) :: bytes(4) + + print *, size(bytes) + bytes = ByteType((/'H', 'i', '!', ' '/)) ! { dg-error "rank of the element in the structure constructor" } +end subroutine foo diff --git a/Fortran/gfortran/regression/derived_constructor_comps_3.f90 b/Fortran/gfortran/regression/derived_constructor_comps_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_constructor_comps_3.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! +! gfortran was ICEing for the constructor of +! componentfree types. +! +! Contributed by James Van Buskirk +! http://groups.google.com/group/comp.lang.fortran/browse_thread/thread/c8dd08d6da052499/ +! + module bug4_mod + implicit none + type bug4 ! no components + end type bug4 +end module bug4_mod + +program bug4_structure + use bug4_mod + implicit none + type(bug4) t + t = bug4() + write(*,*) t +end program bug4_structure diff --git a/Fortran/gfortran/regression/derived_constructor_comps_4.f90 b/Fortran/gfortran/regression/derived_constructor_comps_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_constructor_comps_4.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! +! PR 47789: [F03] Structure constructor of type extending DT with no components +! +! Contributed by eddyg_61-bugzilla@yahoo.it + +type:: one +end type + +type, extends(one) :: two + integer :: a +end type + +type(two) :: wo = two(6) + +if (wo%a /= 6) STOP 1 + +end diff --git a/Fortran/gfortran/regression/derived_constructor_comps_5.f90 b/Fortran/gfortran/regression/derived_constructor_comps_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_constructor_comps_5.f90 @@ -0,0 +1,59 @@ +! { dg-do run } +! +! PR fortran/65792 +! The evaluation of the argument in the call to new_prt_spec2 +! failed to properly initialize the comp component. +! While the array contents were properly copied, the array bounds remained +! uninitialized. +! +! Contributed by Dominique D'Humieres + +program main + implicit none + + integer, parameter :: n = 2 + + type :: string_t + character(LEN=1), dimension(:), allocatable :: chars + end type string_t + + type :: string_container_t + type(string_t) :: comp + end type string_container_t + + type(string_t) :: prt_in, tmp, tmpa(n) + type(string_container_t) :: tmpc, tmpca(n) + integer :: i, j, k + + do i=1,2 + +! scalar elemental function with structure constructor + prt_in = string_t(["D"]) + tmpc = new_prt_spec2 (string_container_t(prt_in)) + if (any(tmpc%comp%chars .ne. ["D"])) STOP 1 + deallocate (prt_in%chars) + deallocate(tmpc%comp%chars) +! Check that function arguments are OK too + tmpc = new_prt_spec2 (string_container_t(new_str_t(["h","e","l","l","o"]))) + if (any(tmpc%comp%chars .ne. ["h","e","l","l","o"])) STOP 1 + deallocate(tmpc%comp%chars) + + end do + +contains + + impure elemental function new_prt_spec2 (name) result (prt_spec) + type(string_container_t), intent(in) :: name + type(string_container_t) :: prt_spec + prt_spec = name + end function new_prt_spec2 + + + function new_str_t (name) result (prt_spec) + character (*), intent(in), dimension (:) :: name + type(string_t) :: prt_spec + prt_spec = string_t(name) + end function new_str_t + +end program main + diff --git a/Fortran/gfortran/regression/derived_constructor_comps_6.f90 b/Fortran/gfortran/regression/derived_constructor_comps_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_constructor_comps_6.f90 @@ -0,0 +1,133 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } +! +! PR fortran/61831 +! The deallocation of components of array constructor elements +! used to have the side effect of also deallocating some other +! variable's components from which they were copied. + +program main + implicit none + + integer, parameter :: n = 2 + + type :: string_t + character(LEN=1), dimension(:), allocatable :: chars + end type string_t + + type :: string_container_t + type(string_t) :: comp + end type string_container_t + + type :: string_array_container_t + type(string_t) :: comp(n) + end type string_array_container_t + + type(string_t) :: prt_in, tmp, tmpa(n) + type(string_container_t) :: tmpc, tmpca(n) + type(string_array_container_t) :: tmpac, tmpaca(n) + integer :: i, j, k + + do i=1,16 + + ! Test without intermediary function + prt_in = string_t(["A"]) + if (.not. allocated(prt_in%chars)) STOP 1 + if (any(prt_in%chars .ne. "A")) STOP 2 + deallocate (prt_in%chars) + + ! scalar elemental function + prt_in = string_t(["B"]) + if (.not. allocated(prt_in%chars)) STOP 3 + if (any(prt_in%chars .ne. "B")) STOP 4 + tmp = new_prt_spec (prt_in) + if (.not. allocated(prt_in%chars)) STOP 5 + if (any(prt_in%chars .ne. "B")) STOP 6 + deallocate (prt_in%chars) + deallocate (tmp%chars) + + ! array elemental function with array constructor + prt_in = string_t(["C"]) + if (.not. allocated(prt_in%chars)) STOP 7 + if (any(prt_in%chars .ne. "C")) STOP 8 + tmpa = new_prt_spec ([(prt_in, i=1,2)]) + if (.not. allocated(prt_in%chars)) STOP 9 + if (any(prt_in%chars .ne. "C")) STOP 10 + deallocate (prt_in%chars) + do j=1,n + deallocate (tmpa(j)%chars) + end do + + ! scalar elemental function with structure constructor + prt_in = string_t(["D"]) + if (.not. allocated(prt_in%chars)) STOP 11 + if (any(prt_in%chars .ne. "D")) STOP 12 + tmpc = new_prt_spec2 (string_container_t(prt_in)) + if (.not. allocated(prt_in%chars)) STOP 13 + if (any(prt_in%chars .ne. "D")) STOP 14 + deallocate (prt_in%chars) + deallocate(tmpc%comp%chars) + + ! array elemental function of an array constructor of structure constructors + prt_in = string_t(["E"]) + if (.not. allocated(prt_in%chars)) STOP 15 + if (any(prt_in%chars .ne. "E")) STOP 16 + tmpca = new_prt_spec2 ([ (string_container_t(prt_in), i=1,2) ]) + if (.not. allocated(prt_in%chars)) STOP 17 + if (any(prt_in%chars .ne. "E")) STOP 18 + deallocate (prt_in%chars) + do j=1,n + deallocate (tmpca(j)%comp%chars) + end do + + ! scalar elemental function with a structure constructor and a nested array constructor + prt_in = string_t(["F"]) + if (.not. allocated(prt_in%chars)) STOP 19 + if (any(prt_in%chars .ne. "F")) STOP 20 + tmpac = new_prt_spec3 (string_array_container_t([ (prt_in, i=1,2) ])) + if (.not. allocated(prt_in%chars)) STOP 21 + if (any(prt_in%chars .ne. "F")) STOP 22 + deallocate (prt_in%chars) + do j=1,n + deallocate (tmpac%comp(j)%chars) + end do + + ! array elemental function with an array constructor nested inside + ! a structure constructor nested inside an array constructor + prt_in = string_t(["G"]) + if (.not. allocated(prt_in%chars)) STOP 23 + if (any(prt_in%chars .ne. "G")) STOP 24 + tmpaca = new_prt_spec3 ([ (string_array_container_t([ (prt_in, i=1,2) ]), j=1,2) ]) + if (.not. allocated(prt_in%chars)) STOP 25 + if (any(prt_in%chars .ne. "G")) STOP 26 + deallocate (prt_in%chars) + do j=1,n + do k=1,n + deallocate (tmpaca(j)%comp(k)%chars) + end do + end do + + end do + +contains + + elemental function new_prt_spec (name) result (prt_spec) + type(string_t), intent(in) :: name + type(string_t) :: prt_spec + prt_spec = name + end function new_prt_spec + + elemental function new_prt_spec2 (name) result (prt_spec) + type(string_container_t), intent(in) :: name + type(string_container_t) :: prt_spec + prt_spec = name + end function new_prt_spec2 + + elemental function new_prt_spec3 (name) result (prt_spec) + type(string_array_container_t), intent(in) :: name + type(string_array_container_t) :: prt_spec + prt_spec = name + end function new_prt_spec3 +end program main +! { dg-final { scan-tree-dump-times "__builtin_malloc" 15 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free" 33 "original" } } diff --git a/Fortran/gfortran/regression/derived_constructor_comps_7.f90 b/Fortran/gfortran/regression/derived_constructor_comps_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_constructor_comps_7.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! PR fortran/104619 + +module m + implicit none + type :: item + real :: x + end type item + type :: container + type(item) :: items(3) + end type container +end module + +program p + use m + implicit none + type(item), allocatable :: items(:) + type(container) :: c + integer :: i, n + items = [item(3.0), item(4.0), item(5.0)] + c = container(items=[(items(i), i = 1, size(items))]) + if (any (c%items% x /= items% x)) stop 1 + n = size (items) + c = container(items=[(items(i), i = 1, n)]) + if (any (c%items% x /= items% x)) stop 2 + c = container(items=[(items(i), i = 1, 3)]) + if (any (c%items% x /= items% x)) stop 3 +end program diff --git a/Fortran/gfortran/regression/derived_external_function_1.f90 b/Fortran/gfortran/regression/derived_external_function_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_external_function_1.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! +! PR fortran/58771 +! +! Contributed by Vittorio Secca +! +! ICEd on the write statement with f() because the derived type backend +! declaration not built. +! +module m + type t + integer(4) g + end type +end + +type(t) function f() result(ff) + use m + ff%g = 42 +end + + use m + character (20) :: line1, line2 + type(t) f + write (line1, *) f() + write (line2, *) 42_4 + if (line1 .ne. line2) STOP 1 +end diff --git a/Fortran/gfortran/regression/derived_function_interface_1.f90 b/Fortran/gfortran/regression/derived_function_interface_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_function_interface_1.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! Tests the fix for PR29634, in which an ICE would occur in the +! interface declaration of a function with an 'old-style' type +! declaration. When fixed, it was found that the error message +! was not very helpful - this was fixed. +! +! Contributed by Francois-Xavier Coudert +! +module kinds + type foo + integer :: i + end type foo +end module + +type(foo) function ext_fun() + use kinds + ext_fun%i = 1 +end function ext_fun + + use kinds + + interface fun_interface + type(foo) function fun() + use kinds + end function fun + end interface + + interface ext_fun_interface + type(foo) function ext_fun() + use kinds + end function ext_fun + end interface + + type(foo) :: x + + x = ext_fun () + print *, x%i + +contains + + type(foo) function fun() ! { dg-error "already has an explicit interface" } + end function fun ! { dg-error "Expecting END PROGRAM" } + +end diff --git a/Fortran/gfortran/regression/derived_init_1.f90 b/Fortran/gfortran/regression/derived_init_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_init_1.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! Check that allocatable/pointer variables of derived types with initialized +! components are are initialized when allocated +! PR 21625 +program test + + implicit none + type :: t + integer :: a = 3 + end type t + type :: s + type(t), pointer :: p(:) + type(t), pointer :: p2 + end type s + type(t), pointer :: p + type(t), allocatable :: q(:,:) + type(s) :: z + type(s) :: x(2) + + allocate(p, q(2,2)) + if (p%a /= 3) STOP 1 + if (any(q(:,:)%a /= 3)) STOP 2 + + allocate(z%p2, z%p(2:3)) + if (z%p2%a /= 3) STOP 3 + if (any(z%p(:)%a /= 3)) STOP 4 + + allocate(x(1)%p2, x(1)%p(2)) + if (x(1)%p2%a /= 3) STOP 5 + if (any(x(1)%p(:)%a /= 3)) STOP 6 +end program test + diff --git a/Fortran/gfortran/regression/derived_init_2.f90 b/Fortran/gfortran/regression/derived_init_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_init_2.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! PR 25217: INTENT(OUT) dummies of derived type with default initializers shall +! be (re)initialized upon procedure entry, unless they are ALLOCATABLE. +! Modified to take account of the regression, identified by Martin Tees +! http://gcc.gnu.org/ml/fortran/2006-08/msg00276.html and fixed with +! PR 28788. +module dt + type :: drv + integer :: a(3) = [ 1, 2, 3 ] + character(3) :: s = "abc" + real, pointer :: p => null() + end type drv +end module dt + +module subs +contains + subroutine foo(fb) + use dt + type(drv), intent(out) :: fb + call sub (fb) + end subroutine foo + + subroutine sub(fa) + use dt + type(drv), intent(out) :: fa + + if (any(fa%a /= [ 1, 2, 3 ])) STOP 1 + if (fa%s /= "abc") STOP 2 + if (associated(fa%p)) STOP 3 + end subroutine sub +end module subs + +program main + use dt + use subs + implicit none + type(drv) :: aa + type(drv), allocatable :: ab(:) + real, target :: x = 99, y = 999 + + aa = drv ([ 4, 5, 6], "def", x) + call sub(aa) + + aa = drv ([ 7, 8, 9], "ghi", y) + call foo(aa) +end program main + diff --git a/Fortran/gfortran/regression/derived_init_3.f90 b/Fortran/gfortran/regression/derived_init_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_init_3.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! +! PR fortran/40851 +! +! Make sure the an INTENT(OUT) dummy is not initialized +! when it is a pointer. +! +! Contributed by Juergen Reuter . +! +program main + + type :: string + character,dimension(:),allocatable :: chars + end type string + + type :: string_container + type(string) :: string + end type string_container + + type(string_container), target :: tgt + type(string_container), pointer :: ptr + + ptr => tgt + call set_ptr (ptr) + if (associated(ptr)) STOP 1 + +contains + + subroutine set_ptr (ptr) + type(string_container), pointer, intent(out) :: ptr + ptr => null () + end subroutine set_ptr + +end program main diff --git a/Fortran/gfortran/regression/derived_init_4.f90 b/Fortran/gfortran/regression/derived_init_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_init_4.f90 @@ -0,0 +1,60 @@ +! { dg-do run } +! +! Test the fix for PR81048, where in the second call to 'g2' the +! default initialization was "forgotten". 'g1', 'g1a' and 'g3' check +! that this does not occur for scalars and explicit results. +! +! Contributed by David Smith +! +program test + type f + integer :: f = -1 + end type + type(f) :: a, b(3) + type(f), allocatable :: ans + b = g2(a) + b = g2(a) + ans = g1(a) + if (ans%f .ne. -1) STOP 1 + ans = g1(a) + if (ans%f .ne. -1) STOP 2 + ans = g1a(a) + if (ans%f .ne. -1) STOP 3 + ans = g1a(a) + if (ans%f .ne. -1) STOP 4 + b = g3(a) + b = g3(a) +contains + function g3(a) result(res) + type(f) :: a, res(3) + do j = 1, 3 + if (res(j)%f == -1) then + res(j)%f = a%f - 1 + else + STOP 5 + endif + enddo + end function g3 + + function g2(a) + type(f) :: a, g2(3) + do j = 1, 3 + if (g2(j)%f == -1) then + g2(j)%f = a%f - 1 + else + STOP 6 + endif + enddo + end function g2 + + function g1(a) + type(f) :: g1, a + if (g1%f .ne. -1 ) STOP 7 + end function + + function g1a(a) result(res) + type(f) :: res, a + if (res%f .ne. -1 ) STOP 8 + end function +end program test + diff --git a/Fortran/gfortran/regression/derived_init_5.f90 b/Fortran/gfortran/regression/derived_init_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_init_5.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! PR 59781 - this was not initialized correctly before. +! Original test case by James Spencer. + implicit none + + type t1 + integer :: s + end type + + type t2 + type(t1) :: state = t1(1) + real, allocatable :: store(:) + end type + + call test + +contains + + subroutine test + type(t2) :: rng + if (rng%state%s /= 1) STOP 1 + end subroutine + +end diff --git a/Fortran/gfortran/regression/derived_init_6.f90 b/Fortran/gfortran/regression/derived_init_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_init_6.f90 @@ -0,0 +1,60 @@ +! { dg-do compile } +! +! Test the fix for PR69654 in which the derived type 'ty_foo2' was +! not completely built in time for initialization thereby causing an ICE. +! +! Contributed by Hossein Talebi +! + Module foo_pointers_class + implicit none + type :: ty_foo_pointers + integer :: scale=0 + integer,pointer :: universe_ulogfile => NULL() + class(*),pointer :: foo => NULL() + end type ty_foo_pointers + + type :: ty_part_ptrs + character(len=80),pointer :: part_name => NULL() + class(*),pointer :: part_fem => NULL() + end type + + type :: ty_class_basis + integer :: id=0 + end type ty_class_basis + + type :: ty_store_sclass + class(ty_class_basis),allocatable :: OBJ + end type ty_store_sclass +End Module foo_pointers_class + +Module foo_class + use foo_pointers_class + implicit none + type,extends(ty_class_basis) :: ty_foo2 + character(200) :: title + logical :: isInit=.false. + type(ty_foo_pointers) :: foo + end type ty_foo2 +ENd Module foo_class + + +Module foo_scripts_mod + implicit none +contains + +subroutine foo_script1 + use foo_class, only: ty_foo2 + implicit none + type(ty_foo2) :: foo2 + integer i + + Call foo_init2(foo2) +end subroutine foo_script1 + +subroutine foo_init2(self) + use foo_class, only: ty_foo2 + type(ty_foo2),target :: self + self%isInit=.true. +end subroutine foo_init2 + +End Module foo_scripts_mod diff --git a/Fortran/gfortran/regression/derived_name_1.f90 b/Fortran/gfortran/regression/derived_name_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_name_1.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! PR 20897 +! Make sure intrinsic type names do not appear as names of derived types +type integer ! { dg-error "cannot be the same as an intrinsic type" } +type real ! { dg-error "cannot be the same as an intrinsic type" } +type complex ! { dg-error "cannot be the same as an intrinsic type" } +type character ! { dg-error "cannot be the same as an intrinsic type" } +type logical ! { dg-error "cannot be the same as an intrinsic type" } +type complex ! { dg-error "cannot be the same as an intrinsic type" } +type double precision +type doubleprecision ! { dg-error "cannot be the same as an intrinsic type" } +type double complex +type doublecomplex ! { dg-error "cannot be the same as an intrinsic type" } + +type x + integer y +end type x +end + diff --git a/Fortran/gfortran/regression/derived_name_2.f b/Fortran/gfortran/regression/derived_name_2.f --- /dev/null +++ b/Fortran/gfortran/regression/derived_name_2.f @@ -0,0 +1,19 @@ +! { dg-do compile } +! PR 20897 +! Make sure intrinsic type names do not appear as names of derived types + type integer ! { dg-error "cannot be the same as an intrinsic type" } + type real ! { dg-error "cannot be the same as an intrinsic type" } + type complex ! { dg-error "cannot be the same as an intrinsic type" } + type character ! { dg-error "cannot be the same as an intrinsic type" } + type logical ! { dg-error "cannot be the same as an intrinsic type" } + type complex ! { dg-error "cannot be the same as an intrinsic type" } + type double precision ! { dg-error "cannot be the same as an intrinsic type" } + type doubleprecision ! { dg-error "cannot be the same as an intrinsic type" } + type double complex ! { dg-error "cannot be the same as an intrinsic type" } + type doublecomplex ! { dg-error "cannot be the same as an intrinsic type" } + + type x + integer y + end type x + end + diff --git a/Fortran/gfortran/regression/derived_pointer_null_1.f90 b/Fortran/gfortran/regression/derived_pointer_null_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_pointer_null_1.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! { dg-options "-std=gnu" } +! +! Test of fix (patch unknown) for pr19181 and pr21300. This test is based +! on the example given in 21300. Note that this can be executed. +! +! Contributed by Paul Thomas +! + TYPE ast_obs + real, DIMENSION(:), POINTER :: geopos + END TYPE ast_obs + + TYPE(ast_obs), PARAMETER :: undefined_ast_obs = AST_OBS(NULL()) + type(ast_obs) :: my_ast_obs + real, target, dimension(10) :: rt + + my_ast_obs%geopos => rt + if (.not.associated (my_ast_obs%geopos)) STOP 1 + + call get_null_ast_obs (my_ast_obs) + if (associated (my_ast_obs%geopos)) STOP 2 + +CONTAINS + + SUBROUTINE get_null_ast_obs (obs1) + TYPE(ast_obs) :: obs1 + obs1 = undefined_ast_obs + RETURN + END SUBROUTINE get_null_ast_obs + +END + diff --git a/Fortran/gfortran/regression/derived_pointer_recursion.f90 b/Fortran/gfortran/regression/derived_pointer_recursion.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_pointer_recursion.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-O0" } +! Tests patch for PR24092 - This would ICE because of the loop in the +! derived type definitions. +! + module llo + type :: it + character*10 :: k + integer :: c(2) + end type it + type :: bt + type (nt), pointer :: p + end type bt + type :: nt + type (it) :: i + type (bt) :: b + end type nt + type (bt), pointer :: ptr + end module llo +! copyright 1996 Loren P. Meissner -- May be distributed if this line is included. +! Linked List operations with Pointer to Pointer diff --git a/Fortran/gfortran/regression/derived_pointer_recursion_2.f90 b/Fortran/gfortran/regression/derived_pointer_recursion_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_pointer_recursion_2.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! +! PR 40594: [4.5 Regression] wrong-code +! +! Original test case by Daniel Franke +! Modified by Janus Weil + +MODULE atom_types + +TYPE :: atom_list + TYPE(atom_private), DIMENSION(:), pointer :: table +END TYPE + +TYPE :: atom_private + TYPE(atom_list) :: neighbors + LOGICAL :: initialized = .true. +END TYPE + +TYPE :: atom_model + TYPE(atom_list) :: atoms + integer :: dummy +END TYPE + +contains + + SUBROUTINE init(this) + TYPE(atom_private) :: this + this%initialized = .FALSE. + END SUBROUTINE + +END MODULE + + +program pr40594 + + USE atom_types + TYPE(atom_model) :: am + type(atom_private) :: ap + + am%dummy = 0 + + call init(ap) + if (ap%initialized .neqv. .false.) STOP 1 + +END diff --git a/Fortran/gfortran/regression/derived_recursion.f90 b/Fortran/gfortran/regression/derived_recursion.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_recursion.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-O0" } +! Tests patch for PR24158 - The module would compile, in spite +! of the recursion between the derived types. This would cause +! an ICE in the commented out main program. The standard demands +! that derived type components be already defined, to break +! recursive derived type definitions. +! +! Contributed by Paul Thomas +! +module snafu + type :: a + integer :: v + type(b) :: i ! { dg-error "not been previously defined" } + end type a + type :: b + type(a) :: i + end type b + type (a) :: foo +end module snafu + +! use snafu +! foo%v = 1 +! end diff --git a/Fortran/gfortran/regression/derived_result.f90 b/Fortran/gfortran/regression/derived_result.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_result.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! PR 78593: [6/7 Regression] ICE in gfc_match_varspec, at fortran/primary.c:2053 +! +! Contributed by Gerhard Steinmetz + +type(t) function add (x, y) ! { dg-error "is not accessible" } + integer, intent(in) :: x, y + add%a = x + y ! { dg-error "Unclassifiable statement" } +end diff --git a/Fortran/gfortran/regression/derived_result_2.f90 b/Fortran/gfortran/regression/derived_result_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_result_2.f90 @@ -0,0 +1,45 @@ +! { dg-do compile } +! +! PR 42188: [OOP] F03:C612. The leftmost part-name shall be the name of a data object +! +! Contributed by Janus Weil + +module grid_module + implicit none + type grid + contains + procedure :: new_grid + procedure :: new_int + end type +contains + subroutine new_grid(this) + class(grid) :: this + end subroutine + integer function new_int(this) + class(grid) :: this + new_int = 42 + end function +end module + +module field_module + use grid_module + implicit none + + type field + type(grid) :: mesh + end type + +contains + + type(field) function new_field() + end function + + subroutine test + integer :: i + type(grid) :: g + g = new_field()%mesh ! { dg-error "cannot be a function reference" } + call new_field()%mesh%new_grid() ! { dg-error "Syntax error" } + i = new_field() % mesh%new_int() ! { dg-error "cannot be a function reference" } + end subroutine + +end module diff --git a/Fortran/gfortran/regression/derived_sub.f90 b/Fortran/gfortran/regression/derived_sub.f90 --- /dev/null +++ b/Fortran/gfortran/regression/derived_sub.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! PR35475 gfortran fails to compile valid code with ICE error in fold-const.c +! Test case from PR report added to avoid future regression +module modone + type mytype + real :: myvar + end type +end module + +module modtwo + interface + subroutine subone(mytype_cur) + use modone + type (mytype) mytype_cur + end subroutine + end interface + +contains + + subroutine subtwo(mytype_cur) + use modone + type (mytype) mytype_cur,mytype_fin + mytype_fin=mytype_cur + return + end subroutine + + subroutine subthree(mytype_cur) + use modone + type (mytype) mytype_cur + call subone(mytype_cur) + end subroutine + +end module diff --git a/Fortran/gfortran/regression/dev_null.F90 b/Fortran/gfortran/regression/dev_null.F90 --- /dev/null +++ b/Fortran/gfortran/regression/dev_null.F90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! pr19478 read from /dev/null +! Thomas.Koenig@online.de +#if defined _WIN32 +#define DEV_NULL "nul" +#else +#define DEV_NULL "/dev/null" +#endif + character*20 foo + open(10,file=DEV_NULL) + write(10,'(A)') "Hello" + rewind(10) + read(10,'(A)',end=100) foo + STOP 1 + 100 continue + end diff --git a/Fortran/gfortran/regression/dfloat_1.f90 b/Fortran/gfortran/regression/dfloat_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dfloat_1.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! Progam to test the dfloat intrinsic. +program dfloat_1 + implicit none + integer(2) i2 + integer(4) i4 + integer(8) i8 + i2 = -4_2 + i4 = 4_4 + i8 = 10_8 + if (dfloat(i2) /= -4.d0) STOP 1 ! { dg-warning "non-default INTEGER" } + if (dfloat(i4) /= 4.d0) STOP 2 + if (dfloat(i8) /= 10.d0) STOP 3 ! { dg-warning "non-default INTEGER" } + if (dfloat(i4*i2) /= -16.d0) STOP 4 + + if (kind(dfloat(i4)) /= kind(1.0_8)) STOP 1 + if (kind(dfloat(i8)) /= kind(1.0_8)) STOP 2! { dg-warning "non-default INTEGER" } +end program dfloat_1 diff --git a/Fortran/gfortran/regression/dg.exp b/Fortran/gfortran/regression/dg.exp --- /dev/null +++ b/Fortran/gfortran/regression/dg.exp @@ -0,0 +1,65 @@ +# Copyright (C) 2004-2023 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# . + +# GCC testsuite that uses the `dg.exp' driver. + +# Load support procs. +load_lib gfortran-dg.exp + +# If a testcase doesn't have special options, use these. +global DEFAULT_FFLAGS +if ![info exists DEFAULT_FFLAGS] then { + set DEFAULT_FFLAGS " -pedantic-errors" +} + +# Initialize `dg'. +dg-init + +global gfortran_test_path +global gfortran_aux_module_flags +set gfortran_test_path $srcdir/$subdir +set gfortran_aux_module_flags $DEFAULT_FFLAGS +proc dg-compile-aux-modules { args } { + global gfortran_test_path + global gfortran_aux_module_flags + if { [llength $args] != 2 } { + error "dg-compile-aux-modules: needs one argument" + return + } + + set level [info level] + if { [info procs dg-save-unknown] != [list] } { + rename dg-save-unknown dg-save-unknown-level-$level + } + + dg-test $gfortran_test_path/[lindex $args 1] "" $gfortran_aux_module_flags + # cleanup-modules is intentionally not invoked here. + + if { [info procs dg-save-unknown-level-$level] != [list] } { + rename dg-save-unknown-level-$level dg-save-unknown + } +} + +# Main loop. +gfortran-dg-runtest [lsort \ + [glob -nocomplain $srcdir/$subdir/*.\[fF\]{,90,95,03,08} ] ] "" $DEFAULT_FFLAGS + +gfortran-dg-runtest [lsort \ + [glob -nocomplain $srcdir/$subdir/g77/*.\[fF\] ] ] "" $DEFAULT_FFLAGS + + +# All done. +dg-finish diff --git a/Fortran/gfortran/regression/diagnostic-format-json-1.F90 b/Fortran/gfortran/regression/diagnostic-format-json-1.F90 --- /dev/null +++ b/Fortran/gfortran/regression/diagnostic-format-json-1.F90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-fdiagnostics-format=json" } + +#error message + +! Use dg-regexp to consume the JSON output starting with +! the innermost values, and working outwards. +! We can't rely on any ordering of the keys. + +! { dg-regexp "\"kind\": \"error\"" } +! { dg-regexp "\"column-origin\": 1" } +! { dg-regexp "\"escape-source\": false" } +! { dg-regexp "\"message\": \"#error message\"" } + +! { dg-regexp "\"caret\": \{" } +! { dg-regexp "\"file\": \"\[^\n\r\"\]*diagnostic-format-json-1.F90\"" } +! { dg-regexp "\"line\": 4" } +! { dg-regexp "\"column\": 2" } +! { dg-regexp "\"display-column\": 2" } +! { dg-regexp "\"byte-column\": 2" } + +! { dg-regexp "\"finish\": \{" } +! { dg-regexp "\"file\": \"\[^\n\r\"\]*diagnostic-format-json-1.F90\"" } +! { dg-regexp "\"line\": 4" } +! { dg-regexp "\"column\": 6" } +! { dg-regexp "\"display-column\": 6" } +! { dg-regexp "\"byte-column\": 6" } + +! { dg-regexp "\"locations\": \[\[\{\}, \]*\]" } +! { dg-regexp "\"children\": \[\[\]\[\]\]" } +! { dg-regexp "\[\[\{\}, \]*\]" } diff --git a/Fortran/gfortran/regression/diagnostic-format-json-2.F90 b/Fortran/gfortran/regression/diagnostic-format-json-2.F90 --- /dev/null +++ b/Fortran/gfortran/regression/diagnostic-format-json-2.F90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-options "-fdiagnostics-format=json" } + +#warning message + +! Use dg-regexp to consume the JSON output starting with +! the innermost values, and working outwards. +! We can't rely on any ordering of the keys. + +! { dg-regexp "\"kind\": \"warning\"" } +! { dg-regexp "\"column-origin\": 1" } +! { dg-regexp "\"escape-source\": false" } +! { dg-regexp "\"message\": \"#warning message\"" } +! { dg-regexp "\"option\": \"-Wcpp\"" } +! { dg-regexp "\"option_url\": \"\[^\n\r\"\]*#index-Wcpp\"" } + +! { dg-regexp "\"caret\": \{" } +! { dg-regexp "\"file\": \"\[^\n\r\"\]*diagnostic-format-json-2.F90\"" } +! { dg-regexp "\"line\": 4" } +! { dg-regexp "\"column\": 2" } +! { dg-regexp "\"display-column\": 2" } +! { dg-regexp "\"byte-column\": 2" } + +! { dg-regexp "\"finish\": \{" } +! { dg-regexp "\"file\": \"\[^\n\r\"\]*diagnostic-format-json-2.F90\"" } +! { dg-regexp "\"line\": 4" } +! { dg-regexp "\"column\": 8" } +! { dg-regexp "\"display-column\": 8" } +! { dg-regexp "\"byte-column\": 8" } + +! { dg-regexp "\"locations\": \[\[\{\}, \]*\]" } +! { dg-regexp "\"children\": \[\[\]\[\]\]" } +! { dg-regexp "\[\[\{\}, \]*\]" } diff --git a/Fortran/gfortran/regression/diagnostic-format-json-3.F90 b/Fortran/gfortran/regression/diagnostic-format-json-3.F90 --- /dev/null +++ b/Fortran/gfortran/regression/diagnostic-format-json-3.F90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-options "-fdiagnostics-format=json -Werror" } + +#warning message + +! Use dg-regexp to consume the JSON output starting with +! the innermost values, and working outwards. +! We can't rely on any ordering of the keys. + +! { dg-regexp "\"kind\": \"error\"" } +! { dg-regexp "\"column-origin\": 1" } +! { dg-regexp "\"escape-source\": false" } +! { dg-regexp "\"message\": \"#warning message\"" } +! { dg-regexp "\"option\": \"-Werror=cpp\"" } +! { dg-regexp "\"option_url\": \"\[^\n\r\"\]*#index-Wcpp\"" } + +! { dg-regexp "\"caret\": \{" } +! { dg-regexp "\"file\": \"\[^\n\r\"\]*diagnostic-format-json-3.F90\"" } +! { dg-regexp "\"line\": 4" } +! { dg-regexp "\"column\": 2" } +! { dg-regexp "\"display-column\": 2" } +! { dg-regexp "\"byte-column\": 2" } + +! { dg-regexp "\"finish\": \{" } +! { dg-regexp "\"file\": \"\[^\n\r\"\]*diagnostic-format-json-3.F90\"" } +! { dg-regexp "\"line\": 4" } +! { dg-regexp "\"column\": 8" } +! { dg-regexp "\"display-column\": 8" } +! { dg-regexp "\"byte-column\": 8" } + +! { dg-regexp "\"locations\": \[\[\{\}, \]*\]" } +! { dg-regexp "\"children\": \[\[\]\[\]\]" } +! { dg-regexp "\[\[\{\}, \]*\]" } diff --git a/Fortran/gfortran/regression/dim_range_1.f90 b/Fortran/gfortran/regression/dim_range_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dim_range_1.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! PR 44693 - check for invalid dim even in functions. +! Based on a test case by Dominique d'Humieres. +subroutine test1(esss,Ix,Iyz, n) + real(kind=kind(1.0d0)), dimension(n), intent(out) :: esss + real(kind=kind(1.0d0)), dimension(n,n,n) :: sp + real(kind=kind(1.0d0)), dimension(n,n) :: Ix,Iyz + esss = sum(Ix * Iyz, 0) ! { dg-error "is not a valid dimension index" } + esss = sum(Ix * Iyz, 1) + esss = sum(Ix * Iyz, 2) + esss = sum(Ix * Iyz, 3) ! { dg-error "is not a valid dimension index" } + sp = spread (ix * iyz, 0, n) ! { dg-error "is not a valid dimension index" } + sp = spread (ix * iyz, 1, n) + sp = spread (ix * iyz, 2, n) + sp = spread (ix * iyz, 3, n) + sp = spread (ix * iyz, 4, n) ! { dg-error "is not a valid dimension index" } +end subroutine diff --git a/Fortran/gfortran/regression/dim_sum_1.f90 b/Fortran/gfortran/regression/dim_sum_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dim_sum_1.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! { dg-shouldfail "Dim argument incorrect in SUM intrinsic: is 5, should be between 1 and 2" } + +program summation + + integer, parameter :: n1=5, n2=7 + integer, dimension(1:n1,1:n2) :: arr + integer, dimension(1:n1) :: r2 + integer, dimension(1:n2) :: r1 + integer :: i,j + character(len=80) :: c1, c2 + character(len=50) :: fmt = '(10I5)' + do j=1,n2 + do i=1,n1 + arr(i,j) = i+j*10 + end do + end do + + r1 = sum(arr,dim=1) + write (unit=c2, fmt=fmt) r1 + call print_sum(1,c1) + if (c1 /= c2) STOP 1 + r2 = sum(arr,dim=2) + write (unit=c2, fmt=fmt) r2 + call print_sum(2,c1) + if (c1 /= c2) STOP 2 + call print_sum(5,c1) + +contains + + subroutine print_sum(d, c) + integer, intent(in) :: d + character(len=80), intent(out) :: c + write (unit=c, fmt=fmt) sum(arr,dim=d) + end subroutine + +end diff --git a/Fortran/gfortran/regression/dim_sum_2.f90 b/Fortran/gfortran/regression/dim_sum_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dim_sum_2.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! { dg-shouldfail "Dim argument incorrect in SUM intrinsic: is 5, should be between 1 and 2" } + +program summation + + integer, parameter :: n1=5, n2=7 + integer, dimension(1:n1,1:n2) :: arr + integer, dimension(1:n1) :: r2 + integer, dimension(1:n2) :: r1 + integer :: i,j + character(len=80) :: c1, c2 + character(len=50) :: fmt = '(10I5)' + do j=1,n2 + do i=1,n1 + arr(i,j) = i+j*10 + end do + end do + + r1 = sum(arr,dim=1,mask=arr>23) + write (unit=c2, fmt=fmt) r1 + call print_sum(1,c1) + if (c1 /= c2) STOP 1 + r2 = sum(arr,dim=2,mask=arr>23) + write (unit=c2, fmt=fmt) r2 + call print_sum(2,c1) + if (c1 /= c2) STOP 2 + call print_sum(5,c1) + +contains + + subroutine print_sum(d, c) + integer, intent(in) :: d + character(len=80), intent(out) :: c + write (unit=c, fmt=fmt) sum(arr,dim=d,mask=arr>23) + end subroutine + +end diff --git a/Fortran/gfortran/regression/dim_sum_3.f90 b/Fortran/gfortran/regression/dim_sum_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dim_sum_3.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! { dg-shouldfail "Dim argument incorrect in SUM intrinsic: is 5, should be between 1 and 2" } + +program summation + + integer, parameter :: n1=5, n2=7 + integer, dimension(1:n1,1:n2) :: arr + integer, dimension(1:n1) :: r2 + integer, dimension(1:n2) :: r1 + integer :: i,j + character(len=80) :: c1, c2 + character(len=50) :: fmt = '(10I5)' + do j=1,n2 + do i=1,n1 + arr(i,j) = i+j*10 + end do + end do + + r1 = sum(arr,dim=1,mask=.true.) + write (unit=c2, fmt=fmt) r1 + call print_sum(1,c1) + if (c1 /= c2) STOP 1 + r2 = sum(arr,dim=2,mask=.true.) + write (unit=c2, fmt=fmt) r2 + call print_sum(2,c1) + if (c1 /= c2) STOP 2 + call print_sum(5,c1) + +contains + + subroutine print_sum(d, c) + integer, intent(in) :: d + character(len=80), intent(out) :: c + write (unit=c, fmt=fmt) sum(arr,dim=d,mask=.true.) + end subroutine + +end diff --git a/Fortran/gfortran/regression/direct_io_1.f90 b/Fortran/gfortran/regression/direct_io_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/direct_io_1.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! PR 16908 +! Segfaulted on second set of writes. We weren't handling partial records +! properly when calculating the file position. +program direct_io_1 + implicit none + + integer n, nt, mt, m + real dt, tm, w + real, allocatable :: p(:) + + nt = 2049 ! if nt < 2049, then everything works. + + allocate(p(nt)) + p = 0.e0 + + inquire(iolength=mt) (p(m), m=1, nt) + + open(unit=12, file='syn.sax', access='direct', recl=mt) + n = 1 + write(12, rec=n) mt, nt + write(12, rec=n+1) (p(m), m=1, nt) + close(12) + + inquire(iolength=mt) (p(m), m=1, nt) + + open(unit=12, file='syn.sax', access='direct', recl=mt) + n = 1 + write(12, rec=n) mt, nt + write(12, rec=n+1) (p(m), m=1, nt) + close(12, status='delete') +end program diff --git a/Fortran/gfortran/regression/direct_io_10.f b/Fortran/gfortran/regression/direct_io_10.f --- /dev/null +++ b/Fortran/gfortran/regression/direct_io_10.f @@ -0,0 +1,46 @@ +! { dg-do run } +! pr35699 run-time abort writing zero sized section to direct access file + program directio + call qi0010 ( 10, 1, 2, 3, 4, 9, 2) + end + + subroutine qi0010 (nf10, nf1, nf2, nf3, nf4,nf9, np2) + character(10) bda(nf10) + character(10) bda1(nf10), bval + + integer j_len + bda1(1) = 'x' + do i = 2,10 + bda1(i) = 'x'//bda1(i-1) + enddo + bda = 'unread' + + inquire(iolength = j_len) bda1(nf1:nf10:nf2), bda1(nf4:nf3), + $ bda1(nf2:nf10:nf2) + + open (unit=48, + $ access='direct', + $ status='scratch', + $ recl = j_len, + $ iostat = istat, + $ form='unformatted', + $ action='readwrite') + + write (48,iostat = istat, rec = 3) bda1(nf1:nf10:nf2), + $ bda1(nf4:nf3), bda1(nf2:nf10:nf2) + if ( istat .ne. 0) then + STOP 1 + endif + istat = -314 + + read (48,iostat = istat, rec = np2+1) bda(nf1:nf9:nf2), + $ bda(nf4:nf3), bda(nf2:nf10:nf2) + if ( istat .ne. 0) then + STOP 2 + endif + + do j1 = 1,10 + bval = bda1(j1) + if (bda(j1) .ne. bval) STOP 3 + enddo + end subroutine diff --git a/Fortran/gfortran/regression/direct_io_11.f90 b/Fortran/gfortran/regression/direct_io_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/direct_io_11.f90 @@ -0,0 +1,55 @@ +! { dg-do run } +! PR42090 Problems reading partial records in formatted direct access files +! Test case from PR, prepared by Jerry DeLisle +program da_good_now + implicit none + real :: a, b + + a = 1.111111111 + b = 2.222222222 + + open( 10, file = 't.dat', form = 'formatted', access = 'direct', recl = 12 ) + write( 10, rec = 1, fmt = '( f6.4, /, f6.4 )' ) a, b + close( 10 ) + + a = -1.0 + b = -1.0 + + open( 10, file = 't.dat', form = 'formatted', access = 'direct', recl = 12 ) + + read( 10, rec = 1, fmt = '( f6.4, /, f6.4 )' ) a, b + !write( *, '( "partial record 1", t25, 2( f6.4, 1x ) )' ) a, b + a = -1.0 + b = -1.0 + + read( 10, rec = 1, fmt = '( f6.4 )' ) a, b + !write( *, '( "partial record 2", t25, 2( f6.4, 1x ) )' ) a, b + if (a /= 1.1111 .and. b /= 2.2222) STOP 1 + a = -1.0 + b = -1.0 + + read( 10, rec = 1, fmt = '( f12.4, /, f12.4 )' ) a, b + !write( *, '( "full record 1", t25, 2( f6.4, 1x ) )' ) a, b + if (a /= 1.1111 .and. b /= 2.2222) STOP 2 + a = -1.0 + b = -1.0 + + read( 10, rec = 1, fmt = '( f12.4 )' ) a, b + !write( *, '( "full record 2", t25, 2( f6.4, 1x ) )' ) a, b + if (a /= 1.1111 .and. b /= 2.2222) STOP 3 + a = -1.0 + b = -1.0 + + read( 10, rec = 1, fmt = '( f6.4, 6x, /, f6.4, 6x )' ) a, b + !write( *, '( "full record with 6x", t25, 2( f6.4, 1x ) )' ) a, b + if (a /= 1.1111 .and. b /= 2.2222) STOP 4 + a = -1.0 + b = -1.0 + + read( 10, rec = 1, fmt = '( f6.4 )' ) a + read( 10, rec = 2, fmt = '( f6.4 )' ) b + !write( *, '( "record at a time", t25, 2( f6.4, 1x ) )' ) a, b + if (a /= 1.1111 .and. b /= 2.2222) STOP 5 + + close( 10, status="delete") +end program da_good_now diff --git a/Fortran/gfortran/regression/direct_io_12.f90 b/Fortran/gfortran/regression/direct_io_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/direct_io_12.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! +! PR fortran/43551 +! +! Writes a 672000 byte file with buffering. The writing failed because +! of a missing lseek. + +implicit none +integer, parameter :: size = 2800 ! << needs to be large enough +real(8) :: vec1(size,30), dummy(size) +integer i + +CALL RANDOM_NUMBER(vec1) + +open(99, file='test.dat', form='unformatted', access='direct', recl=size*8) +do i = 1, 10 + write(99,rec=i) vec1(:,i) + write(99,rec=i+10) vec1(:,i+10) + write(99,rec=i+20) vec1(:,i+20) ! << rec = 30 was written to rec = 21 +end do + +do i = 1, 10 + read(99,rec=i) dummy + if (any (dummy /= vec1(:,i))) STOP 1 + read(99,rec=i+10) dummy + if (any (dummy /= vec1(:,i+10))) STOP 2 + read(99,rec=i+20) dummy + if (any (dummy /= vec1(:,i+20))) STOP 3 ! << aborted here for rec = 21 +end do + +close(99, status='delete') +end + diff --git a/Fortran/gfortran/regression/direct_io_2.f90 b/Fortran/gfortran/regression/direct_io_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/direct_io_2.f90 @@ -0,0 +1,48 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! this testcase derived from NIST test FM413.FOR +! tests writing direct access files in ascending and descending +! REC's. + PROGRAM FM413 + IMPLICIT LOGICAL (L) + IMPLICIT CHARACTER*14 (C) + IMPLICIT INTEGER(4) (I) + DATA IPROG, IFILE, ITOTR, IRLGN, IRECN, IEOF,ICON21, ICON22, ICON31, ICON32, ICON33, ICON34, ICON55, ICON56 /14*0/ + OPEN (7, ACCESS = 'DIRECT', RECL = 80, STATUS='REPLACE', FILE="FOO" ) + IRECN = 13 + IREC = 13 + DO 4132 I = 1,100 + IREC = IREC + 2 + IRECN = IRECN + 2 + WRITE(7, REC = IREC) IPROG, IFILE, ITOTR, IRLGN, IRECN, IEOF,ICON21, ICON22, ICON31, ICON32, ICON33, ICON34, ICON55, ICON56 + 4132 CONTINUE + IRECN = 216 + IREC = 216 + DO 4133 I=1,100 + IREC = IREC - 2 + IRECN = IRECN - 2 + WRITE(7, REC = IREC) IPROG, IFILE, ITOTR, IRLGN, IRECN, IEOF,ICON21, ICON22, ICON31, ICON32, ICON33, ICON34, ICON55, ICON56 + 4133 CONTINUE + IRECCK = 13 + IRECN = 0 + IREC = 13 + IVCOMP = 0 + DO 4134 I = 1,100 + IREC = IREC + 2 + IRECCK = IRECCK + 2 + READ(7, REC = IREC) IPROG, IFILE, ITOTR, IRLGN, IRECN, IEOF,IVON21, IVON22, IVON31, IVON32, IVON33, IVON34, IVON55, IVON56 + IF (IRECN .NE. IRECCK) STOP 1 + 4134 CONTINUE + IRECCK = 216 + IRECN = 0 + IREC = 216 + DO 4135 I = 1,100 + IREC = IREC - 2 + IRECCK = IRECCK - 2 + READ(7, REC = IREC) IPROG, IFILE, ITOTR, IRLGN, IRECN, IEOF,IVON21, IVON22, IVON31, IVON32, IVON33, IVON34, IVON55, IVON56 + IF (IRECN .NE. IRECCK) STOP 2 + 4135 CONTINUE + CLOSE(7, STATUS='DELETE') + STOP + END diff --git a/Fortran/gfortran/regression/direct_io_3.f90 b/Fortran/gfortran/regression/direct_io_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/direct_io_3.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! PR 18710 : We used to not read and write the imaginary part of +! complex numbers + COMPLEX C, D + COMPLEX(KIND=8) E, F + + OPEN(UNIT=9,FILE='PR18710',ACCESS='DIRECT',RECL=132) + + C = (120.0,240.0) + WRITE(9,REC=1)C + READ(9,REC=1)D + if (c /= d) STOP 1 + + E = (120.0,240.0) + WRITE(9,REC=1)E + READ(9,REC=1)F + if (E /= F) STOP 2 + + CLOSE(UNIT=9,STATUS='DELETE') + END diff --git a/Fortran/gfortran/regression/direct_io_4.f90 b/Fortran/gfortran/regression/direct_io_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/direct_io_4.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! PR 23321 : Running off the end of a file was not detected with direct I/O. +program main + implicit none + integer(kind=1) :: a, b + integer :: ios, i + + a = 42 + open (unit=10,status="scratch",recl=1,access="direct") + write(10,rec=1) a + + read (10,rec=2, iostat=ios) b + if (ios == 0) STOP 1 + + read (10, rec=82641, iostat=ios) b ! This used to cause a segfault + if (ios == 0) STOP 2 + + read(10, rec=1, iostat=ios) b + if (ios /= 0) STOP 3 + if (a /= b) STOP 4 + +end program main diff --git a/Fortran/gfortran/regression/direct_io_5.f90 b/Fortran/gfortran/regression/direct_io_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/direct_io_5.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! PR27757 Problems with direct access I/O +! This test checks a series of random writes followed by random reads. +! Contributed by Jerry DeLisle + +program testdirect + implicit none + integer, dimension(100) :: a + integer :: i,j,k,ier + real :: x + data a / 13, 9, 34, 41, 25, 98, 6, 12, 11, 44, 79, 3,& + & 64, 61, 77, 57, 59, 2, 92, 38, 71, 64, 31, 60, 28, 90, 26,& + & 97, 47, 26, 48, 96, 95, 82, 100, 90, 45, 71, 71, 67, 72,& + & 76, 94, 49, 85, 45, 100, 22, 96, 48, 13, 23, 40, 14, 76, 99,& + & 96, 90, 65, 2, 8, 60, 96, 19, 45, 1, 100, 48, 91, 20, 92,& + & 72, 81, 59, 24, 37, 43, 21, 54, 68, 31, 19, 79, 63, 41,& + & 42, 12, 10, 62, 43, 9, 30, 9, 54, 35, 4, 5, 55, 3, 94 / + + open(unit=15,file="testdirectio",access="direct",form="unformatted",recl=89) + do i=1,100 + k = a(i) + write(unit=15, rec=k) k + enddo + do j=1,100 + read(unit=15, rec=a(j), iostat=ier) k + if (ier.ne.0) then + STOP 1 + else + if (a(j) /= k) STOP 2 + endif + enddo + close(unit=15, status="delete") +end program testdirect \ No newline at end of file diff --git a/Fortran/gfortran/regression/direct_io_6.f90 b/Fortran/gfortran/regression/direct_io_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/direct_io_6.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! pr31366 last record truncated for read after short write, direct access file. +! test case derived from pr, submitted by jerry delisle 1 + j = 0 + do i = HUGE(i) - 10, HUGE(i), 2 + j = j + 1 + end do + if (j .ne. 6) STOP 1 + j = 0 + do i = HUGE(i) - 9, HUGE(i), 2 + j = j + 1 + end do + if (j .ne. 5) STOP 2 + + ! Same again, but unknown loop step + if (test1(10, 1) .ne. 11) STOP 3 + if (test1(10, 2) .ne. 6) STOP 4 + if (test1(9, 2) .ne. 5) STOP 5 + + ! Zero iterations + j = 0 + do i = 1, 0, 1 ! { dg-warning "executed zero times" } + j = j + 1 + end do + if (j .ne. 0) STOP 6 + j = 0 + do i = 1, 0, 2 ! { dg-warning "executed zero times" } + j = j + 1 + end do + if (j .ne. 0) STOP 7 + j = 0 + do i = 1, 2, -1 ! { dg-warning "executed zero times" } + j = j + 1 + end do + if (j .ne. 0) STOP 8 + call test2 (0, 1) + call test2 (0, 2) + call test2 (2, -1) + call test2 (2, -2) + + ! Bound near smallest value + j = 0; + do i = -HUGE(i), -HUGE(i), 10 + j = j + 1 + end do + if (j .ne. 1) STOP 9 +contains +! Returns the number of iterations performed. +function test1(r, step) + implicit none + integer test1, r, step + integer k, n + k = 0 + do n = HUGE(n) - r, HUGE(n), step + k = k + 1 + end do + test1 = k +end function + +subroutine test2 (lim, step) + implicit none + integer lim, step + integer k, n + k = 0 + do n = 1, lim, step + k = k + 1 + end do + if (k .ne. 0) STOP 10 +end subroutine +end program diff --git a/Fortran/gfortran/regression/do_2.f90 b/Fortran/gfortran/regression/do_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_2.f90 @@ -0,0 +1,54 @@ +! { dg-do compile } +! Check the fix for PR20839, which concerned non-compliance with one of the +! constraints for block-do-constructs (8.1.4.1.1): +! Constraint: If the do-stmt of a block-do-construct is identified by a +! do-construct-name, the corresponding end-do shall be an end-do-stmt +! specifying the same do-construct-name. (Tests a & b) +! If the do-stmt of a block-do-construct is not identified by a +! do-construct-name, the corresponding end-do shall not specify a +! do-construct-name. (Tests c & d) +! Constraint: If the do-stmt is a nonlabel-do-stmt, the corresponding end-do +! shall be an end-do-stmt. +! Constraint: If the do-stmt is a label-do-stmt, the corresponding end-do shall +! be identified with the same label. +! +! Test a - this was the PR + doi: DO 111 i=1,3 ! { dg-error "requires matching ENDDO name" } +111 continue +! Test b + doii: DO 112 ij=1,3 +112 enddo doij ! { dg-error "Expected label" } +! Test c + DO 113 ik=1,3 +113 enddo doik ! { dg-error "Syntax error" } +! Test d + DO il=1,3 + enddo doil ! { dg-error "Syntax error" } +! Test e + doj: DO 114 j=1,3 + enddo doj ! { dg-error "doesn't match DO label" } + +! Correct block do constructs +dok: DO 115 k=1,3 + dokk: do kk=1,3 + dokkk: DO + do kkkk=1,3 + do + enddo + enddo + enddo dokkk + enddo dokk +115 enddo dok +! Correct non-block do constructs + do 117 l=1,3 + do ll=1,3 + do 116 lll=1,3 +116 continue + enddo +117 enddo +! These prevent an EOF error, arising from the previous errors. +end do +113 end do +112 end do doii +END + diff --git a/Fortran/gfortran/regression/do_3.F90 b/Fortran/gfortran/regression/do_3.F90 --- /dev/null +++ b/Fortran/gfortran/regression/do_3.F90 @@ -0,0 +1,111 @@ +! { dg-do run } +! { dg-options "-std=legacy -ffree-line-length-none -fno-range-check -fwrapv -Wzerotrip" } +program test + integer :: count + integer :: i + integer(kind=1) :: i1 + real :: r + +#define TEST_LOOP(var,from,to,step,total,test,final) \ + count = 0 ; do var = from, to, step ; count = count + 1 ; end do ; \ + if (count /= total) STOP 1; \ + if (test (from, to, step, final) /= total) STOP 2 + + ! Integer loops + TEST_LOOP(i, 0, 0, 1, 1, test_i, 1) + TEST_LOOP(i, 0, 0, 2, 1, test_i, 2) + TEST_LOOP(i, 0, 0, -1, 1, test_i, -1) + TEST_LOOP(i, 0, 0, -2, 1, test_i, -2) + + TEST_LOOP(i, 0, 1, 1, 2, test_i, 2) + TEST_LOOP(i, 0, 1, 2, 1, test_i, 2) + TEST_LOOP(i, 0, 1, 3, 1, test_i, 3) + TEST_LOOP(i, 0, 1, huge(0), 1, test_i, huge(0)) + TEST_LOOP(i, 0, 1, -1, 0, test_i, 0) ! { dg-warning "executed zero times" } + TEST_LOOP(i, 0, 1, -2, 0, test_i, 0) ! { dg-warning "executed zero times" } + TEST_LOOP(i, 0, 1, -3, 0, test_i, 0) ! { dg-warning "executed zero times" } + TEST_LOOP(i, 0, 1, -huge(0), 0, test_i, 0) ! { dg-warning "executed zero times" } + TEST_LOOP(i, 0, 1, -huge(0)-1, 0, test_i, 0) ! { dg-warning "executed zero times" } + + TEST_LOOP(i, 1, 0, 1, 0, test_i, 1) ! { dg-warning "executed zero times" } + TEST_LOOP(i, 1, 0, 2, 0, test_i, 1) ! { dg-warning "executed zero times" } + TEST_LOOP(i, 1, 0, 3, 0, test_i, 1) ! { dg-warning "executed zero times" } + TEST_LOOP(i, 1, 0, huge(0), 0, test_i, 1) ! { dg-warning "executed zero times" } + TEST_LOOP(i, 1, 0, -1, 2, test_i, -1) + TEST_LOOP(i, 1, 0, -2, 1, test_i, -1) + TEST_LOOP(i, 1, 0, -3, 1, test_i, -2) + TEST_LOOP(i, 1, 0, -huge(0), 1, test_i, 1-huge(0)) + TEST_LOOP(i, 1, 0, -huge(0)-1, 1, test_i, -huge(0)) + + TEST_LOOP(i, 0, 17, 1, 18, test_i, 18) + TEST_LOOP(i, 0, 17, 2, 9, test_i, 18) + TEST_LOOP(i, 0, 17, 3, 6, test_i, 18) + TEST_LOOP(i, 0, 17, 4, 5, test_i, 20) + TEST_LOOP(i, 0, 17, 5, 4, test_i, 20) + TEST_LOOP(i, 17, 0, -1, 18, test_i, -1) + TEST_LOOP(i, 17, 0, -2, 9, test_i, -1) + TEST_LOOP(i, 17, 0, -3, 6, test_i, -1) + TEST_LOOP(i, 17, 0, -4, 5, test_i, -3) + TEST_LOOP(i, 17, 0, -5, 4, test_i, -3) + + TEST_LOOP(i1, -huge(i1)-1_1, huge(i1), 2_1, int(huge(i1))+1, test_i1, huge(i1)+1_1) + TEST_LOOP(i1, -huge(i1)-1_1, huge(i1), huge(i1), 3, test_i1, 2_1*huge(i1)-1_1) + + TEST_LOOP(i1, huge(i1), -huge(i1)-1_1, -2_1, int(huge(i1))+1, test_i1, -huge(i1)-2_1) + TEST_LOOP(i1, huge(i1), -huge(i1)-1_1, -huge(i1), 3, test_i1, -2_1*huge(i1)) + TEST_LOOP(i1, huge(i1), -huge(i1)-1_1, -huge(i1)-1_1, 2, test_i1, -huge(i1)-2_1) + + TEST_LOOP(i1, -2_1, 3_1, huge(i1), 1, test_i1, huge(i1)-2_1) + TEST_LOOP(i1, -2_1, 3_1, -huge(i1), 0, test_i1, -2_1) ! { dg-warning "executed zero times" } + TEST_LOOP(i1, 2_1, -3_1, -huge(i1), 1, test_i1, 2_1-huge(i1)) + TEST_LOOP(i1, 2_1, -3_1, huge(i1), 0, test_i1, 2_1) ! { dg-warning "executed zero times" } + + ! Real loops + TEST_LOOP(r, 0.0, 1.0, 0.11, 1 + int(1.0/0.11), test_r, 0.0) + TEST_LOOP(r, 0.0, 1.0, -0.11, 0, test_r, 0.0) ! { dg-warning "executed zero times" } + TEST_LOOP(r, 0.0, -1.0, 0.11, 0, test_r, 0.0) ! { dg-warning "executed zero times" } + TEST_LOOP(r, 0.0, -1.0, -0.11, 1 + int(1.0/0.11), test_r, 0.0) + TEST_LOOP(r, 0.0, 0.0, 0.11, 1, test_r, 0.0) + TEST_LOOP(r, 0.0, 0.0, -0.11, 1, test_r, 0.0) + +#undef TEST_LOOP + +contains + + function test_i1 (from, to, step, final) result(res) + integer(kind=1), intent(in) :: from, to, step, final + integer(kind=1) :: i + integer :: res + + res = 0 + do i = from, to, step + res = res + 1 + end do + if (i /= final) STOP 3 + end function test_i1 + + function test_i (from, to, step, final) result(res) + integer, intent(in) :: from, to, step, final + integer :: i + integer :: res + + res = 0 + do i = from, to, step + res = res + 1 + end do + if (i /= final) STOP 4 + end function test_i + + function test_r (from, to, step, final) result(res) + real, intent(in) :: from, to, step, final + real :: i + integer :: res + + res = 0 + do i = from, to, step + res = res + 1 + end do + ! final is ignored + end function test_r + +end program test diff --git a/Fortran/gfortran/regression/do_4.f b/Fortran/gfortran/regression/do_4.f --- /dev/null +++ b/Fortran/gfortran/regression/do_4.f @@ -0,0 +1,10 @@ +! { dg-do compile } +! Verify that the loop not terminated on an action-stmt is correctly rejected + do10i=1,20 + if(i.eq.5)then + goto 10 + 10 endif ! { dg-error "is within another block" } + end ! { dg-error "END DO statement expected" } + ! { dg-warning "Fortran 2018 deleted feature: DO termination statement which is not END DO or CONTINUE" "" { target "*-*-*" } 6 } +! { dg-error "Unexpected end of file" "" { target "*-*-*" } 0 } + diff --git a/Fortran/gfortran/regression/do_5.f90 b/Fortran/gfortran/regression/do_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_5.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! +! PR fortran/54370 +! +! The following program was ICEing at tree-check time +! "L()" was regarded as default-kind logical. +! +! Contributed by Kirill Chilikin +! + MODULE M + CONTAINS + + LOGICAL(C_BOOL) FUNCTION L() BIND(C) + USE, INTRINSIC :: ISO_C_BINDING + L = .FALSE. + END FUNCTION + + LOGICAL(8) FUNCTION L2() BIND(C) ! { dg-warning "GNU Extension: LOGICAL result variable 'l2' at .1. with non-C_Bool kind in BIND.C. procedure 'l2'" } + L2 = .FALSE._8 + END FUNCTION + + SUBROUTINE S() + DO WHILE (L()) + ENDDO + DO WHILE (L2()) + ENDDO + END + + END diff --git a/Fortran/gfortran/regression/do_check_1.f90 b/Fortran/gfortran/regression/do_check_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_check_1.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-fcheck=do" } +! { dg-shouldfail "DO check" } +! +! PR fortran/34656 +! Run-time check for zero STEP +! +program test + implicit none + integer :: i,j + j = 0 + do i = 1, 40, j + print *, i + end do +end program test +! { dg-output "Fortran runtime error: DO step value is zero" } diff --git a/Fortran/gfortran/regression/do_check_10.f90 b/Fortran/gfortran/regression/do_check_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_check_10.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! { dg-options "-Wall -Wno-zerotrip" } +program main + do i=1,0 + print *,i + end do +end program main diff --git a/Fortran/gfortran/regression/do_check_11.f90 b/Fortran/gfortran/regression/do_check_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_check_11.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! { dg-options "-fcheck=do" } +! { dg-shouldfail "DO check" } +! +program test + implicit none + integer(1) :: i + do i = HUGE(i)-10, HUGE(i) + print *, i + end do +end program test +! { dg-output "Fortran runtime error: Loop iterates infinitely" } diff --git a/Fortran/gfortran/regression/do_check_12.f90 b/Fortran/gfortran/regression/do_check_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_check_12.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! { dg-options "-fcheck=do" } +! { dg-shouldfail "DO check" } +! +program test + implicit none + integer(1) :: i + do i = -HUGE(i)+10, -HUGE(i)-1, -1 + print *, i + end do +end program test +! { dg-output "Fortran runtime error: Loop iterates infinitely" } diff --git a/Fortran/gfortran/regression/do_check_13.f90 b/Fortran/gfortran/regression/do_check_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_check_13.f90 @@ -0,0 +1,86 @@ +program main + implicit none + integer :: i1, i2, i3, i4, i5, i6, i7 + integer :: j + do i1=1,10 + call sub1 ! { dg-error "Index variable 'i1' redefined" } + end do + do i2=1,10 + call sub2 ! { dg-error "Index variable 'i2' redefined" } + end do + do i3=1,10 + j = fcn3() ! { dg-error "Index variable 'i3' redefined" } + end do + do i4=1,10 + j = fcn4() ! { dg-error "Index variable 'i4' redefined" } + end do + do i5=1,10 + call sub5 ! { dg-error "Index variable 'i5' set to undefined" } + end do + + call sub6 + + do i7=1,10 + call sub7 ! { dg-error "Index variable 'i7' not definable" } + end do +contains + subroutine sub1 + i1 = 5 ! { dg-error "Index variable 'i1' redefined" } + end subroutine sub1 + + subroutine sub2 + do i2=1,5 ! { dg-error "Index variable 'i2' redefined" } + end do + end subroutine sub2 + + integer function fcn3() + i3 = 1 ! { dg-error "Index variable 'i3' redefined" } + fcn3 = i3 + end function fcn3 + + integer function fcn4() + open (10,file="foo.dat", iostat=i4) ! { dg-error "Index variable 'i4' redefined" } + fcn4 = 12 + end function fcn4 + + subroutine sub5 + integer :: k + k = intentout(i5) ! { dg-error "Index variable 'i5' set to undefined" } + end subroutine sub5 + + subroutine sub6 + do i6=1,10 + call sub6a ! { dg-error "Index variable 'i6' redefined" } + end do + end subroutine sub6 + + subroutine sub6a + i6 = 5 ! { dg-error "Index variable 'i6' redefined" } + end subroutine sub6a + + subroutine sub7 + integer :: k + k = intentinout (i7) ! { dg-error "Index variable 'i7' not definable" } + end subroutine sub7 + + integer function intentout(i) + integer, intent(out) :: i + end function intentout + + integer function intentinout(i) + integer, intent(inout) :: i + end function intentinout +end program main + +module foo + integer :: j1 +contains + subroutine mod_sub_1 + do j1=1,10 + call aux ! { dg-error "Index variable 'j1' redefined" } + end do + end subroutine mod_sub_1 + subroutine aux + j1 = 3 ! { dg-error "Index variable 'j1' redefined" } + end subroutine aux +end module foo diff --git a/Fortran/gfortran/regression/do_check_14.f90 b/Fortran/gfortran/regression/do_check_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_check_14.f90 @@ -0,0 +1,56 @@ +! { dg-do compile } +! PR fortran/96469 - make sure that all legal variants pass. + +module x + implicit none +contains + subroutine sub_intent_in(i) + integer, intent(in) :: i + end subroutine sub_intent_in + subroutine sub_intent_unspec(i) + integer :: i + end subroutine sub_intent_unspec + integer function fcn_intent_in(i) + integer, intent(in) :: i + fcn_intent_in = i + 42 + end function fcn_intent_in + integer function fcn_intent_unspec (i) + integer :: i + fcn_intent_unspec = i + 42 + end function fcn_intent_unspec +end module x + +program main + use x + implicit none + integer :: i1, i2, i3, i4 + integer :: k, l + do i1=1,10 + call sub1 + end do + do i2=1,10 + call sub2 + end do + do i3 = 1,10 + k = fcn3() + end do + do i4=1,10 + l = fcn4() + end do +contains + subroutine sub1 + call sub_intent_in (i1) + end subroutine sub1 + subroutine sub2 + integer :: m + m = fcn_intent_in (i2) + print *,m + end subroutine sub2 + integer function fcn3() + call sub_intent_unspec (i3) + fcn3 = 42 + end function fcn3 + integer function fcn4() + fcn4 = fcn_intent_unspec (i4) + end function fcn4 +end program main diff --git a/Fortran/gfortran/regression/do_check_15.f90 b/Fortran/gfortran/regression/do_check_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_check_15.f90 @@ -0,0 +1,58 @@ +! { dg-do compile } +! PR fortran/96556 - this used to cause an ICE. +! Test case by Juergen Reuter. +module polarizations + + implicit none + private + + type :: smatrix_t + private + integer :: dim = 0 + integer :: n_entry = 0 + integer, dimension(:,:), allocatable :: index + contains + procedure :: write => smatrix_write + end type smatrix_t + + type, extends (smatrix_t) :: pmatrix_t + private + contains + procedure :: write => pmatrix_write + procedure :: normalize => pmatrix_normalize + end type pmatrix_t + +contains + + subroutine msg_error (string) + character(len=*), intent(in), optional :: string + end subroutine msg_error + + subroutine smatrix_write (object) + class(smatrix_t), intent(in) :: object + end subroutine smatrix_write + + subroutine pmatrix_write (object) + class(pmatrix_t), intent(in) :: object + call object%smatrix_t%write () + end subroutine pmatrix_write + + subroutine pmatrix_normalize (pmatrix) + class(pmatrix_t), intent(inout) :: pmatrix + integer :: i, hmax + logical :: fermion, ok + do i = 1, pmatrix%n_entry + associate (index => pmatrix%index(:,i)) + if (index(1) == index(2)) then + call error ("diagonal must be real") + end if + end associate + end do + contains + subroutine error (msg) + character(*), intent(in) :: msg + call pmatrix%write () + end subroutine error + end subroutine pmatrix_normalize + +end module polarizations diff --git a/Fortran/gfortran/regression/do_check_16.f90 b/Fortran/gfortran/regression/do_check_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_check_16.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +program main + implicit none + integer :: iq,nq,recl + DO iq = 1, nq + call foobar ! { dg-error "redefined" } + ENDDO +CONTAINS + + subroutine foobar + inquire (iolength=nq) iq ! { dg-error "redefined" } + end subroutine foobar +END program main diff --git a/Fortran/gfortran/regression/do_check_17.f90 b/Fortran/gfortran/regression/do_check_17.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_check_17.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! PR 99345 - this used to cause an ICE. +! Original test case by Matthias Klose +program main + implicit none + integer :: iq,nq,recl + DO iq = 1, nq + CALL calc_upper_fan (iq) + ENDDO +CONTAINS + SUBROUTINE calc_upper_fan (iq) + INTEGER :: iq + INTEGER :: recl + INQUIRE(IOLENGTH=recl) iq + END SUBROUTINE calc_upper_fan +END diff --git a/Fortran/gfortran/regression/do_check_18.f90 b/Fortran/gfortran/regression/do_check_18.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_check_18.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! PR103718, +! PR103719 - ICE in doloop_contained_procedure_code +! Contributed by G.Steinmetz + +subroutine s1 + integer :: i + do i = 1, 2 + call s + end do +contains + subroutine s + integer :: n + inquire (iolength=n) 0 ! valid + end +end + +subroutine s2 + integer :: i + do i = 1, 2 + call s + end do +contains + subroutine s + shape(1) = 0 ! { dg-error "Non-variable expression" } + end +end diff --git a/Fortran/gfortran/regression/do_check_19.f90 b/Fortran/gfortran/regression/do_check_19.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_check_19.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-prune-output "Obsolescent feature: Alternate-return argument" } +! PR fortran/103717 - ICE in doloop_code +! Contributed by G.Steinmetz + +program p + integer :: i + do i = 1, 2 + call s(i) ! { dg-error "Missing alternate return specifier" } + end do +contains + subroutine s(*) + end +end + +recursive subroutine s(*) + integer :: i + do i = 1, 2 + call s(i) ! { dg-error "Missing alternate return specifier" } + end do +end diff --git a/Fortran/gfortran/regression/do_check_2.f90 b/Fortran/gfortran/regression/do_check_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_check_2.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-options "-fcheck=do" } +! { dg-shouldfail "DO check" } +! +! PR fortran/34656 +! Run-time check for modifing loop variables +! +program test + implicit none + integer :: i,j + do i = 1, 10 + call modLoopVar(i) + end do +contains + subroutine modLoopVar(i) + integer :: i + i = i + 1 + end subroutine modLoopVar +end program test +! { dg-output "Fortran runtime error: Loop variable has been modified" } diff --git a/Fortran/gfortran/regression/do_check_3.f90 b/Fortran/gfortran/regression/do_check_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_check_3.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! { dg-options "-fcheck=do" } +! { dg-shouldfail "DO check" } +! +! PR fortran/34656 +! Run-time check for modifing loop variables +! +program test + implicit none + real :: i, j, k + j = 10.0 + k = 1.0 + do i = 1.0, j, k ! { dg-warning "must be integer" } + call modLoopVar(i) + end do +contains + subroutine modLoopVar(x) + real :: x + x = x + 1 + end subroutine modLoopVar +end program test +! { dg-output "Fortran runtime error: Loop variable has been modified" } diff --git a/Fortran/gfortran/regression/do_check_4.f90 b/Fortran/gfortran/regression/do_check_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_check_4.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! { dg-options "-fcheck=do" } +! { dg-shouldfail "DO check" } +! +! PR fortran/34656 +! Run-time check for modifing loop variables +! + +module x + integer :: i +contains + SUBROUTINE do_something() + IMPLICIT NONE + DO i=1,10 + ENDDO + END SUBROUTINE do_something +end module x + +PROGRAM test + use x + IMPLICIT NONE + DO i=1,100 + CALL do_something() + ENDDO +end PROGRAM test + +! { dg-output "Fortran runtime error: Loop variable has been modified" } diff --git a/Fortran/gfortran/regression/do_check_5.f90 b/Fortran/gfortran/regression/do_check_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_check_5.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! { dg-options "-Wall" } +! PR/fortran 38432 +! DO-loop compile-time checks +! +implicit none +integer :: i +real :: r +do i = 1, 0 ! { dg-warning "executed zero times" } +end do + +do i = 1, -1, 1 ! { dg-warning "executed zero times" } +end do + +do i = 1, 2, -1 ! { dg-warning "executed zero times" } +end do + +do i = 1, 2, 0 ! { dg-error "cannot be zero" } +end do + +do r = 1, 0 ! { dg-warning "must be integer|executed zero times" } +end do + +do r = 1, -1, 1 ! { dg-warning "must be integer|executed zero times" } +end do + +do r = 1, 2, -1 ! { dg-warning "must be integer|executed zero times" } +end do + +do r = 1, 2, 0 +end do +! { dg-warning "must be integer" "loop var" { target *-*-* } 30 } +! { dg-error "cannot be zero" "loop step" { target *-*-* } 30 } +end diff --git a/Fortran/gfortran/regression/do_check_6.f90 b/Fortran/gfortran/regression/do_check_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_check_6.f90 @@ -0,0 +1,84 @@ +! { dg-do compile } +! +! PR fortran/54958 +! +module m + integer, protected :: i + integer :: j +end module m + +subroutine test1() + use m + implicit none + integer :: A(5) + ! Valid: data-implied-do (has a scope of the statement or construct) + DATA (A(i), i=1,5)/5*42/ ! OK + + ! Valid: ac-implied-do (has a scope of the statement or construct) + print *, [(i, i=1,5 )] ! OK + + ! Valid: index-name (has a scope of the statement or construct) + forall (i = 1:5) ! OK + end forall + + ! Valid: index-name (has a scope of the statement or construct) + do concurrent (i = 1:5) ! OK + end do + + ! Invalid: io-implied-do + print *, (i, i=1,5 ) ! { dg-error "PROTECTED and cannot appear in a variable definition context .iterator variable." } + + ! Invalid: do-variable in a do-stmt + do i = 1, 5 ! { dg-error "PROTECTED and cannot appear in a variable definition context .iterator variable." } + end do +end subroutine test1 + +subroutine test2(i) + implicit none + integer, intent(in) :: i + integer :: A(5) + ! Valid: data-implied-do (has a scope of the statement or construct) + DATA (A(i), i=1,5)/5*42/ ! OK + + ! Valid: ac-implied-do (has a scope of the statement or construct) + print *, [(i, i=1,5 )] ! OK + + ! Valid: index-name (has a scope of the statement or construct) + forall (i = 1:5) ! OK + end forall + + ! Valid: index-name (has a scope of the statement or construct) + do concurrent (i = 1:5) ! OK + end do + + ! Invalid: io-implied-do + print *, (i, i=1,5 ) ! { dg-error "INTENT.IN. in variable definition context .iterator variable." } + + ! Invalid: do-variable in a do-stmt + do i = 1, 5 ! { dg-error "INTENT.IN. in variable definition context .iterator variable." } + end do +end subroutine test2 + +pure subroutine test3() + use m + implicit none + integer :: A(5) + !DATA (A(j), j=1,5)/5*42/ ! Not allowed in pure + + ! Valid: ac-implied-do (has a scope of the statement or construct) + A = [(j, j=1,5 )] ! OK + + ! Valid: index-name (has a scope of the statement or construct) + forall (j = 1:5) ! OK + end forall + + ! Valid: index-name (has a scope of the statement or construct) + do concurrent (j = 1:5) ! OK + end do + + ! print *, (j, j=1,5 ) ! I/O not allowed in PURE + + ! Invalid: do-variable in a do-stmt + do j = 1, 5 ! { dg-error "variable definition context .iterator variable. at .1. in PURE procedure" } + end do +end subroutine test3 diff --git a/Fortran/gfortran/regression/do_check_7.f90 b/Fortran/gfortran/regression/do_check_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_check_7.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! PR 30146 - warn about DO variables as argument to INTENT(IN) and +! INTENT(INOUT) dummy arguments +program main + implicit none + integer :: i,j, k, l + do k=1,2 ! { dg-error "undefined value" } + do i=1,10 ! { dg-error "definable" } + do j=1,10 ! { dg-error "undefined value" } + do l=1,10 ! { dg-error "definable" } + call s_out(k) ! { dg-error "undefined" } + call s_inout(i) ! { dg-error "definable" } + print *,f_out(j) ! { dg-error "undefined" } + print *,f_inout(l) ! { dg-error "definable" } + end do + end do + end do + end do +contains + subroutine s_out(i_arg) + integer, intent(out) :: i_arg + end subroutine s_out + + subroutine s_inout(i_arg) + integer, intent(inout) :: i_arg + end subroutine s_inout + + function f_out(i_arg) + integer, intent(out) :: i_arg + integer :: f_out + f_out = i_arg + end function f_out + + function f_inout(i_arg) + integer, intent(inout) :: i_arg + integer :: f_inout + f_inout = i_arg + end function f_inout + +end program main diff --git a/Fortran/gfortran/regression/do_check_8.f90 b/Fortran/gfortran/regression/do_check_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_check_8.f90 @@ -0,0 +1,58 @@ +! { dg-do compile } +! PR 55593 - bogus error with generic subroutines +module foo + implicit none + interface sub + subroutine sub2(i) + integer, intent(in) :: i + end subroutine sub2 + subroutine sub(i) + integer, dimension(:), intent(out) :: i + end subroutine sub + end interface sub + + interface tub2 + subroutine tub2(i) + integer, intent(in) :: i + end subroutine tub2 + subroutine tub(i) + integer, dimension(:), intent(out) :: i + end subroutine tub + end interface tub2 + + interface func + integer function ifunc(i) + integer, intent(in) :: i + end function ifunc + integer function func(i) + integer, intent(in) :: i(:) + end function func + end interface func + + interface igunc + integer function igunc(i) + integer, intent(in) :: i + end function igunc + integer function gunc(i) + integer, intent(in) :: i(:) + end function gunc + end interface igunc +end module foo + +program main + use foo + implicit none + integer :: i + do i=1,10 + call sub(i) + call tub2(i) + end do + do i=1,10 + print *,func(i) + print *,igunc(i) + end do + + do undeclared=1,10 ! { dg-error "has no IMPLICIT type" } + call sub(undeclared) + end do +end program main diff --git a/Fortran/gfortran/regression/do_check_9.f90 b/Fortran/gfortran/regression/do_check_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_check_9.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! PR fortran/50554 +! +! Contributed by Vittorio Zecca +! +! INQUIRE cannot redefine DO index +! + do I=1,10 ! { dg-error "cannot be redefined inside loop beginning at" } + inquire(iolength=I) n ! { dg-error "cannot be redefined inside loop beginning at" } + inquire(99,size=I) ! { dg-error "cannot be redefined inside loop beginning at" } + read(99,'(i4)',size=I,advance="no") n ! { dg-error "cannot be redefined inside loop beginning at" } + end do + end diff --git a/Fortran/gfortran/regression/do_concurrent_1.f90 b/Fortran/gfortran/regression/do_concurrent_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_concurrent_1.f90 @@ -0,0 +1,71 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/44646 +! +! DO CONCURRENT +! +implicit none +integer :: i, j + +outer: do, concurrent ( i = 1 : 4) + do j = 1, 5 + if (j == 1) cycle ! OK + cycle outer ! OK: C821 FIXME + exit outer ! { dg-error "EXIT statement at .1. leaves DO CONCURRENT construct" } + end do +end do outer + +do concurrent (j = 1:5) + cycle ! OK +end do + +outer2: do j = 1, 7 + do concurrent (j=1:5:2) ! cycle outer2 - bad: C821 + cycle outer2 ! { dg-error "leaves DO CONCURRENT construct" } + end do +end do outer2 + +do concurrent ( i = 1 : 4) + exit ! { dg-error "EXIT statement at .1. leaves DO CONCURRENT construct" } +end do +end + +subroutine foo() + do concurrent ( i = 1 : 4) + return ! { dg-error "Image control statement RETURN" } + sync all ! { dg-error "Image control statement SYNC" } + call test () ! { dg-error "Subroutine call to .test. in DO CONCURRENT block at .1. is not PURE" } + stop ! { dg-error "Image control statement STOP" } + end do + do concurrent ( i = 1 : 4) + critical ! { dg-error "Image control statement CRITICAL at .1. in DO CONCURRENT block" } + print *, i +! end critical + end do + + critical + do concurrent ( i = 1 : 4) ! OK + end do + end critical +end + +subroutine caf() + use iso_fortran_env + implicit none + type(lock_type), allocatable :: lock[:] + integer :: i + do, concurrent (i = 1:3) + allocate (lock[*]) ! { dg-error "ALLOCATE of coarray at .1. in DO CONCURRENT block" } + lock(lock) ! { dg-error "Image control statement LOCK" } + unlock(lock) ! { dg-error "Image control statement UNLOCK" } + deallocate (lock) ! { dg-error "DEALLOCATE of coarray at .1. in DO CONCURRENT block" } + end do + + critical + allocate (lock[*]) ! { dg-error "ALLOCATE of coarray at .1. in CRITICAL block" } + lock(lock) ! { dg-error "Image control statement LOCK" } + unlock(lock) ! { dg-error "Image control statement UNLOCK" } + deallocate (lock) ! { dg-error "DEALLOCATE of coarray at .1. in CRITICAL block" } + end critical +end subroutine caf diff --git a/Fortran/gfortran/regression/do_concurrent_2.f90 b/Fortran/gfortran/regression/do_concurrent_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_concurrent_2.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! +! PR fortran/44646 +! +! DO CONCURRENT +! +implicit none +integer :: i, j +integer :: A(5,5) + +A = 0.0 +do concurrent (i=1:5, j=1:5, (i/=j)) + if (i == 5) cycle + A(i,j) = i*j +end do + +if (any (A(:,1) /= [0, 2, 3, 4, 0])) STOP 1 +if (any (A(:,2) /= [2, 0, 6, 8, 0])) STOP 2 +if (any (A(:,3) /= [3, 6, 0, 12, 0])) STOP 3 +if (any (A(:,4) /= [4, 8, 12, 0, 0])) STOP 4 +if (any (A(:,5) /= [5, 10, 15, 20, 0])) STOP 5 + +A = -99 + +do concurrent (i = 1 : 5) + forall (j=1:4, i/=j) + A(i,j) = i*j + end forall + if (i == 5) then + A(i,i) = -i + end if +end do + +if (any (A(:,1) /= [-99, 2, 3, 4, 5])) STOP 6 +if (any (A(:,2) /= [ 2, -99, 6, 8, 10])) STOP 7 +if (any (A(:,3) /= [ 3, 6, -99, 12, 15])) STOP 8 +if (any (A(:,4) /= [ 4, 8, 12, -99, 20])) STOP 9 +if (any (A(:,5) /= [-99, -99, -99, -99, -5])) STOP 10 + +end diff --git a/Fortran/gfortran/regression/do_concurrent_3.f90 b/Fortran/gfortran/regression/do_concurrent_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_concurrent_3.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR 56519 - flag impure intrinsic subroutine calls +! within DO CONCURRENT +program main + implicit none + integer :: i + real :: array(123), val + + do concurrent (i = 1:123) + call random_number (val) ! { dg-error "is not PURE" } + array(i) = val + end do +end program main diff --git a/Fortran/gfortran/regression/do_concurrent_4.f90 b/Fortran/gfortran/regression/do_concurrent_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_concurrent_4.f90 @@ -0,0 +1,67 @@ +! { dg-do run } +! { dg-options "-O" } +! PR 80304 - this used to give a wrong result. +! Original test case by Chinoune +module test_mod + implicit none + +contains + + pure real function add(i,j,k) + integer ,intent(in) :: i,j,k + add = real(i+j+k)+1. + end function add + + pure real function add2(i,j,k) + integer ,intent(in) :: i,j,k + add2 = real(i+j+k) + end function add2 + + subroutine check_err(a, s) + real, dimension(:,:), intent(in) :: a + real, intent(in) :: s + if (abs(sum(a) - s) > 1e-5) STOP 1 + end subroutine check_err + +end module test_mod + +program test + use test_mod + implicit none + + integer :: i ,j + real :: a(0:1,0:1) ,b(0:1,0:1) + + ! first do-concurrent loop + a = 0. + b = 0. + DO CONCURRENT( i=0:1 ,j=0:1) + a(i,j) = add(i,j,abs(i-j)) + b(i,j) = add2(i,j,abs(i-j)) + END DO + call check_err (a, 10.) + call check_err (b, 6.) + + ! normal do loop + a = 0. + b = 0. + DO i=0,1 + DO j=0,1 + a(i,j) = add(i,j,abs(i-j)) + b(i,j) = add2(i,j,abs(i-j)) + END DO + END DO + call check_err (a, 10.) + call check_err (b, 6.) + + ! second do-concuurent loop + a = 0. + b = 0. + DO CONCURRENT( i=0:1 ,j=0:1) + a(i,j) = add(i,j,abs(i-j)) + b(i,j) = add2(i,j,abs(i-j)) + END DO + call check_err (a, 10.) + call check_err (b, 6.) + +end program test diff --git a/Fortran/gfortran/regression/do_concurrent_6.f90 b/Fortran/gfortran/regression/do_concurrent_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_concurrent_6.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } + +program main + real, dimension(100) :: a,b + call random_number(a) + do concurrent (i=1:100) + b(i) = a(i)*a(i) + end do + print *,sum(a) +end program main + +! { dg-final { scan-tree-dump-times "ivdep" 1 "original" } } diff --git a/Fortran/gfortran/regression/do_corner_warn.f90 b/Fortran/gfortran/regression/do_corner_warn.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_corner_warn.f90 @@ -0,0 +1,22 @@ +! { dg-options "-Wundefined-do-loop" } +! Program to check corner cases for DO statements. + +program do_1 + implicit none + integer i, j + + ! limit=HUGE(i), step 1 + j = 0 + do i = HUGE(i) - 10, HUGE(i), 1 ! { dg-warning "is undefined as it overflows" } + j = j + 1 + end do + if (j .ne. 11) STOP 1 + + ! limit=-HUGE(i)-1, step -1 + j = 0 + do i = -HUGE(i) + 10 - 1, -HUGE(i) - 1, -1 ! { dg-warning "is undefined as it underflows" } + j = j + 1 + end do + if (j .ne. 11) STOP 2 + +end program diff --git a/Fortran/gfortran/regression/do_iterator.f90 b/Fortran/gfortran/regression/do_iterator.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_iterator.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! various checks which verify that we don't change do-iterators +DO I=1,5 ! { dg-error "cannot be redefined" "changing do-iterator 1" } + I=1 ! { dg-error "cannot be redefined" "changing do-iterator 1" } +END DO +DO I=1,5 ! { dg-error "cannot be redefined" "changing do-iterator 2" } + READ(5,*) I ! { dg-error "cannot be redefined" "changing do-iterator 2" } +END DO +DO I=1,5 ! { dg-error "cannot be redefined" "changing do-iterator 3" } + READ(5,*,iostat=i) j ! { dg-error "cannot be redefined" "changing do-iterator 3" } +ENDDO +END diff --git a/Fortran/gfortran/regression/do_iterator_2.f90 b/Fortran/gfortran/regression/do_iterator_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_iterator_2.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! Tests the fix for pr32613 - see: +! http://groups.google.com/group/comp.lang.fortran/browse_thread/thread/495c154ee188d7f1/ea292134fe68b1d0#ea292134fe68b1d0 +! +! Contributed by Al Greynolds +! +program main + call something +end + +subroutine something +! integer i !correct results from gfortran depend on this statement (before fix) + integer :: m = 0 + character lit*1, line*100 + lit(i) = line(i:i) + i = 1 + n = 5 + line = 'PZ0R1' + if (internal (1)) STOP 1 + if (m .ne. 4) STOP 2 +contains + logical function internal (j) + intent(in) j + do i = j, n + k = index ('RE', lit (i)) + m = m + 1 + if (k == 0) cycle + if (i + 1 == n) exit + enddo + internal = (k == 0) + end function +end diff --git a/Fortran/gfortran/regression/do_pointer_1.f90 b/Fortran/gfortran/regression/do_pointer_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_pointer_1.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR 30869 - pointer loop variables were wrongly rejected. +program main + integer, pointer :: i + allocate (i) + do i=1,10 + end do + deallocate (i) +end program main diff --git a/Fortran/gfortran/regression/do_subscript_1.f90 b/Fortran/gfortran/regression/do_subscript_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_subscript_1.f90 @@ -0,0 +1,57 @@ +! { dg-do compile } +program main + real, dimension(3) :: a + a = 42. + do i=-1,3,2 ! { dg-warning "out of bounds" } + a(i) = 0 ! { dg-warning "out of bounds \\(-1 < 1\\)" } + end do + do i=4,1,-1 ! { dg-warning "out of bounds" } + a(i) = 22 ! { dg-warning "out of bounds \\(4 > 3\\)" } + end do + do i=1,4 ! { dg-warning "out of bounds" } + a(i) = 32 ! { dg-warning "out of bounds \\(4 > 3\\)" } + end do + do i=3,0,-1 ! { dg-warning "out of bounds" } + a(i) = 12 ! { dg-warning "out of bounds \\(0 < 1\\)" } + end do + do i=-1,3 + if (i>0) a(i) = a(i) + 1 ! No warning inside if + end do + do i=-1,4 + select case(i) + case(1:3) + a(i) = -234 ! No warning inside select case + end select + end do + do i=1,3 ! { dg-warning "out of bounds" } + a(i+1) = a(i) ! { dg-warning "out of bounds \\(4 > 3\\)" } + a(i-1) = a(i) ! { dg-warning "out of bounds \\(0 < 1\\)" } + end do + do i=3,1,-1 ! { dg-warning "out of bounds" } + a(i) = a(i-1) ! { dg-warning "out of bounds \\(0 < 1\\)" } + a(i) = a(i+1) ! { dg-warning "out of bounds \\(4 > 3\\)" } + end do + do i=1,2 ! { dg-warning "out of bounds" } + a(i) = a(i*i) ! { dg-warning "out of bounds \\(4 > 3\\)" } + end do + do i=1,4,2 + a(i) = a(i)*2 ! No error + end do + do i=1,4 + if (i > 3) exit + a(i) = 33 + end do + do i=0,3 ! { dg-warning "out of bounds \\(0 < 1\\)" } + a(i) = 13. ! { dg-warning "out of bounds \\(0 < 1\\)" } + if (i < 1) exit + end do + do i=0,3 + if (i < 1) cycle + a(i) = -21. + end do + do i=0,3 ! { dg-warning "out of bounds \\(0 < 1\\)" } + do j=1,2 + a(i) = -123 ! { dg-warning "out of bounds \\(0 < 1\\)" } + end do + end do +end program main diff --git a/Fortran/gfortran/regression/do_subscript_2.f90 b/Fortran/gfortran/regression/do_subscript_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_subscript_2.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-additional-options "-Wdo-subscript" } +program main + real, dimension(3) :: a + a = 42. + do i=-1,3 ! { dg-warning "out of bounds \\(-1 < 1\\)" } + select case(i) + case(1:3) + a(i) = -234 ! { dg-warning "out of bounds \\(-1 < 1\\)" } + end select + end do + do i=1,4,2 + a(i) = a(i)*2 ! No warning - end value is 3 + end do + do i=1,4 ! { dg-warning "out of bounds \\(4 > 3\\)" } + if (i > 3) exit + a(i) = 33 ! { dg-warning "out of bounds \\(4 > 3\\)" } + end do + do i=0,3 ! { dg-warning "out of bounds \\(0 < 1\\)" } + if (i < 1) cycle + a(i) = -21. ! { dg-warning "out of bounds \\(0 < 1\\)" } + end do +end program main diff --git a/Fortran/gfortran/regression/do_subscript_3.f90 b/Fortran/gfortran/regression/do_subscript_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_subscript_3.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-O0" } +! PR fortran/91424 +! Check that only one warning is issued inside blocks, and that +! warnings are also issued for contained subroutines. + +program main + real :: a(5) + block + integer :: j + do j=0, 5 ! { dg-warning "out of bounds" } + a(j) = 2. ! { dg-warning "out of bounds" } + end do + end block + call x +contains + subroutine x + integer :: i + do i=1,6 ! { dg-warning "out of bounds" } + a(i) = 2. ! { dg-warning "out of bounds" } + end do + end subroutine x +end program main diff --git a/Fortran/gfortran/regression/do_subscript_4.f90 b/Fortran/gfortran/regression/do_subscript_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_subscript_4.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR 91424 - this used to warn although the DO loop is zero trip. +program main + implicit none + integer :: i + real :: a(2) + do i=1,3,-1 + a(i) = 2. + end do + print *,a +end program main diff --git a/Fortran/gfortran/regression/do_subscript_5.f90 b/Fortran/gfortran/regression/do_subscript_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_subscript_5.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-additional-options "-Wdo-subscript" } +! PR 90563 - this used to be rejected, wrongly +! Original test case by Tobias Neumann +program test + implicit none + integer, parameter :: swap(4) = [2,1,3,4] + real :: p(20) + integer :: j + + p = 0.0 + + ! The following warnings are actually bogus, but we are not yet + ! clever enough to suppress them. + do j=1,6 ! { dg-warning "out of bounds" } + if (j<5) then + p(j) = p(swap(j)) ! { dg-warning "out of bounds" } + endif + enddo +end program diff --git a/Fortran/gfortran/regression/do_subscript_6.f90 b/Fortran/gfortran/regression/do_subscript_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_subscript_6.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! PR 91550 - this used to cause an ICE +! Test case by Gerhard Steinmetz +program p + real :: a(3) + integer :: i + do i = 1, 3, .1 ! { dg-error "cannot be zero" } + a(i) = i + end do +end diff --git a/Fortran/gfortran/regression/do_while_1.f90 b/Fortran/gfortran/regression/do_while_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/do_while_1.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! PR 50327 - this used to cause an endless loop because +! of wrong fron-end optimization. +program main + real :: tmp + tmp = 0. + do while (abs(tmp) < 10. .and. abs(tmp) < 20.) + tmp = tmp + 1. + end do +end program main diff --git a/Fortran/gfortran/regression/dollar_edit_descriptor_1.f b/Fortran/gfortran/regression/dollar_edit_descriptor_1.f --- /dev/null +++ b/Fortran/gfortran/regression/dollar_edit_descriptor_1.f @@ -0,0 +1,13 @@ +! { dg-do run } +! { dg-options "-w" } +! PR libfortran/20006 + character*5 c + open (42,status='scratch') + write (42,'(A,$)') 'abc' + write (42,'(A)') 'de' + rewind (42) + read (42,'(A)') c + close (42) + + if (c /= 'abcde') STOP 1 + end diff --git a/Fortran/gfortran/regression/dollar_edit_descriptor_2.f b/Fortran/gfortran/regression/dollar_edit_descriptor_2.f --- /dev/null +++ b/Fortran/gfortran/regression/dollar_edit_descriptor_2.f @@ -0,0 +1,9 @@ +! { dg-do run } +! { dg-options "-w" } +! PR25545 internal file and dollar edit descriptor. + program main + character*20 line + line = '1234567890ABCDEFGHIJ' + write (line, '(A$)') 'asdf' + if (line.ne.'asdf') STOP 1 + end diff --git a/Fortran/gfortran/regression/dollar_edit_descriptor_3.f b/Fortran/gfortran/regression/dollar_edit_descriptor_3.f --- /dev/null +++ b/Fortran/gfortran/regression/dollar_edit_descriptor_3.f @@ -0,0 +1,8 @@ +! { dg-do run } +! { dg-options "-std=gnu" } +! Test for dollar descriptor in the middle of a format +300 format(1000(a,$)) ! { dg-warning "should be the last specifier" } + write(*,300) "gee", "gee" + write(*,"(1000(a,$))") "foo", "bar" ! { dg-warning "should be the last specifier" } + end +! { dg-output "^geegeefoobar$" } diff --git a/Fortran/gfortran/regression/dollar_edit_descriptor_4.f b/Fortran/gfortran/regression/dollar_edit_descriptor_4.f --- /dev/null +++ b/Fortran/gfortran/regression/dollar_edit_descriptor_4.f @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-std=gnu" } +! PR98825 Test for fix of '$' edit descriptor. + character(30) :: line + 10 format (i3,$) + + open(10, status='scratch') + write (10,10) 1 + write (10,10) 2,3,4,5 +! Check the result. + line = 'abcdefg' + rewind(10) + read(10, '(a)') line + close(10) + if (line .ne. ' 1 2 3 4 5') call abort + end diff --git a/Fortran/gfortran/regression/dollar_sym_1.f90 b/Fortran/gfortran/regression/dollar_sym_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dollar_sym_1.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/34997 +! Variable names containing $ signs +! + REAL*4 PLT$C_HOUSTPIX ! { dg-error "Invalid character '\\$'" } + INTEGER PLT$C_COMMAND ! Unreachable as the error above is now fatal + PARAMETER (PLT$B_OPC=0) ! Unreachable as the error above is now fatal + common /abc$def/ PLT$C_HOUSTPIX, PLT$C_COMMAND ! Unreachable as the error above is now fatal + end +! { dg-prune-output "compilation terminated" } diff --git a/Fortran/gfortran/regression/dollar_sym_2.f90 b/Fortran/gfortran/regression/dollar_sym_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dollar_sym_2.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-fdollar-ok" } +! +! PR fortran/34997 +! Variable names containing $ signs +! + REAL*4 PLT$C_HOUSTPIX + INTEGER PLT$C_COMMAND + PARAMETER (PLT$B_OPC=0) + common /abc$def/ PLT$C_HOUSTPIX, PLT$C_COMMAND + end diff --git a/Fortran/gfortran/regression/dollar_sym_3.f b/Fortran/gfortran/regression/dollar_sym_3.f --- /dev/null +++ b/Fortran/gfortran/regression/dollar_sym_3.f @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! PR fortran/57895 +! +! Contributed by Vittorio Zecca +! +c Segmentation fault in gfc_restore_last_undo_checkpoint + COMMON RADE3155V62$JUTMU9L9E(3,3,3), LADE314JUTMP9 ! { dg-error "Invalid character '\\$' at .1.. Use '-fdollar-ok' to allow it as an extension" } + +LHEDDJNTMP9L(3,3,3) + end +! { dg-prune-output "compilation terminated" } diff --git a/Fortran/gfortran/regression/dos_eol.f b/Fortran/gfortran/regression/dos_eol.f --- /dev/null +++ b/Fortran/gfortran/regression/dos_eol.f @@ -0,0 +1,19 @@ +! PR libfortran/19678 and PR libfortran/19679 +! { dg-do run } + integer i, j + + open (10,status='scratch') + write (10,'(2A)') '1', achar(13) + rewind (10) + read (10,*) i + if (i .ne. 1) STOP 1 + close (10) + + open (10,status='scratch') + write (10,'(2A)') ' 1', achar(13) + write (10,'(2A)') ' 2', achar(13) + rewind (10) + read (10,'(I4)') i + read (10,'(I5)') j + if ((i .ne. 1) .or. (j .ne. 2)) STOP 2 + end diff --git a/Fortran/gfortran/regression/dot_product_1.f03 b/Fortran/gfortran/regression/dot_product_1.f03 --- /dev/null +++ b/Fortran/gfortran/regression/dot_product_1.f03 @@ -0,0 +1,11 @@ +! { dg-do run } +! Transformational intrinsic DOT_PRODUCT as initialization expression. + + INTEGER, PARAMETER :: n = 10 + INTEGER, PARAMETER :: a(n) = 1 + INTEGER, PARAMETER :: p = DOT_PRODUCT(a, a) + INTEGER, PARAMETER :: e = DOT_PRODUCT(SHAPE(1), SHAPE(1)) + + IF (p /= n) STOP 1 + IF (e /= 0) STOP 2 +END diff --git a/Fortran/gfortran/regression/dot_product_2.f90 b/Fortran/gfortran/regression/dot_product_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dot_product_2.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/57785 +! +! Contributed by Kontantinos Anagnostopoulos +! +! The implicit complex conjugate was missing for DOT_PRODUCT + + +! For the following, the compile-time simplification fails for SUM; +! see PR fortran/56342. Hence, a manually expanded SUM is used. + +!if (DOT_PRODUCT ((/ (1.0, 2.0), (2.0, 3.0) /), (/ (1.0, 1.0), (1.0, 4.0) /)) & +! /= SUM (CONJG ((/ (1.0, 2.0), (2.0, 3.0) /))*(/ (1.0, 1.0), (1.0, 4.0) /))) & +! STOP 1 +! +!if (ANY (MATMUL ((/ (1.0, 2.0), (2.0, 3.0) /), & +! RESHAPE ((/ (1.0, 1.0), (1.0, 4.0) /),(/2, 1/))) /= & +! SUM ((/ (1.0, 2.0), (2.0, 3.0) /)*(/ (1.0, 1.0), (1.0, 4.0) /)))) & +! STOP 2 + + +if (DOT_PRODUCT ((/ (1.0, 2.0), (2.0, 3.0) /), (/ (1.0, 1.0), (1.0, 4.0) /)) & + /= CONJG (cmplx(1.0, 2.0)) * cmplx(1.0, 1.0) & + + CONJG (cmplx(2.0, 3.0)) * cmplx(1.0, 4.0)) & + STOP 3 + +if (ANY (MATMUL ((/ (1.0, 2.0), (2.0, 3.0) /), & + RESHAPE ((/ (1.0, 1.0), (1.0, 4.0) /),(/2, 1/))) & + /= cmplx(1.0, 2.0) * cmplx(1.0, 1.0) & + + cmplx(2.0, 3.0) * cmplx(1.0, 4.0))) & + STOP 4 +end + + +! { dg-final { scan-tree-dump-not "_gfortran_stop" "original" } } diff --git a/Fortran/gfortran/regression/dot_product_3.f90 b/Fortran/gfortran/regression/dot_product_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dot_product_3.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! PR 61999 - this used to ICE. +! Original test case by A. Kasahara +program main + use, intrinsic:: iso_fortran_env, only: output_unit + + implicit none + + write(output_unit, *) dot_product([1, 2], [2.0, 3.0]) + + stop +end program main +! { dg-final { scan-tree-dump-times "8\\.0e\\+0" 1 "original" } } diff --git a/Fortran/gfortran/regression/dot_product_4.f90 b/Fortran/gfortran/regression/dot_product_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dot_product_4.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! PR fortran/83998 +program p + integer, parameter :: a(0) = 1 + real, parameter :: b(0) = 1 + complex, parameter :: c(0) = 1 + logical, parameter :: d(0) = .true. + if (dot_product(a,a) /= 0) STOP 1 + if (dot_product(b,b) /= 0) STOP 2 + if (dot_product(c,c) /= 0) STOP 3 + if (dot_product(d,d) .neqv. .false.) STOP 4 +end + diff --git a/Fortran/gfortran/regression/double_complex_1.f90 b/Fortran/gfortran/regression/double_complex_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/double_complex_1.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "--std=f95" } +! PR18565 +! As we provide "double complex" versions of certain intrinsics an extension. +! However --std=f95 was also breaking the generic versions, which should work +! on any type kind. +program prog + complex(kind=kind(0d0)) :: c + print *, abs(c) + print *, aimag(c) + print *, conjg(c) + print *, cos(c) + print *, exp(c) + print *, log(c) + print *, sin(c) + print *, sqrt(c) +end program + diff --git a/Fortran/gfortran/regression/dshift_1.F90 b/Fortran/gfortran/regression/dshift_1.F90 --- /dev/null +++ b/Fortran/gfortran/regression/dshift_1.F90 @@ -0,0 +1,177 @@ +! Test the DSHIFTL and DSHIFTR intrinsics. +! +! { dg-do run } +! { dg-options "-ffree-line-length-none" } + + implicit none + + interface run_dshiftl + procedure dshiftl_1 + procedure dshiftl_2 + procedure dshiftl_4 + procedure dshiftl_8 + end interface + interface run_dshiftr + procedure dshiftr_1 + procedure dshiftr_2 + procedure dshiftr_4 + procedure dshiftr_8 + end interface + +#define RESL(I,J,SHIFT) \ + IOR(SHIFTL(I,SHIFT),SHIFTR(J,BIT_SIZE(J)-SHIFT)) +#define RESR(I,J,SHIFT) \ + IOR(SHIFTL(I,BIT_SIZE(I)-SHIFT),SHIFTR(J,SHIFT)) + +#define CHECK(I,J,SHIFT) \ + if (dshiftl(I,J,SHIFT) /= RESL(I,J,SHIFT)) STOP 1; \ + if (dshiftr(I,J,SHIFT) /= RESR(I,J,SHIFT)) STOP 2; \ + if (run_dshiftl(I,J,SHIFT) /= RESL(I,J,SHIFT)) STOP 3; \ + if (run_dshiftr(I,J,SHIFT) /= RESR(I,J,SHIFT)) STOP 4 + + CHECK(0_1,0_1,0) + CHECK(0_1,0_1,1) + CHECK(0_1,0_1,7) + CHECK(0_1,0_1,8) + CHECK(28_1,79_1,0) + CHECK(28_1,79_1,1) + CHECK(28_1,79_1,5) + CHECK(28_1,79_1,7) + CHECK(28_1,79_1,8) + CHECK(-28_1,79_1,0) + CHECK(-28_1,79_1,1) + CHECK(-28_1,79_1,5) + CHECK(-28_1,79_1,7) + CHECK(-28_1,79_1,8) + CHECK(28_1,-79_1,0) + CHECK(28_1,-79_1,1) + CHECK(28_1,-79_1,5) + CHECK(28_1,-79_1,7) + CHECK(28_1,-79_1,8) + CHECK(-28_1,-79_1,0) + CHECK(-28_1,-79_1,1) + CHECK(-28_1,-79_1,5) + CHECK(-28_1,-79_1,7) + CHECK(-28_1,-79_1,8) + + CHECK(0_2,0_2,0) + CHECK(0_2,0_2,1) + CHECK(0_2,0_2,7) + CHECK(0_2,0_2,8) + CHECK(28_2,79_2,0) + CHECK(28_2,79_2,1) + CHECK(28_2,79_2,5) + CHECK(28_2,79_2,7) + CHECK(28_2,79_2,8) + CHECK(-28_2,79_2,0) + CHECK(-28_2,79_2,1) + CHECK(-28_2,79_2,5) + CHECK(-28_2,79_2,7) + CHECK(-28_2,79_2,8) + CHECK(28_2,-79_2,0) + CHECK(28_2,-79_2,1) + CHECK(28_2,-79_2,5) + CHECK(28_2,-79_2,7) + CHECK(28_2,-79_2,8) + CHECK(-28_2,-79_2,0) + CHECK(-28_2,-79_2,1) + CHECK(-28_2,-79_2,5) + CHECK(-28_2,-79_2,7) + CHECK(-28_2,-79_2,8) + + CHECK(0_4,0_4,0) + CHECK(0_4,0_4,1) + CHECK(0_4,0_4,7) + CHECK(0_4,0_4,8) + CHECK(28_4,79_4,0) + CHECK(28_4,79_4,1) + CHECK(28_4,79_4,5) + CHECK(28_4,79_4,7) + CHECK(28_4,79_4,8) + CHECK(-28_4,79_4,0) + CHECK(-28_4,79_4,1) + CHECK(-28_4,79_4,5) + CHECK(-28_4,79_4,7) + CHECK(-28_4,79_4,8) + CHECK(28_4,-79_4,0) + CHECK(28_4,-79_4,1) + CHECK(28_4,-79_4,5) + CHECK(28_4,-79_4,7) + CHECK(28_4,-79_4,8) + CHECK(-28_4,-79_4,0) + CHECK(-28_4,-79_4,1) + CHECK(-28_4,-79_4,5) + CHECK(-28_4,-79_4,7) + CHECK(-28_4,-79_4,8) + + CHECK(0_8,0_8,0) + CHECK(0_8,0_8,1) + CHECK(0_8,0_8,7) + CHECK(0_8,0_8,8) + CHECK(28_8,79_8,0) + CHECK(28_8,79_8,1) + CHECK(28_8,79_8,5) + CHECK(28_8,79_8,7) + CHECK(28_8,79_8,8) + CHECK(-28_8,79_8,0) + CHECK(-28_8,79_8,1) + CHECK(-28_8,79_8,5) + CHECK(-28_8,79_8,7) + CHECK(-28_8,79_8,8) + CHECK(28_8,-79_8,0) + CHECK(28_8,-79_8,1) + CHECK(28_8,-79_8,5) + CHECK(28_8,-79_8,7) + CHECK(28_8,-79_8,8) + CHECK(-28_8,-79_8,0) + CHECK(-28_8,-79_8,1) + CHECK(-28_8,-79_8,5) + CHECK(-28_8,-79_8,7) + CHECK(-28_8,-79_8,8) + + +contains + + function dshiftl_1 (i, j, shift) result(res) + integer(kind=1) :: i, j, res + integer :: shift + res = dshiftl(i,j,shift) + end function + function dshiftl_2 (i, j, shift) result(res) + integer(kind=2) :: i, j, res + integer :: shift + res = dshiftl(i,j,shift) + end function + function dshiftl_4 (i, j, shift) result(res) + integer(kind=4) :: i, j, res + integer :: shift + res = dshiftl(i,j,shift) + end function + function dshiftl_8 (i, j, shift) result(res) + integer(kind=8) :: i, j, res + integer :: shift + res = dshiftl(i,j,shift) + end function + + function dshiftr_1 (i, j, shift) result(res) + integer(kind=1) :: i, j, res + integer :: shift + res = dshiftr(i,j,shift) + end function + function dshiftr_2 (i, j, shift) result(res) + integer(kind=2) :: i, j, res + integer :: shift + res = dshiftr(i,j,shift) + end function + function dshiftr_4 (i, j, shift) result(res) + integer(kind=4) :: i, j, res + integer :: shift + res = dshiftr(i,j,shift) + end function + function dshiftr_8 (i, j, shift) result(res) + integer(kind=8) :: i, j, res + integer :: shift + res = dshiftr(i,j,shift) + end function + +end diff --git a/Fortran/gfortran/regression/dshift_2.F90 b/Fortran/gfortran/regression/dshift_2.F90 --- /dev/null +++ b/Fortran/gfortran/regression/dshift_2.F90 @@ -0,0 +1,59 @@ +! Test the DSHIFTL and DSHIFTR intrinsics. +! +! { dg-do run } +! { dg-options "-ffree-line-length-none" } +! { dg-require-effective-target fortran_integer_16 } + + implicit none + +#define RESL(I,J,SHIFT) \ + IOR(SHIFTL(I,SHIFT),SHIFTR(J,BIT_SIZE(J)-SHIFT)) +#define RESR(I,J,SHIFT) \ + IOR(SHIFTL(I,BIT_SIZE(I)-SHIFT),SHIFTR(J,SHIFT)) + +#define CHECK(I,J,SHIFT) \ + if (dshiftl(I,J,SHIFT) /= RESL(I,J,SHIFT)) STOP 1; \ + if (dshiftr(I,J,SHIFT) /= RESR(I,J,SHIFT)) STOP 2; \ + if (run_dshiftl(I,J,SHIFT) /= RESL(I,J,SHIFT)) STOP 3; \ + if (run_dshiftr(I,J,SHIFT) /= RESR(I,J,SHIFT)) STOP 4 + + CHECK(0_16,0_16,0) + CHECK(0_16,0_16,1) + CHECK(0_16,0_16,7) + CHECK(0_16,0_16,8) + CHECK(28_16,79_16,0) + CHECK(28_16,79_16,1) + CHECK(28_16,79_16,5) + CHECK(28_16,79_16,7) + CHECK(28_16,79_16,8) + CHECK(-28_16,79_16,0) + CHECK(-28_16,79_16,1) + CHECK(-28_16,79_16,5) + CHECK(-28_16,79_16,7) + CHECK(-28_16,79_16,8) + CHECK(28_16,-79_16,0) + CHECK(28_16,-79_16,1) + CHECK(28_16,-79_16,5) + CHECK(28_16,-79_16,7) + CHECK(28_16,-79_16,8) + CHECK(-28_16,-79_16,0) + CHECK(-28_16,-79_16,1) + CHECK(-28_16,-79_16,5) + CHECK(-28_16,-79_16,7) + CHECK(-28_16,-79_16,8) + +contains + + function run_dshiftl (i, j, shift) result(res) + integer(kind=16) :: i, j, res + integer :: shift + res = dshiftl(i,j,shift) + end function + + function run_dshiftr (i, j, shift) result(res) + integer(kind=16) :: i, j, res + integer :: shift + res = dshiftr(i,j,shift) + end function + +end diff --git a/Fortran/gfortran/regression/dshift_3.f90 b/Fortran/gfortran/regression/dshift_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dshift_3.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! PR fortran/50753 +subroutine foo(i, j, k) + + implicit none + + integer(4), intent(in) :: i, j + integer(8), intent(in) :: k + + print *, dshiftl(i, j, 134) ! { dg-error "must be less than or equal" } + print *, dshiftl(z'FFF', j, 134) ! { dg-error "must be less than or equal" } + print *, dshiftl(i, j, -10) ! { dg-error "must be nonnegative" } + print *, dshiftl(z'FFF', z'EEE', 10) ! { dg-error "cannot both be" } + print *, dshiftl(z'FFF', j, 10) + print *, dshiftl(i, z'EEE', 10) + print *, dshiftl(i, j, 10) + print *, dshiftl(i, k, 10) ! { dg-error "must be the same type and kind" } + print *, dshiftl(k, j, 10) ! { dg-error "must be the same type and kind" } + print *, dshiftl(i, j, k) + + print *, dshiftr(i, j, 134) ! { dg-error "must be less than or equal" } + print *, dshiftr(z'FFF', j, 134) ! { dg-error "must be less than or equal" } + print *, dshiftr(i, j, -10) ! { dg-error "must be nonnegative" } + print *, dshiftr(z'FFF', z'EEE', 10) ! { dg-error "cannot both be" } + print *, dshiftr(z'FFF', j, 10) + print *, dshiftr(i, z'EEE', 10) + print *, dshiftr(i, j, 10) + print *, dshiftr(i, k, 10) ! { dg-error "must be the same type and kind" } + print *, dshiftr(k, j, 10) ! { dg-error "must be the same type and kind" } + print *, dshiftr(i, j, k) + +end subroutine foo diff --git a/Fortran/gfortran/regression/dtio_1.f90 b/Fortran/gfortran/regression/dtio_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_1.f90 @@ -0,0 +1,163 @@ +! { dg-do run { target fd_truncate } } +! +! Functional test of User Defined Derived Type IO, Formatted WRITE/READ +! +! 1) Tests passing of iostat out of the user procedure. +! 2) Tests parsing of the DT optional string and passing in and using +! to control execution. +! 3) Tests parsing of the optional vlist, passing in and using it to +! generate a user defined format string. +! 4) Tests passing an iostat or iomsg out of the libgfortran child +! procedure back to the parent. +! +MODULE p + USE ISO_FORTRAN_ENV + TYPE :: person + CHARACTER (LEN=20) :: name + INTEGER(4) :: age + CONTAINS + procedure :: pwf + procedure :: prf + GENERIC :: WRITE(FORMATTED) => pwf + GENERIC :: READ(FORMATTED) => prf + END TYPE person +CONTAINS + SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg) + CLASS(person), INTENT(IN) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER (LEN=*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: vlist(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + CHARACTER (LEN=30) :: udfmt + INTEGER :: myios + + udfmt='(*(g0))' + iostat=0 + if (iotype.eq."DT") then + if (size(vlist).ne.0) print *, 36 + WRITE(unit, FMT = '(a,5x,i2)', IOSTAT=iostat, advance='no') trim(dtv%name), dtv%age + if (iostat.ne.0) iomsg = "Fail PWF DT" + endif + if (iotype.eq."DTzeroth") then + if (size(vlist).ne.0) print *, 40 + WRITE(unit, FMT = '(g0,g0)', advance='no') dtv%name, dtv%age + if (iostat.ne.0) iomsg = "Fail PWF DTzeroth" + endif + if (iotype.eq."DTtwo") then + if (size(vlist).ne.2) STOP 1 + WRITE(udfmt,'(A,A,I1,A,I1,A)') '(', 'A', vlist(1),',I', vlist(2), ')' + WRITE(unit, FMT='(A8,I2)') dtv%name, dtv%age + if (iostat.ne.0) iomsg = "Fail PWF DTtwo" + endif + if (iotype.eq."DTthree") then + WRITE(udfmt,'(2A,I2,A,I1,A,I2,A)',iostat=myios) '(', 'A', vlist(1),',I', vlist(2), ',F', vlist(3), '.2)' + WRITE(unit, FMT=udfmt, IOSTAT=iostat, advance='no') trim(dtv%name), dtv%age, 3.14 + if (iostat.ne.0) iomsg = "Fail PWF DTthree" + endif + if (iotype.eq."LISTDIRECTED") then + if (size(vlist).ne.0) print *, 55 + WRITE(unit, FMT = *) dtv%name, dtv%age + if (iostat.ne.0) iomsg = "Fail PWF LISTDIRECTED" + endif + if (iotype.eq."NAMELIST") then + if (size(vlist).ne.0) print *, 59 + iostat=6000 + iomsg = "NAMELIST not implemented in pwf" + endif + END SUBROUTINE pwf + + SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg) + CLASS(person), INTENT(INOUT) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER (LEN=*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: vlist(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + CHARACTER (LEN=30) :: udfmt + INTEGER :: myios + real :: areal + udfmt='(*(g0))' + iostat=0 + if (iotype.eq."DT") then + if (size(vlist).ne.0) print *, 36 + READ(unit, FMT = '(a,5x,i2)', IOSTAT=iostat, advance='no') dtv%name, dtv%age + if (iostat.ne.0) iomsg = "Fail PWF DT" + endif + if (iotype.eq."DTzeroth") then + if (size(vlist).ne.0) print *, 40 + READ(unit, FMT = '(a,I2)', advance='no') dtv%name, dtv%age + if (iostat.ne.0) iomsg = "Fail PWF DTzeroth" + endif + if (iotype.eq."DTtwo") then + if (size(vlist).ne.2) STOP 2 + WRITE(udfmt,'(A,A,I1,A,I1,A)') '(', 'A', vlist(1),',I', vlist(2), ')' + READ(unit, FMT='(A8,I2)') dtv%name, dtv%age + if (iostat.ne.0) iomsg = "Fail PWF DTtwo" + endif + if (iotype.eq."DTthree") then + WRITE(udfmt,'(2A,I2,A,I1,A,I2,A)',iostat=myios) '(', 'A', vlist(1),',I', vlist(2), ',F', vlist(3), '.2)' + READ(unit, FMT=udfmt, IOSTAT=iostat, advance='no') dtv%name, dtv%age, areal + if (iostat.ne.0) iomsg = "Fail PWF DTthree" + endif + if (iotype.eq."LISTDIRECTED") then + if (size(vlist).ne.0) print *, 55 + READ(unit, FMT = *) dtv%name, dtv%age + if (iostat.ne.0) iomsg = "Fail PWF LISTDIRECTED" + endif + if (iotype.eq."NAMELIST") then + if (size(vlist).ne.0) print *, 59 + iostat=6000 + iomsg = "NAMELIST not implemented in prf" + endif + END SUBROUTINE prf + +END MODULE p + +PROGRAM test + USE p + TYPE (person), SAVE :: chairman + TYPE (person), SAVE :: member + character(80) :: astring + integer :: thelength + + chairman%name="Charlie" + chairman%age=62 + member%name="George" + member%age=42 + astring = "SUCCESS" + write (10, "(DT'zeroth',3x, DT'three'(11,4,10),11x,DT'two'(8,2))", & + & iostat=myiostat, iomsg=astring) member, chairman, member + if (myiostat.ne.0) STOP 3 + if (astring.ne."SUCCESS") STOP 4 + astring = "SUCCESS" + write (10, *, iostat=myiostat, iomsg=astring) member, chairman, member + if (myiostat.ne.0) STOP 5 + if (astring.ne."SUCCESS") STOP 6 + write(10,*) ! See note below + rewind(10) + chairman%name="bogus1" + chairman%age=99 + member%name="bogus2" + member%age=66 + astring = "SUCCESS" + read(10,"(DT'zeroth',3x, DT'three'(11,4,10),11x,DT'two'(8,2))") member, chairman, member + if (member%name.ne."George") STOP 7 + if (chairman%name.ne." Charlie") STOP 8 + if (member%age.ne.42) STOP 9 + if (chairman%age.ne.62) STOP 10 + chairman%name="bogus1" + chairman%age=99 + member%name="bogus2" + member%age=66 + astring = "SAME" + read (10, *, iostat=myiostat, iomsg=astring) member, chairman, member + ! The user defined procedure reads to the end of the line/file, then finalizing the parent + ! reads past, so we wrote a blank line above. User needs to address these nuances in their + ! procedures. (subject to interpretation) + if (astring.ne."SAME" .or. myiostat.ne.0) STOP 11 + if (member%name.ne."George") STOP 12 + if (chairman%name.ne."Charlie") STOP 13 + if (member%age.ne.42) STOP 14 + if (chairman%age.ne.62) STOP 15 +END PROGRAM test diff --git a/Fortran/gfortran/regression/dtio_10.f90 b/Fortran/gfortran/regression/dtio_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_10.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! +! Tests runtime check of the required type in dtio formatted read. +! +module usertypes + type udt + integer :: myarray(15) + end type udt + type, extends(udt) :: more + integer :: itest = -25 + end type + +end module usertypes + +program test1 + use usertypes + type (udt) :: udt1 + type (more) :: more1 + class (more), allocatable :: somemore + integer :: thesize, i, ios + character(100) :: errormsg + + read (10, fmt='(dt)', advance='no', size=thesize, iostat=ios, & + & iomsg=errormsg) i, udt1 + if (ios.ne.5006) STOP 1 + if (errormsg(27:47).ne."intrinsic type passed") STOP 2 +end program test1 diff --git a/Fortran/gfortran/regression/dtio_11.f90 b/Fortran/gfortran/regression/dtio_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_11.f90 @@ -0,0 +1,52 @@ +! { dg-do compile } +! +! Test fixes for PRs77532-4. +! +! Contributed by Gerhard Steinmetz +! +! PR77532 - used to ICE +module m1 + type t + end type + interface read(unformatted) + end interface +end + +! PR77533 - used to ICE after error +module m2 + type t + type(unknown), pointer :: next ! { dg-error "has not been declared" } + contains + procedure :: s ! { dg-error "Non-polymorphic passed-object" } + generic :: write(formatted) => s + end type +contains + subroutine s(x) ! { dg-error "Too few dummy arguments" } + end +end + +! PR77533 comment #1 - gave error 'KIND = 0' +module m3 + type t + contains + procedure :: s ! { dg-error "Non-polymorphic passed-object" } + generic :: write(formatted) => s + end type +contains + subroutine s(x) ! { dg-error "Too few dummy arguments" } + class(t), intent(in) : x ! { dg-error "Invalid character in name" } + end +end + +! PR77534 +module m4 + type t + end type + interface read(unformatted) + module procedure s + end interface +contains + subroutine s(dtv) ! { dg-error "Too few dummy arguments" } + type(t), intent(inout) :: dtv + end +end diff --git a/Fortran/gfortran/regression/dtio_12.f90 b/Fortran/gfortran/regression/dtio_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_12.f90 @@ -0,0 +1,80 @@ +! { dg-do run { target fd_truncate } } +! +! Test the fix for PR77657 in which the DTIO subroutine was not found, +! which led to an error in attempting to link to the abstract interface. +! +! Contributed by Damian Rouson +! +MODULE abstract_parent + implicit none + + type, abstract :: parent + contains + procedure(write_formatted_interface), deferred :: write_formatted + generic :: write(formatted) => write_formatted + end type parent + + abstract interface + subroutine write_formatted_interface(this,unit,iotype,vlist,iostat,iomsg) + import parent + class(parent), intent(in) :: this + integer, intent(in) :: unit + character (len=*), intent(in) :: iotype + integer, intent(in) :: vlist(:) + integer, intent(out) :: iostat + character (len=*), intent(inout) :: iomsg + end subroutine + end interface + +end module + +module child_module + use abstract_parent, only : parent + implicit none + + type, extends(parent) :: child + integer :: i = 99 + contains + procedure :: write_formatted + end type +contains + subroutine write_formatted(this,unit,iotype,vlist,iostat,iomsg) + class(child), intent(in) :: this + integer, intent(in) :: unit + character (len=*), intent(in) :: iotype + integer, intent(in) :: vlist(:) + integer, intent(out) :: iostat + character (len=*), intent(inout) :: iomsg + write (unit, "(i4)") this%i + end subroutine +end module + + use child_module, only : child + implicit none + type (child) :: baby + integer :: v(1), istat + character(20) :: msg + open (10, status = "scratch") + call baby%write_formatted(10, "abcd", v, istat, msg) ! Call the dtio proc directly + rewind (10) + read (10, *) msg + if (trim (msg) .ne. "99") STOP 1 + rewind (10) + baby%i = 42 + write (10,"(DT)") baby ! Call the dtio proc via the library + rewind (10) + read (10, *) msg + if (trim (msg) .ne. "42") STOP 2 + rewind (10) + write (10,"(DT)") child (77) ! The original testcase + rewind (10) + read (10, *) msg + if (trim (msg) .ne. "77") STOP 3 + rewind (10) + write (10,40) child (77) ! Modified using format label +40 format(DT) + rewind (10) + read (10, *) msg + if (trim (msg) .ne. "77") STOP 4 + close(10) +end diff --git a/Fortran/gfortran/regression/dtio_13.f90 b/Fortran/gfortran/regression/dtio_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_13.f90 @@ -0,0 +1,142 @@ +! { dg-do compile } +! { dg-options -std=legacy } +! +! Test elimination of various segfaults and ICEs on error recovery. +! +! Contributed by Gerhard Steinmetz +! +module m1 + type t + end type + interface write(formatted) + module procedure s + end interface +contains + subroutine s(dtv,unit,iotype,vlist,extra,iostat,iomsg) ! { dg-error "Too many dummy arguments" } + class(t), intent(in) :: dtv + integer, intent(in) :: unit + character(len=*), intent(in) :: iotype + integer, intent(in) :: vlist(:) + integer, intent(out) :: iostat + character(len=*), intent(inout) :: iomsg + end +end + +module m2 + type t + end type + interface read(formatted) + module procedure s + end interface +contains + subroutine s(dtv,unit,iotype,vlist,iostat,iomsg,extra) ! { dg-error "Too many dummy arguments" } + class(t), intent(inout) :: dtv + integer, intent(in) :: unit + character(len=*), intent(in) :: iotype + integer, intent(in) :: vlist(:) + integer, intent(out) :: iostat + character(len=*), intent(inout) :: iomsg + end +end + +module m3 + type t + end type + interface read(formatted) + module procedure s + end interface +contains + subroutine s(dtv,extra,unit,iotype,vlist,iostat,iomsg) ! { dg-error "Too many dummy arguments" } + class(t), intent(inout) :: dtv + integer, intent(in) :: unit + character(len=*), intent(in) :: iotype + integer, intent(in) :: vlist(:) + integer, intent(out) :: iostat + character(len=*), intent(inout) :: iomsg + end +end + +module m4 + type t + end type + interface write(unformatted) + module procedure s + end interface +contains + subroutine s(*) ! { dg-error "Alternate return" } + end +end + +module m5 + type t + contains + procedure :: s + generic :: write(unformatted) => s + end type +contains + subroutine s(dtv, *) ! { dg-error "Too few dummy arguments" } + class(t), intent(out) :: dtv + end +end + +module m6 + type t + character(len=20) :: name + integer(4) :: age + contains + procedure :: pruf + generic :: read(unformatted) => pruf + end type +contains + subroutine pruf (dtv,unit,*,iomsg) ! { dg-error "Alternate return" } + class(t), intent(inout) :: dtv + integer, intent(in) :: unit + character(len=*), intent(inout) :: iomsg + write (unit=unit, iostat=iostat, iomsg=iomsg) dtv%name, dtv%age + end +end + +module m7 + type t + character(len=20) :: name + integer(4) :: age + contains + procedure :: pruf + generic :: read(unformatted) => pruf + end type +contains + subroutine pruf (dtv,unit,iostat) ! { dg-error "Too few dummy arguments" } + class(t), intent(inout) :: dtv + integer, intent(in) :: unit + integer, intent(out) :: iostat + character(len=1) :: iomsg + write (unit=unit, iostat=iostat, iomsg=iomsg) dtv%name, dtv%age + end +end + +module m + type t + character(len=20) :: name + integer(4) :: age + contains + procedure :: pruf + generic :: read(unformatted) => pruf + end type +contains + subroutine pruf (dtv,unit,iostat,iomsg) + class(t), intent(inout) :: dtv + integer, intent(in) :: unit + integer, intent(out) :: iostat + character(len=*), intent(inout) :: iomsg + write (unit=unit, iostat=iostat, iomsg=iomsg) dtv%name, dtv%age + end +end +program test + use m + character(3) :: a, b + class(t) :: chairman ! { dg-error "must be dummy, allocatable or pointer" } + open (unit=71, file='myunformatted_data.dat', form='unformatted') + read (71) a, chairman, b + close (unit=71) +end + diff --git a/Fortran/gfortran/regression/dtio_14.f90 b/Fortran/gfortran/regression/dtio_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_14.f90 @@ -0,0 +1,64 @@ +! { dg-do run } +! +! Functional test of User Defined Derived Type IO with typebound bindings +! This version tests IO to internal character units. +! +MODULE p + TYPE :: person + CHARACTER (LEN=20) :: name + INTEGER(4) :: age + CONTAINS + procedure :: pwf + procedure :: prf + GENERIC :: WRITE(FORMATTED) => pwf + GENERIC :: READ(FORMATTED) => prf + END TYPE person +CONTAINS + SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg) + CLASS(person), INTENT(IN) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER (LEN=*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: vlist(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + WRITE(unit, FMT = *, IOSTAT=iostat) dtv%name, dtv%age + END SUBROUTINE pwf + + SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg) + CLASS(person), INTENT(INOUT) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER (LEN=*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: vlist(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age + END SUBROUTINE prf +END MODULE p + +PROGRAM test + USE p + TYPE (person) :: chairman, answer + character(kind=1,len=80) :: str1 + character(kind=4,len=80) :: str4 + str1 = "" + str4 = 4_"" + chairman%name="Charlie" + chairman%age=62 + answer = chairman +! KIND=1 test + write (str1, *) chairman + if (trim(str1).ne." Charlie 62") STOP 1 + chairman%name="Bogus" + chairman%age=99 + read (str1, *) chairman + if (chairman%name.ne.answer%name) STOP 2 + if (chairman%age.ne.answer%age) STOP 3 +! KIND=4 test + write (str4, *) chairman + if (trim(str4).ne.4_" Charlie 62") STOP 4 + chairman%name="Bogus" + chairman%age=99 + read (str4, *) chairman + if (chairman%name.ne.answer%name) STOP 5 + if (chairman%age.ne.answer%age) STOP 6 +END PROGRAM test diff --git a/Fortran/gfortran/regression/dtio_15.f90 b/Fortran/gfortran/regression/dtio_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_15.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! Test that inquire of string internal unit in child process errors. +module string_m + implicit none + type person + character(10) :: aname + integer :: ijklmno + contains + procedure :: write_s + generic :: write(formatted) => write_s + end type person +contains + subroutine write_s (this, lun, iotype, vlist, istat, imsg) + class(person), intent(in) :: this + integer, intent(in) :: lun + character(len=*), intent(in) :: iotype + integer, intent(in) :: vlist(:) + integer, intent(out) :: istat + character(len=*), intent(inout) :: imsg + integer :: filesize + inquire( unit=lun, size=filesize, iostat=istat, iomsg=imsg) + if (istat /= 0) return + end subroutine write_s +end module string_m +program p + use string_m + type(person) :: s + character(len=12) :: msg + integer :: istat + character(len=256) :: imsg = "" + write( msg, "(DT)", iostat=istat) s + if (istat /= 5018) STOP 1 +end program p diff --git a/Fortran/gfortran/regression/dtio_16.f90 b/Fortran/gfortran/regression/dtio_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_16.f90 @@ -0,0 +1,73 @@ +! { dg-do run } +! Tests that inquire(iolength=) treats derived types as if they do not +! have User Defined procedures. Fortran Draft F2016 Standard, 9.10.3 +MODULE p + TYPE :: person + CHARACTER (LEN=20) :: name + INTEGER(4) :: age + END TYPE person + INTERFACE WRITE(FORMATTED) + MODULE procedure pwf + END INTERFACE + INTERFACE WRITE(UNFORMATTED) + MODULE procedure pwuf + END INTERFACE + INTERFACE read(FORMATTED) + MODULE procedure prf + END INTERFACE + INTERFACE read(UNFORMATTED) + MODULE procedure pruf + END INTERFACE +CONTAINS + SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg) + CLASS(person), INTENT(IN) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER (LEN=*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: vlist(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + WRITE(unit, FMT = *, IOSTAT=iostat) dtv%name, dtv%age + END SUBROUTINE pwf + + SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg) + CLASS(person), INTENT(INOUT) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER (LEN=*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: vlist(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age + END SUBROUTINE prf + + SUBROUTINE pwuf (dtv,unit,iostat,iomsg) + CLASS(person), INTENT(IN) :: dtv + INTEGER, INTENT(IN) :: unit + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + print *, "in pwuf" + WRITE (UNIT=UNIT, FMT = *) DTV%name, DTV%age + END SUBROUTINE pwuf + + SUBROUTINE pruf (dtv,unit,iostat,iomsg) + CLASS(person), INTENT(INOUT) :: dtv + INTEGER, INTENT(IN) :: unit + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + print *, "in pruf" + READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age + END SUBROUTINE pruf + +END MODULE p + +PROGRAM test + USE p + IMPLICIT NONE + TYPE (person) :: chairman + integer(4) :: rl, tl, kl + + chairman%name="Charlie" + chairman%age=62 + + inquire(iolength=rl) rl, kl, chairman, rl, chairman, tl + if (rl.ne.64) STOP 1 +END PROGRAM test diff --git a/Fortran/gfortran/regression/dtio_17.f90 b/Fortran/gfortran/regression/dtio_17.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_17.f90 @@ -0,0 +1,81 @@ +! { dg-do run } +! PR48298, this tests function of size= specifier with DTIO. +MODULE p + USE ISO_FORTRAN_ENV + TYPE :: person + CHARACTER (LEN=20) :: name + INTEGER(4) :: age + CONTAINS + procedure :: pwf + procedure :: prf + GENERIC :: WRITE(FORMATTED) => pwf + GENERIC :: READ(FORMATTED) => prf + END TYPE person +CONTAINS + SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg) + CLASS(person), INTENT(IN) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER (LEN=*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: vlist(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + CHARACTER (LEN=30) :: udfmt + INTEGER :: myios + + iomsg = "SUCCESS" + iostat=0 + if (iotype.eq."DT") then + WRITE(unit, FMT = '(a20,i2)', IOSTAT=iostat, advance='no') dtv%name, dtv%age + if (iostat.ne.0) iomsg = "Fail PWF DT" + endif + if (iotype.eq."LISTDIRECTED") then + WRITE(unit, '(*(g0))', IOSTAT=iostat) dtv%name, dtv%age + if (iostat.ne.0) iomsg = "Fail PWF DT" + endif + END SUBROUTINE pwf + + SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg) + CLASS(person), INTENT(INOUT) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER (LEN=*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: vlist(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + CHARACTER (LEN=30) :: udfmt + INTEGER :: myios + real :: areal + udfmt='(*(g0))' + iomsg = "SUCCESS" + iostat=0 + if (iotype.eq."DT") then + READ(unit, FMT = '(a20,i2)', IOSTAT=iostat) dtv%name, dtv%age + if (iostat.ne.0) iomsg = "Fail PWF DT" + endif + END SUBROUTINE prf + +END MODULE p + +PROGRAM test + USE p + implicit none + TYPE (person) :: chairman + integer(4) :: rl, tl, kl, thesize + + rl = 1 + tl = 22 + kl = 333 + thesize = 9999 + chairman%name="Charlie" + chairman%age=62 + + open(28, status='scratch') + write(28, '(i10,i10,DT,i15,DT,i12)') rl, kl, chairman, rl, chairman, tl + rewind(28) + chairman%name="bogus" + chairman%age=99 + !print *, chairman + read(28, '(i10,i10,DT,i15,DT,i12)', advance='no', size=thesize) rl, & + & kl, chairman, rl, chairman, tl + if (thesize.ne.91) STOP 1 + close(28) +END PROGRAM test diff --git a/Fortran/gfortran/regression/dtio_18.f90 b/Fortran/gfortran/regression/dtio_18.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_18.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! +! PR 78592: [7 Regression] ICE in gfc_find_specific_dtio_proc, at fortran/interface.c:4939 +! +! Contributed by Gerhard Steinmetz + +program p + type t + end type + type(t) :: z + interface write(formatted) + module procedure wf ! { dg-error "is neither function nor subroutine" } + end interface + print *, z +end diff --git a/Fortran/gfortran/regression/dtio_19.f90 b/Fortran/gfortran/regression/dtio_19.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_19.f90 @@ -0,0 +1,68 @@ +! { dg-do run } +! +! PR78737: [OOP] linking error with deferred, undefined user-defined derived-type I/O +! +! Contributed by Damian Rouson + +module object_interface + character(30) :: buffer(2) + type, abstract :: object + contains + procedure(write_formatted_interface), deferred :: write_formatted + generic :: write(formatted) => write_formatted + end type + abstract interface + subroutine write_formatted_interface(this,unit,iotype,vlist,iostat,iomsg) + import object + class(object), intent(in) :: this + integer, intent(in) :: unit + character (len=*), intent(in) :: iotype + integer, intent(in) :: vlist(:) + integer, intent(out) :: iostat + character (len=*), intent(inout) :: iomsg + end subroutine + end interface + type, extends(object) :: non_abstract_child1 + integer :: i + contains + procedure :: write_formatted => write_formatted1 + end type + type, extends(object) :: non_abstract_child2 + real :: r + contains + procedure :: write_formatted => write_formatted2 + end type +contains + subroutine write_formatted1(this,unit,iotype,vlist,iostat,iomsg) + class(non_abstract_child1), intent(in) :: this + integer, intent(in) :: unit + character (len=*), intent(in) :: iotype + integer, intent(in) :: vlist(:) + integer, intent(out) :: iostat + character (len=*), intent(inout) :: iomsg + write(unit,'(a,i2/)') "write_formatted1 => ", this%i + end subroutine + subroutine write_formatted2(this,unit,iotype,vlist,iostat,iomsg) + class(non_abstract_child2), intent(in) :: this + integer, intent(in) :: unit + character (len=*), intent(in) :: iotype + integer, intent(in) :: vlist(:) + integer, intent(out) :: iostat + character (len=*), intent(inout) :: iomsg + write(unit,'(a,f4.1/)') "write_formatted2 => ", this%r + end subroutine + subroutine assert(a) + class(object):: a + write(buffer,'(DT)') a + end subroutine +end module + +program p + use object_interface + + call assert (non_abstract_child1 (99)) + if (trim (buffer(1)) .ne. "write_formatted1 => 99") STOP 1 + + call assert (non_abstract_child2 (42.0)) + if (trim (buffer(1)) .ne. "write_formatted2 => 42.0") STOP 2 +end diff --git a/Fortran/gfortran/regression/dtio_2.f90 b/Fortran/gfortran/regression/dtio_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_2.f90 @@ -0,0 +1,71 @@ +! { dg-do run } +! +! Functional test of User Defined DT IO, unformatted WRITE/READ +! +! 1) Tests unformatted DTV write with other variables in the record +! 2) Tests reading back the recods written. +! +module p + type :: person + character (len=20) :: name + integer(4) :: age + contains + procedure :: pwuf + procedure :: pruf + generic :: write(unformatted) => pwuf + generic :: read(unformatted) => pruf + end type person +contains + subroutine pwuf (dtv,unit,iostat,iomsg) + class(person), intent(in) :: dtv + integer, intent(in) :: unit + integer, intent(out) :: iostat + character (len=*), intent(inout) :: iomsg + write (unit=unit, iostat=iostat, iomsg=iomsg) dtv%name, dtv%age + end subroutine pwuf + + subroutine pruf (dtv,unit,iostat,iomsg) + class(person), intent(inout) :: dtv + integer, intent(in) :: unit + integer, intent(out) :: iostat + character (len=*), intent(inout) :: iomsg + read (unit = unit) dtv%name, dtv%age + end subroutine pruf + +end module p + +program test + use p + type (person), save :: chairman + character(3) :: tmpstr1, tmpstr2 + chairman%name="charlie" + chairman%age=62 + + open (unit=71, file='myunformatted_data.dat', form='unformatted') + write (71) "abc", chairman, "efg" + write (71) "hij", chairman, "klm" + write (71) "nop", chairman, "qrs" + rewind (unit = 71) + chairman%name="boggle" + chairman%age=1234 + read (71) tmpstr1, chairman, tmpstr2 + if (tmpstr1.ne."abc") STOP 1 + if (tmpstr2.ne."efg") STOP 2 + if (chairman%name.ne."charlie") STOP 3 + if (chairman%age.ne.62) STOP 4 + chairman%name="boggle" + chairman%age=1234 + read (71) tmpstr1, chairman, tmpstr2 + if (tmpstr1.ne."hij") STOP 5 + if (tmpstr2.ne."klm") STOP 6 + if (chairman%name.ne."charlie") STOP 7 + if (chairman%age.ne.62) STOP 8 + chairman%name="boggle" + chairman%age=1234 + read (71) tmpstr1, chairman, tmpstr2 + if (tmpstr1.ne."nop") STOP 9 + if (tmpstr2.ne."qrs") STOP 10 + if (chairman%name.ne."charlie") STOP 11 + if (chairman%age.ne.62) STOP 12 + close (unit = 71, status='delete') +end program test diff --git a/Fortran/gfortran/regression/dtio_20.f03 b/Fortran/gfortran/regression/dtio_20.f03 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_20.f03 @@ -0,0 +1,31 @@ +MODULE m + IMPLICIT NONE + + TYPE :: t + CHARACTER :: c + CONTAINS + PROCEDURE :: write_formatted + GENERIC :: WRITE(FORMATTED) => write_formatted + END TYPE t +CONTAINS + SUBROUTINE write_formatted(dtv, unit, iotype, v_list, iostat, iomsg) + CLASS(t), INTENT(IN) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER(*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: v_list(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER(*), INTENT(INOUT) :: iomsg + + WRITE (unit, "(A)", IOSTAT=iostat, IOMSG=iomsg) iotype + END SUBROUTINE write_formatted +END MODULE m + +PROGRAM p + USE m + IMPLICIT NONE + CHARACTER(25) :: str + + TYPE(t) :: x + WRITE (str, "(DT'a''b')") x + if (str.ne."DTa'b") STOP 1 +END PROGRAM p diff --git a/Fortran/gfortran/regression/dtio_21.f90 b/Fortran/gfortran/regression/dtio_21.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_21.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! +! PR 78592: [7 Regression] ICE in gfc_find_specific_dtio_proc, at fortran/interface.c:4939 +! +! Contributed by Mikael Morin + +program p + type t + end type + type(t) :: z + type, extends(t) :: t2 + end type + class(t2), allocatable :: z2 + interface write(formatted) + procedure wf2 + module procedure wf ! { dg-error "is neither function nor subroutine" } + end interface + print *, z + allocate(z2) + print *, z2 + contains + subroutine wf2(this, a, b, c, d, e) ! { dg-error "must have assumed length" } + class(t2), intent(in) :: this + integer, intent(in) :: a + character(*), intent(in) :: b + integer, intent(in) :: c(:) + integer, intent(out) :: d + character, intent(inout) :: e + end subroutine wf2 +end diff --git a/Fortran/gfortran/regression/dtio_22.f90 b/Fortran/gfortran/regression/dtio_22.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_22.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! +! PR 78848: [OOP] ICE on writing CLASS variable with non-typebound DTIO procedure +! +! Contributed by Mikael Morin + +module m + type :: t + integer :: i = 123 + end type + interface write(formatted) + procedure wf + end interface +contains + subroutine wf(this, unit, b, c, iostat, iomsg) + class(t), intent(in) :: this + integer, intent(in) :: unit + character(*), intent(in) :: b + integer, intent(in) :: c(:) + integer, intent(out) :: iostat + character(*), intent(inout) :: iomsg + write (unit, "(i3)", IOSTAT=iostat, IOMSG=iomsg) this%i + end subroutine +end + +program p + use m + character(3) :: buffer + class(t), allocatable :: z + allocate(z) + write(buffer,"(DT)") z + if (buffer /= "123") STOP 1 +end diff --git a/Fortran/gfortran/regression/dtio_23.f90 b/Fortran/gfortran/regression/dtio_23.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_23.f90 @@ -0,0 +1,76 @@ +! { dg-do compile } +! +! Test fix for the original in PR793822 and for PR80156. +! +! Contributed by Walt Brainerd +! and (PR80156) +! +module dollar_mod + + implicit none + private + + type, public :: dollar_type + real :: amount + contains + procedure :: Write_dollar + generic :: write(formatted) => Write_dollar + end type dollar_type + + PRIVATE :: write (formatted) ! This used to ICE + +contains + +subroutine Write_dollar & + + (dollar_value, unit, b_edit_descriptor, v_list, iostat, iomsg) + + class (dollar_type), intent(in) :: dollar_value + integer, intent(in) :: unit + character (len=*), intent(in) :: b_edit_descriptor + integer, dimension(:), intent(in) :: v_list + integer, intent(out) :: iostat + character (len=*), intent(inout) :: iomsg + write (unit=unit, fmt="(f9.2)", iostat=iostat) dollar_value%amount + +end subroutine Write_dollar + +end module dollar_mod + +module pr80156 + + implicit none + private + + type, public :: String + character(len=:), allocatable :: raw + end type + + public :: write(unformatted) ! Gave an error due to the first fix for PR79382. + interface write(unformatted) + module procedure writeUnformatted + end interface + +contains + + subroutine writeUnformatted(self, unit, iostat, iomsg) + class(String) , intent(in) :: self + integer , intent(in) :: unit + integer , intent(out) :: iostat + character(len=*), intent(inout) :: iomsg + + if (allocated(self%raw)) then + write (unit, iostat=iostat, iomsg=iomsg) self%raw + else + write (unit, iostat=iostat, iomsg=iomsg) '' + endif + + end subroutine + +end module + + use dollar_mod + type(dollar_type) :: money + money = dollar_type(50.0) + print '(DT)', money ! Make sure that the typebound generic is accessible. +end diff --git a/Fortran/gfortran/regression/dtio_24.f90 b/Fortran/gfortran/regression/dtio_24.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_24.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! +! Test fix for the additional bug that was found in fixing PR79832. +! +! Contributed by Walt Brainerd +! +module dollar_mod + + implicit none + private + + type, public :: dollar_type + real :: amount + end type dollar_type + + interface write(formatted) + module procedure Write_dollar + end interface + + private :: write (formatted) + +contains + +subroutine Write_dollar & + + (dollar_value, unit, b_edit_descriptor, v_list, iostat, iomsg) + + class (dollar_type), intent(in) :: dollar_value + integer, intent(in) :: unit + character (len=*), intent(in) :: b_edit_descriptor + integer, dimension(:), intent(in) :: v_list + integer, intent(out) :: iostat + character (len=*), intent(inout) :: iomsg + write (unit=unit, fmt="(f9.2)", iostat=iostat) dollar_value%amount + +end subroutine Write_dollar + +end module dollar_mod + +program test_dollar + + use :: dollar_mod + implicit none + integer :: ios + character(100) :: errormsg + + type (dollar_type), parameter :: wage = dollar_type(15.10) + write (unit=*, fmt="(DT)", iostat=ios, iomsg=errormsg) wage + if (ios.ne.5006) STOP 1 + if (errormsg(1:22).ne."Missing DTIO procedure") STOP 2 +end program test_dollar diff --git a/Fortran/gfortran/regression/dtio_25.f90 b/Fortran/gfortran/regression/dtio_25.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_25.f90 @@ -0,0 +1,57 @@ +! { dg-do run } +! PR78854 namelist write to internal unit. +module m + implicit none + type :: t + character :: c + integer :: k + contains + procedure :: write_formatted + generic :: write(formatted) => write_formatted + procedure :: read_formatted + generic :: read(formatted) => read_formatted + end type +contains + subroutine write_formatted(dtv, unit, iotype, v_list, iostat, iomsg) + class(t), intent(in) :: dtv + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, intent(in) :: v_list(:) + integer, intent(out) :: iostat + character(*), intent(inout) :: iomsg + if (iotype.eq."NAMELIST") then + write (unit, '(a1,a1,i3)') dtv%c,',', dtv%k + else + write (unit,*) dtv%c, dtv%k + end if + end subroutine + subroutine read_formatted(dtv, unit, iotype, v_list, iostat, iomsg) + class(t), intent(inout) :: dtv + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, intent(in) :: v_list(:) + integer, intent(out) :: iostat + character(*), intent(inout) :: iomsg + character :: comma + if (iotype.eq."NAMELIST") then + read (unit, '(a1,a1,i3)') dtv%c, comma, dtv%k + else + read (unit,*) dtv%c, comma, dtv%k + end if + if (comma /= ',') STOP 1 + end subroutine +end module + +program p + use m + implicit none + character(len=50) :: buffer + type(t) :: x + namelist /nml/ x + x = t('a', 5) + write (buffer, nml) + if (buffer.ne.'&NML X=a, 5 /') STOP 1 + x = t('x', 0) + read (buffer, nml) + if (x%c.ne.'a'.or. x%k.ne.5) STOP 2 +end diff --git a/Fortran/gfortran/regression/dtio_26.f03 b/Fortran/gfortran/regression/dtio_26.f03 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_26.f03 @@ -0,0 +1,67 @@ +! { dg-do run } +! PR78881 test for correct end of record condition and ignoring advance= +module t_m + use, intrinsic :: iso_fortran_env, only : iostat_end, iostat_eor, output_unit + implicit none + type, public :: t + character(len=:), allocatable :: m_s + contains + procedure, pass(this) :: read_t + generic :: read(formatted) => read_t + end type t +contains +subroutine read_t(this, lun, iotype, vlist, istat, imsg) + class(t), intent(inout) :: this + integer, intent(in) :: lun + character(len=*), intent(in) :: iotype + integer, intent(in) :: vlist(:) + integer, intent(out) :: istat + character(len=*), intent(inout) :: imsg + character(len=1) :: c + integer :: i + i = 0 ; imsg='' + loop_read: do + i = i + 1 + read( unit=lun, fmt='(a1)', iostat=istat, iomsg=imsg) c + select case ( istat ) + case ( 0 ) + if (i.eq.1 .and. c.ne.'h') exit loop_read + !write( output_unit, fmt=sfmt) "i = ", i, ", c = ", c + case ( iostat_end ) + !write( output_unit, fmt=sfmt) "i = ", i, ", istat = iostat_end" + exit loop_read + case ( iostat_eor ) + !write( output_unit, fmt=sfmt) "i = ", i, ", istat = iostat_eor" + exit loop_read + case default + !write( output_unit, fmt=sfmt) "i = ", i, ", istat = ", istat + exit loop_read + end select + if (i.gt.10) exit loop_read + end do loop_read +end subroutine read_t +end module t_m + +program p + use t_m, only : t + implicit none + + character(len=:), allocatable :: s + type(t) :: foo + character(len=256) :: imsg + integer :: istat + + open(10, status="scratch") + write(10,'(a)') 'hello' + rewind(10) + read(unit=10, fmt='(dt)', iostat=istat, iomsg=imsg) foo + if (imsg.ne."End of record") STOP 1 + rewind(10) + read(unit=10, fmt=*, iostat=istat, iomsg=imsg) foo + if (imsg.ne."End of record") STOP 2 + s = "hello" + read( unit=s, fmt='(dt)', iostat=istat, iomsg=imsg) foo + if (imsg.ne."End of record") STOP 3 + read( unit=s, fmt=*, iostat=istat, iomsg=imsg) foo + if (imsg.ne."End of record") STOP 4 +end program p diff --git a/Fortran/gfortran/regression/dtio_27.f90 b/Fortran/gfortran/regression/dtio_27.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_27.f90 @@ -0,0 +1,65 @@ +! { dg-do run } +! +! PR 78661: [OOP] Namelist output missing object designator under DTIO +! +! Contributed by Ian Harvey + +MODULE m + IMPLICIT NONE + TYPE :: t + CHARACTER :: c + CONTAINS + PROCEDURE :: write_formatted + GENERIC :: WRITE(FORMATTED) => write_formatted + PROCEDURE :: read_formatted + GENERIC :: READ(FORMATTED) => read_formatted + END TYPE +CONTAINS + SUBROUTINE write_formatted(dtv, unit, iotype, v_list, iostat, iomsg) + CLASS(t), INTENT(IN) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER(*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: v_list(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER(*), INTENT(INOUT) :: iomsg + WRITE (unit, "(A)", IOSTAT=iostat, IOMSG=iomsg) dtv%c + END SUBROUTINE + SUBROUTINE read_formatted(dtv, unit, iotype, v_list, iostat, iomsg) + CLASS(t), INTENT(INOUT) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER(*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: v_list(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER(*), INTENT(INOUT) :: iomsg + READ (unit, "(A)", IOSTAT=iostat, IOMSG=iomsg) dtv%c + END SUBROUTINE +END MODULE + + +PROGRAM p + + USE m + IMPLICIT NONE + character(len=4), dimension(3) :: buffer + call test_type + call test_class + +contains + + subroutine test_type + type(t) :: x + namelist /n1/ x + x = t('a') + write (buffer, n1) + if (buffer(2) /= " X=a") STOP 1 + end subroutine + + subroutine test_class + class(t), allocatable :: y + namelist /n2/ y + y = t('b') + write (buffer, n2) + if (buffer(2) /= " Y=b") STOP 2 + end subroutine + +END diff --git a/Fortran/gfortran/regression/dtio_28.f03 b/Fortran/gfortran/regression/dtio_28.f03 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_28.f03 @@ -0,0 +1,74 @@ +! { dg-do run } +! PR78670 Incorrect file position with namelist read under DTIO +MODULE m + IMPLICIT NONE + TYPE :: t + CHARACTER :: c + CONTAINS + PROCEDURE :: read_formatted + GENERIC :: READ(FORMATTED) => read_formatted + PROCEDURE :: write_formatted + GENERIC :: WRITE(FORMATTED) => write_formatted + END TYPE t +CONTAINS + SUBROUTINE write_formatted(dtv, unit, iotype, v_list, iostat, iomsg) + CLASS(t), INTENT(IN) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER(*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: v_list(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER(*), INTENT(INOUT) :: iomsg + write(unit,'(a)', iostat=iostat, iomsg=iomsg) dtv%c + END SUBROUTINE write_formatted + + SUBROUTINE read_formatted(dtv, unit, iotype, v_list, iostat, iomsg) + CLASS(t), INTENT(INOUT) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER(*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: v_list(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER(*), INTENT(INOUT) :: iomsg + + CHARACTER :: ch + dtv%c = '' + DO + READ (unit, "(A)", IOSTAT=iostat, IOMSG=iomsg) ch + IF (iostat /= 0) RETURN + ! Store first non-blank + IF (ch /= ' ') THEN + dtv%c = ch + RETURN + END IF + END DO + END SUBROUTINE read_formatted +END MODULE m + +PROGRAM p + USE m + IMPLICIT NONE + TYPE(t) :: x + TYPE(t) :: y + TYPE(t) :: z + integer :: j, k + NAMELIST /nml/ j, x, y, z, k + INTEGER :: unit, iostatus + + OPEN(NEWUNIT=unit, STATUS='SCRATCH', ACTION='READWRITE') + + x%c = 'a' + y%c = 'b' + z%c = 'c' + j=1 + k=2 + WRITE(unit, nml) + REWIND (unit) + x%c = 'x' + y%c = 'y' + z%c = 'x' + j=99 + k=99 + READ (unit, nml, iostat=iostatus) + if (iostatus.ne.0) STOP 1 + if (j.ne.1 .or. k.ne.2 .or. x%c.ne.'a' .or. y%c.ne.'b' .or. z%c.ne.'c') STOP 2 + !WRITE(*, nml) +END PROGRAM p diff --git a/Fortran/gfortran/regression/dtio_29.f03 b/Fortran/gfortran/regression/dtio_29.f03 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_29.f03 @@ -0,0 +1,47 @@ +! { dg-do compile } +! PR80484 Three syntax errors involving derived-type I/O +module dt_write_mod + type, public :: B_type + real :: amount + end type B_type + interface write (formatted) + procedure :: Write_b + end interface +contains + +subroutine Write_b & + (amount, unit, b_edit_descriptor, v_list, iostat, iomsg) + + class (B_type), intent(in) :: amount + integer, intent(in) :: unit + character (len=*), intent(in) :: b_edit_descriptor + integer, dimension(:), intent(in) :: v_list + integer, intent(out) :: iostat + character (len=*), intent(inout) :: iomsg + write (unit=unit, fmt="(f9.3)", iostat=iostat) amount%amount + +end subroutine Write_b + +end module dt_write_mod + +program test + use dt_write_mod, only: B_type , write(formatted) + implicit none + + real :: wage = 15.10 + integer :: ios + character(len=99) :: iom = "OK" + + write (unit=*, fmt="(DT'$$$Z.##')", iostat=ios, iomsg=iom) & + B_type(wage), B_type(wage) + print *, trim(iom) + write (unit=*, fmt="(2DT'$$$Z.##')", iostat=ios, iomsg=iom) & + B_type(wage), B_type(wage) + print *, trim(iom) + write (unit=*, fmt="(3DT'$$$Z.##')", iostat=ios, iomsg=iom) & + B_type(wage), B_type(wage) + print *, trim(iom) + write (unit=*, fmt="(DT'$$$Z.##'/)", iostat=ios, iomsg=iom) & + B_type(wage), B_type(wage) + print *, trim(iom) +end program test diff --git a/Fortran/gfortran/regression/dtio_3.f90 b/Fortran/gfortran/regression/dtio_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_3.f90 @@ -0,0 +1,172 @@ +! { dg-do run } +! +! Functional test of User Defined Derived Type IO. +! +! This tests recursive calls where a derived type has a member that is +! itself. +! +MODULE p + USE ISO_FORTRAN_ENV + TYPE :: person + CHARACTER (LEN=20) :: name + INTEGER(4) :: age + type(person), pointer :: next => NULL() + CONTAINS + procedure :: pwf + procedure :: prf + GENERIC :: WRITE(FORMATTED) => pwf + GENERIC :: READ(FORMATTED) => prf + END TYPE person +CONTAINS + RECURSIVE SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg) + CLASS(person), INTENT(IN) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER (LEN=*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: vlist(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + CHARACTER (LEN=30) :: udfmt + INTEGER :: myios + + udfmt='(*(g0))' + iomsg = "SUCCESS" + iostat=0 + if (iotype.eq."DT") then + if (size(vlist).ne.0) print *, 36 + if (associated(dtv%next)) then + WRITE(unit, FMT = '(a20,i2, DT)', IOSTAT=iostat, advance='no') dtv%name, dtv%age, dtv%next + else + WRITE(unit, FMT = '(a20,i2)', IOSTAT=iostat, advance='no') dtv%name, dtv%age + endif + if (iostat.ne.0) iomsg = "Fail PWF DT" + endif + if (iotype.eq."DTzeroth") then + if (size(vlist).ne.0) print *, 40 + WRITE(unit, FMT = '(g0,g0)', advance='no') dtv%name, dtv%age + if (iostat.ne.0) iomsg = "Fail PWF DTzeroth" + endif + if (iotype.eq."DTtwo") then + if (size(vlist).ne.2) STOP 1 + WRITE(udfmt,'(A,A,I1,A,I1,A)') '(', 'A', vlist(1),',I', vlist(2), ')' + WRITE(unit, FMT='(A8,I2)') dtv%name, dtv%age + if (iostat.ne.0) iomsg = "Fail PWF DTtwo" + endif + if (iotype.eq."DTthree") then + WRITE(udfmt,'(2A,I2,A,I1,A,I2,A)',iostat=myios) '(', 'A', vlist(1),',I', vlist(2), ',F', vlist(3), '.2)' + WRITE(unit, FMT=udfmt, IOSTAT=iostat, advance='no') trim(dtv%name), dtv%age, 3.14 + if (iostat.ne.0) iomsg = "Fail PWF DTthree" + endif + if (iotype.eq."LISTDIRECTED") then + if (size(vlist).ne.0) print *, 55 + if (associated(dtv%next)) then + WRITE(unit, FMT = *) dtv%name, dtv%age, dtv%next + else + WRITE(unit, FMT = *) dtv%name, dtv%age + endif + if (iostat.ne.0) iomsg = "Fail PWF LISTDIRECTED" + endif + if (iotype.eq."NAMELIST") then + if (size(vlist).ne.0) print *, 59 + iostat=6000 + endif + if (associated (dtv%next) .and. (iotype.eq."LISTDIRECTED")) write(unit, fmt = *) dtv%next + END SUBROUTINE pwf + + RECURSIVE SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg) + CLASS(person), INTENT(INOUT) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER (LEN=*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: vlist(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + CHARACTER (LEN=30) :: udfmt + INTEGER :: myios + real :: areal + udfmt='(*(g0))' + iomsg = "SUCCESS" + iostat=0 + if (iotype.eq."DT") then + if (size(vlist).ne.0) print *, 36 + if (associated(dtv%next)) then + READ(unit, FMT = '(a20,i2, DT)', IOSTAT=iostat, advance='no') dtv%name, dtv%age, dtv%next + else + READ(unit, FMT = '(a20,i2)', IOSTAT=iostat, advance='no') dtv%name, dtv%age + endif + if (iostat.ne.0) iomsg = "Fail PWF DT" + endif + if (iotype.eq."DTzeroth") then + if (size(vlist).ne.0) print *, 40 + READ(unit, FMT = '(a,I2)', advance='no') dtv%name, dtv%age + if (iostat.ne.0) iomsg = "Fail PWF DTzeroth" + endif + if (iotype.eq."DTtwo") then + if (size(vlist).ne.2) STOP 1 + WRITE(udfmt,'(A,A,I1,A,I1,A)') '(', 'A', vlist(1),',I', vlist(2), ')' + READ(unit, FMT='(A8,I2)') dtv%name, dtv%age + if (iostat.ne.0) iomsg = "Fail PWF DTtwo" + endif + if (iotype.eq."DTthree") then + WRITE(udfmt,'(2A,I2,A,I1,A,I2,A)',iostat=myios) '(', 'A', vlist(1),',I', vlist(2), ',F', vlist(3), '.2)' + READ(unit, FMT=udfmt, IOSTAT=iostat, advance='no') dtv%name, dtv%age, areal + if (iostat.ne.0) iomsg = "Fail PWF DTthree" + endif + if (iotype.eq."LISTDIRECTED") then + if (size(vlist).ne.0) print *, 55 + READ(unit, FMT = *) dtv%name, dtv%age + if (iostat.ne.0) iomsg = "Fail PWF LISTDIRECTED" + endif + if (iotype.eq."NAMELIST") then + if (size(vlist).ne.0) print *, 59 + iostat=6000 + endif + !READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age + END SUBROUTINE prf + +END MODULE p + +PROGRAM test + USE p + TYPE (person) :: chairman + TYPE (person), target :: member + character(80) :: astring + integer :: thelength + + chairman%name="Charlie" + chairman%age=62 + member%name="George" + member%age=42 + astring = "FAILURE" + ! At this point, next is NULL as defined up in the type block. + open(10, status = "scratch") + write (10, *, iostat=myiostat, iomsg=astring) member, chairman + write(10,*) + rewind(10) + chairman%name="bogus1" + chairman%age=99 + member%name="bogus2" + member%age=66 + read (10, *, iostat=myiostat, iomsg=astring) member, chairman + if (astring.ne."SUCCESS") print *, astring + if (member%name.ne."George") STOP 1 + if (chairman%name.ne."Charlie") STOP 1 + if (member%age.ne.42) STOP 1 + if (chairman%age.ne.62) STOP 1 + close(10, status='delete') + ! Now we set next to point to member. This changes the code path + ! in the pwf and prf procedures. + chairman%next => member + open(10, status = "scratch") + write (10,"(DT)") chairman + rewind(10) + chairman%name="bogus1" + chairman%age=99 + member%name="bogus2" + member%age=66 + read (10,"(DT)", iomsg=astring) chairman + !print *, trim(astring) + if (member%name.ne."George") STOP 1 + if (chairman%name.ne."Charlie") STOP 1 + if (member%age.ne.42) STOP 1 + if (chairman%age.ne.62) STOP 1 + close(10) +END PROGRAM test diff --git a/Fortran/gfortran/regression/dtio_30.f03 b/Fortran/gfortran/regression/dtio_30.f03 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_30.f03 @@ -0,0 +1,60 @@ +! { dg-do run } +! PR80333 Namelist dtio write of array of class does not traverse the array +! This test checks both NAMELIST WRITE and READ of an array of class +module m + implicit none + type :: t + character :: c + character :: d + contains + procedure :: read_formatted + generic :: read(formatted) => read_formatted + procedure :: write_formatted + generic :: write(formatted) => write_formatted + end type t +contains + subroutine read_formatted(dtv, unit, iotype, v_list, iostat, iomsg) + class(t), intent(inout) :: dtv + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, intent(in) :: v_list(:) + integer, intent(out) :: iostat + character(*), intent(inout) :: iomsg + integer :: i + read(unit,'(a1,a1)', iostat=iostat, iomsg=iomsg) dtv%c, dtv%d + end subroutine read_formatted + + subroutine write_formatted(dtv, unit, iotype, v_list, iostat, iomsg) + class(t), intent(in) :: dtv + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, intent(in) :: v_list(:) + integer, intent(out) :: iostat + character(*), intent(inout) :: iomsg + write(unit,'(a1,a1)', iostat=iostat, iomsg=iomsg) dtv%c, dtv%d + end subroutine write_formatted +end module m + +program p + use m + implicit none + class(t), dimension(:,:), allocatable :: w + namelist /nml/ w + integer :: unit, iostatus + character(256) :: str = "" + + open(10, status='scratch') + allocate(w(10,3)) + w = t('j','r') + w(5:7,2)%c='k' + write(10, nml) + rewind(10) + w = t('p','z') + read(10, nml) + write(str,*) w + if (str.ne." jr jr jr jr jr jr jr jr jr jr jr jr jr jr kr kr kr jr jr jr jr jr jr jr jr jr jr jr jr jr") & + & STOP 1 + str = "" + write(str,"(*(DT))") w + if (str.ne."jrjrjrjrjrjrjrjrjrjrjrjrjrjrkrkrkrjrjrjrjrjrjrjrjrjrjrjrjrjr") STOP 2 +end program p diff --git a/Fortran/gfortran/regression/dtio_31.f03 b/Fortran/gfortran/regression/dtio_31.f03 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_31.f03 @@ -0,0 +1,47 @@ +! { dg-do run } +! { dg-options "-w" } +! PR fortran/79383 +! Contributed by Walt Brainerd +module dollar_mod + + implicit none + + private + + type, public :: dollar_type + real :: amount + end type dollar_type + + interface write(formatted) + procedure :: Write_dollar + end interface + + public :: write(formatted) + + contains + + subroutine Write_dollar(dollar_value, unit, b_edit_descriptor, & + & v_list, iostat, iomsg) + + class(dollar_type), intent(in) :: dollar_value + integer, intent(in) :: unit + character(len=*), intent(in) :: b_edit_descriptor + integer, dimension(:), intent(in) :: v_list + integer, intent(out) :: iostat + character(len=*), intent(inout) :: iomsg + write(unit=unit, fmt="(f9.2)", iostat=iostat) dollar_value%amount + end subroutine Write_dollar + +end module dollar_mod + +program test_dollar + + use, non_intrinsic :: dollar_mod, only: dollar_type, write (formatted) + implicit none + + type(dollar_type), parameter :: wage = dollar_type(15.10) + character(len=10) str + write (str, fmt="(DT)") wage + if(trim(adjustl(str)) /= '15.10') STOP 1 + +end program test_dollar diff --git a/Fortran/gfortran/regression/dtio_32.f03 b/Fortran/gfortran/regression/dtio_32.f03 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_32.f03 @@ -0,0 +1,46 @@ +! { dg-do run } +! { dg-options "-w" } +! PR fortran/79383 +! Contributed by Walt Brainerd +module dollar_mod + + implicit none + + private + + type, public :: dollar_type + real :: amount + end type dollar_type + + interface write(formatted) + procedure :: Write_dollar + end interface + + public :: write(formatted) + + contains + + subroutine Write_dollar(dollar_value, unit, b_edit_descriptor, & + & v_list, iostat, iomsg) + class(dollar_type), intent(in) :: dollar_value + integer, intent(in) :: unit + character(len=*), intent(in) :: b_edit_descriptor + integer, dimension(:), intent(in) :: v_list + integer, intent(out) :: iostat + character(len=*), intent(inout) :: iomsg + write(unit=unit, fmt="(f9.2)", iostat=iostat) dollar_value%amount + end subroutine Write_dollar + +end module dollar_mod + +program test_dollar + + use :: dollar_mod ! with this USE, same result + implicit none + + type(dollar_type), parameter :: wage = dollar_type(15.10) + character(len=10) str + write(str, fmt="(DT)") wage + if (trim(adjustl(str)) /= '15.10') STOP 1 + +end program test_dollar diff --git a/Fortran/gfortran/regression/dtio_33.f90 b/Fortran/gfortran/regression/dtio_33.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_33.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! PR84389 rejected valid use of ':' in format +module m + type :: t + integer :: i + contains + procedure, pass(this) :: write_t + generic, public :: write(formatted) => write_t + end type +contains + subroutine write_t(this, lun, iotype, vlist, istat, imsg) + ! argument definitions + class(t), intent(in) :: this + integer, intent(in) :: lun + character(len=*), intent(in) :: iotype + integer, intent(in) :: vlist(:) + integer, intent(out) :: istat + character(len=*), intent(inout) :: imsg + write(lun, fmt=*, iostat=istat, iomsg=imsg) "Hello World!" + end subroutine write_t +end module +program p + use m, only : t + character(50) :: str + type(t) :: foo(2) + write(str, "(*(dt:,','))") foo + if (str.ne." Hello World!, Hello World!") stop 1 +end program diff --git a/Fortran/gfortran/regression/dtio_34.f90 b/Fortran/gfortran/regression/dtio_34.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_34.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! PR84387 Defined output does not work for a derived type that +! has no components +module m + type :: t + private + !integer :: m_i = 0 !<-- *** + contains + private + procedure, pass(this) :: write_t + generic, public :: write(formatted) => write_t + end type +contains + subroutine write_t(this, lun, iotype, vlist, istat, imsg) + ! argument definitions + class(t), intent(in) :: this + integer, intent(in) :: lun + character(len=*), intent(in) :: iotype + integer, intent(in) :: vlist(:) + integer, intent(out) :: istat + character(len=*), intent(inout) :: imsg + write(lun, fmt=*, iostat=istat, iomsg=imsg) "Hello World!" + return + end subroutine write_t + +end module + +program p + use m, only : t + type(t) :: foo + print "(dt)", foo ! { dg-output " Hello World!" } +end program diff --git a/Fortran/gfortran/regression/dtio_35.f90 b/Fortran/gfortran/regression/dtio_35.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_35.f90 @@ -0,0 +1,50 @@ +! { dg-compile } +! +! Reported by Vladimir Nikishkin +! at https://stackoverflow.com/questions/60972134/whats-wrong-with-the-following-fortran-code-gfortran-dtio-dummy-argument-at# +! + +module scheme + + type, abstract :: scheme_object + contains + procedure, pass :: generic_scheme_print => print_scheme_object + generic, public :: write (formatted) => generic_scheme_print + end type scheme_object + + abstract interface + subroutine packageable_procedure( ) + import scheme_object + end subroutine packageable_procedure + end interface +contains + + subroutine print_scheme_object(this, unit, iotype, v_list, iostat, iomsg) + class(scheme_object), intent(in) :: this + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, intent(in) :: v_list (:) + integer, intent(out) :: iostat + character(*), intent(inout) :: iomsg + iostat = 1 + end subroutine print_scheme_object + + subroutine packaged_cons( ) + end subroutine packaged_cons + + function make_primitive_procedure_object( proc1 ) result( retval ) + class(scheme_object), pointer :: retval + procedure(packageable_procedure), pointer :: proc1 + end function make_primitive_procedure_object + + subroutine ll_setup_global_environment() + procedure(packageable_procedure), pointer :: proc1 + class(scheme_object), pointer :: proc_obj_to_pack + proc1 => packaged_cons + proc_obj_to_pack => make_primitive_procedure_object( proc1 ) + end subroutine ll_setup_global_environment + +end module scheme + +program main +end program main diff --git a/Fortran/gfortran/regression/dtio_36.f90 b/Fortran/gfortran/regression/dtio_36.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_36.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! +! PR fortran/99146 +! + MODULE p + TYPE :: person + sequence + END TYPE person + INTERFACE READ(UNFORMATTED) + MODULE PROCEDURE pruf + END INTERFACE + + CONTAINS + + SUBROUTINE pruf (dtv,unit,iostat,iomsg) + type(person), INTENT(INOUT) :: dtv + INTEGER, INTENT(IN) :: unit + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + iostat = 1 + END SUBROUTINE pruf + + END MODULE p + + PROGRAM test + USE p + TYPE (person) :: chairman + + OPEN (UNIT=71, status = 'scratch', FORM='UNFORMATTED') + + read(71) chairman + + END PROGRAM test diff --git a/Fortran/gfortran/regression/dtio_4.f90 b/Fortran/gfortran/regression/dtio_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_4.f90 @@ -0,0 +1,107 @@ +! { dg-do run } +! +! Functional test of User Defined Derived Type IO. +! +! This tests a combination of module procedure and generic procedure +! and performs reading and writing an array with a pseudo user defined +! tag at the beginning of the file. +! +module usertypes + type udt + integer :: myarray(15) + contains + procedure :: user_defined_read + generic :: read (formatted) => user_defined_read + end type udt + type, extends(udt) :: more + integer :: someinteger = -25 + end type + + interface write(formatted) + module procedure user_defined_write + end interface + + integer :: result_array(15) +contains + subroutine user_defined_read (dtv, unit, iotype, v_list, iostat, iomsg) + class(udt), intent(inout) :: dtv + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, intent(in) :: v_list (:) + integer, intent(out) :: iostat + character(*), intent(inout) :: iomsg + character(10) :: typestring + + iomsg = 'SUCCESS' + read (unit, '(a6)', iostat=iostat, iomsg=iomsg) typestring + typestring = trim(typestring) + select type (dtv) + type is (udt) + if (typestring.eq.' UDT: ') then + read (unit, fmt=*, iostat=iostat, iomsg=iomsg) dtv%myarray + else + iostat = 6000 + iomsg = 'FAILURE' + end if + type is (more) + if (typestring.eq.' MORE: ') then + read (unit, fmt=*, iostat=iostat, iomsg=iomsg) dtv%myarray + else + iostat = 6000 + iomsg = 'FAILUREwhat' + end if + end select + end subroutine user_defined_read + + subroutine user_defined_write (dtv, unit, iotype, v_list, iostat, iomsg) + class(udt), intent(in) :: dtv + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, intent(in) :: v_list (:) + integer, intent(out) :: iostat + character(*), intent(inout) :: iomsg + character(10) :: typestring + select type (dtv) + type is (udt) + write (unit, fmt=*, iostat=iostat, iomsg=iomsg) "UDT: " + write (unit, fmt=*, iostat=iostat, iomsg=iomsg) dtv%myarray + type is (more) + write (unit, fmt=*, iostat=iostat, iomsg=iomsg) "MORE: " + write (unit, fmt=*, iostat=iostat, iomsg=iomsg) dtv%myarray + end select + write (unit,*) + end subroutine user_defined_write +end module usertypes + +program test1 + use usertypes + type (udt) :: udt1 + type (more) :: more1 + class (more), allocatable :: somemore + integer :: thesize, i, ios + character(25):: iomsg + +! Create a file that contains some data for testing. + open (10, form='formatted', status='scratch') + write(10, '(a)') ' UDT: ' + do i = 1, 15 + write(10,'(i5)', advance='no') i + end do + write(10,*) + rewind(10) + udt1%myarray = 99 + result_array = (/ (i, i = 1, 15) /) + more1%myarray = result_array + read (10, fmt='(dt)', advance='no', iomsg=iomsg) udt1 + if (iomsg.ne.'SUCCESS') STOP 1 + if (any(udt1%myarray.ne.result_array)) STOP 1 + close(10) + open (10, form='formatted', status='scratch') + write (10, '(dt)') more1 + rewind(10) + more1%myarray = 99 + read (10, '(dt)', iostat=ios, iomsg=iomsg) more1 + if (iomsg.ne.'SUCCESS') STOP 1 + if (any(more1%myarray.ne.result_array)) STOP 1 + close (10) +end program test1 diff --git a/Fortran/gfortran/regression/dtio_6.f90 b/Fortran/gfortran/regression/dtio_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_6.f90 @@ -0,0 +1,98 @@ +! { dg-do compile } +! +! Tests the checks for interface compliance. +! +! +MODULE p + USE ISO_C_BINDING + + TYPE :: person + CHARACTER (LEN=20) :: name + INTEGER(4) :: age + CONTAINS + procedure :: pwf ! { dg-error "Non-polymorphic passed-object" } + procedure :: pwuf + GENERIC :: WRITE(FORMATTED) => pwf + GENERIC :: WRITE(UNFORMATTED) => pwuf + END TYPE person + INTERFACE READ(FORMATTED) + MODULE PROCEDURE prf + END INTERFACE + INTERFACE READ(UNFORMATTED) + MODULE PROCEDURE pruf + END INTERFACE + + TYPE :: seq_type + sequence + INTEGER(4) :: i + END TYPE seq_type + INTERFACE WRITE(FORMATTED) + MODULE PROCEDURE pwf_seq + END INTERFACE + + TYPE, BIND(C) :: bindc_type + INTEGER(C_INT) :: i + END TYPE bindc_type + + INTERFACE WRITE(FORMATTED) + MODULE PROCEDURE pwf_bindc + END INTERFACE + +CONTAINS + SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg) ! { dg-error "must be of type CLASS" } + type(person), INTENT(IN) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER (LEN=*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: vlist(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + WRITE(unit, FMT = *, IOSTAT=iostat) dtv%name, dtv%age + END SUBROUTINE pwf + + SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg) ! { dg-error "must be an ASSUMED SHAPE ARRAY" } + CLASS(person), INTENT(INOUT) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER (LEN=*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: vlist + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age + END SUBROUTINE prf + + SUBROUTINE pwuf (dtv,unit,iostat,iomsg) ! { dg-error "must have INTENT IN" } + CLASS(person), INTENT(INOUT) :: dtv + INTEGER, INTENT(IN) :: unit + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + WRITE (UNIT=UNIT, FMT = *) DTV%name, DTV%age + END SUBROUTINE pwuf + + SUBROUTINE pruf (dtv,unit,iostat,iomsg) ! { dg-error "must be of KIND = 4" } + CLASS(person), INTENT(INOUT) :: dtv + INTEGER, INTENT(IN) :: unit + INTEGER(8), INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + READ (UNIT = UNIT, FMT = *) dtv%name, dtv%age + END SUBROUTINE pruf + + SUBROUTINE pwf_seq (dtv,unit,iotype,vlist,iostat,iomsg) ! { dg-error "not extensible|DERIVED" } + class(seq_type), INTENT(IN) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER (LEN=*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: vlist(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + WRITE(unit, FMT = *, IOSTAT=iostat) dtv%i + END SUBROUTINE pwf_seq + + SUBROUTINE pwf_bindc (dtv,unit,iotype,vlist,iostat,iomsg) ! { dg-error "not extensible|DERIVED" } + class(bindc_type), INTENT(IN) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER (LEN=*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: vlist(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + WRITE(unit, FMT = *, IOSTAT=iostat) dtv%i + END SUBROUTINE pwf_bindc + +END MODULE p diff --git a/Fortran/gfortran/regression/dtio_7.f90 b/Fortran/gfortran/regression/dtio_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_7.f90 @@ -0,0 +1,139 @@ +! { dg-do run } +! +! Tests dtio transfer of arrays of derived types and classes +! +MODULE p + TYPE :: person + CHARACTER (LEN=20) :: name + INTEGER(4) :: age + CONTAINS + procedure :: pwf + procedure :: prf + GENERIC :: WRITE(FORMATTED) => pwf + GENERIC :: READ(FORMATTED) => prf + END TYPE person + type, extends(person) :: employee + character(20) :: job_title + end type + type, extends(person) :: officer + character(20) :: position + end type + type, extends(person) :: member + integer :: membership_number + end type + type :: club + type(employee), allocatable :: staff(:) + class(person), allocatable :: committee(:) + class(person), allocatable :: membership(:) + end type +CONTAINS + SUBROUTINE pwf (dtv,unit,iotype,vlist,iostat,iomsg) + CLASS(person), INTENT(IN) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER (LEN=*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: vlist(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + select type (dtv) + type is (employee) + WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Employee" + WRITE(unit, FMT = "(A20,I4,A20/)", IOSTAT=iostat) dtv%name, dtv%age, dtv%job_title + type is (officer) + WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Officer" + WRITE(unit, FMT = "(A20,I4,A20/)", IOSTAT=iostat) dtv%name, dtv%age, dtv%position + type is (member) + WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Member" + WRITE(unit, FMT = "(A20,I4,I4/)", IOSTAT=iostat) dtv%name, dtv%age, dtv%membership_number + class default + WRITE(unit, FMT = "(A/)", IOSTAT=iostat) "Ugggh!" + WRITE(unit, FMT = "(A20,I4,' '/)", IOSTAT=iostat) dtv%name, dtv%age + end select + END SUBROUTINE pwf + + SUBROUTINE prf (dtv,unit,iotype,vlist,iostat,iomsg) + CLASS(person), INTENT(INOUT) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER (LEN=*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: vlist(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + character (20) :: header, rname, jtitle, oposition + integer :: i + integer :: no + integer :: age + iostat = 0 + select type (dtv) + + type is (employee) + read (unit = unit, fmt = *) header + READ (UNIT = UNIT, FMT = "(A20,I4,A20)") rname, age, jtitle + if (trim (rname) .ne. dtv%name) iostat = 1 + if (age .ne. dtv%age) iostat = 2 + if (trim (jtitle) .ne. dtv%job_title) iostat = 3 + if (iotype .ne. "DTstaff") iostat = 4 + + type is (officer) + read (unit = unit, fmt = *) header + READ (UNIT = UNIT, FMT = "(A20,I4,A20)") rname, age, oposition + if (trim (rname) .ne. dtv%name) iostat = 1 + if (age .ne. dtv%age) iostat = 2 + if (trim (oposition) .ne. dtv%position) iostat = 3 + if (iotype .ne. "DTofficers") iostat = 4 + + type is (member) + read (unit = unit, fmt = *) header + READ (UNIT = UNIT, FMT = "(A20,I4,I4)") rname, age, no + if (trim (rname) .ne. dtv%name) iostat = 1 + if (age .ne. dtv%age) iostat = 2 + if (no .ne. dtv%membership_number) iostat = 3 + if (iotype .ne. "DTmembers") iostat = 4 + + class default + STOP 1 + end select + end subroutine +END MODULE p + +PROGRAM test + USE p + + type (club) :: social_club + TYPE (person) :: chairman + CLASS (person), allocatable :: president(:) + character (40) :: line + integer :: i, j + + allocate (social_club%staff, source = [employee ("Bert",25,"Barman"), & + employee ("Joy",16,"Auditor")]) + + allocate (social_club%committee, source = [officer ("Hank",32, "Chair"), & + officer ("Ann", 29, "Secretary")]) + + allocate (social_club%membership, source = [member ("Dan",52,1), & + member ("Sue",39,2)]) + + chairman%name="Charlie" + chairman%age=62 + + open (7, status = "scratch") + write (7,*) social_club%staff ! Tests array of derived types + write (7,*) social_club%committee ! Tests class array + do i = 1, size (social_club%membership, 1) + write (7,*) social_club%membership(i) ! Tests class array elements + end do + + rewind (7) + read (7, "(DT'staff')", iostat = i) social_club%staff + if (i .ne. 0) STOP 2 + + social_club%committee(2)%age = 33 ! Introduce an error + + read (7, "(DT'officers')", iostat = i) social_club%committee + if (i .ne. 2) STOP 3! Pick up error + + do j = 1, size (social_club%membership, 1) + read (7, "(DT'members')", iostat = i) social_club%membership(j) + if (i .ne. 0) STOP 4 + end do + close (7) +END PROGRAM test diff --git a/Fortran/gfortran/regression/dtio_8.f90 b/Fortran/gfortran/regression/dtio_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_8.f90 @@ -0,0 +1,65 @@ +! { dg-do run } +! +! Tests dtio transfer sequence types. +! +! Note difficulty at end with comparisons at any level of optimization. +! +MODULE p + TYPE :: person + sequence + CHARACTER (LEN=20) :: name + INTEGER(4) :: age + END TYPE person + INTERFACE WRITE(UNFORMATTED) + MODULE PROCEDURE pwuf + END INTERFACE + INTERFACE READ(UNFORMATTED) + MODULE PROCEDURE pruf + END INTERFACE + +CONTAINS + + SUBROUTINE pwuf (dtv,unit,iostat,iomsg) + type(person), INTENT(IN) :: dtv + INTEGER, INTENT(IN) :: unit + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + WRITE (UNIT=UNIT) DTV%name, DTV%age + END SUBROUTINE pwuf + + SUBROUTINE pruf (dtv,unit,iostat,iomsg) + type(person), INTENT(INOUT) :: dtv + INTEGER, INTENT(IN) :: unit + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + READ (UNIT = UNIT) dtv%name, dtv%age + END SUBROUTINE pruf + +END MODULE p + +PROGRAM test + USE p + TYPE (person) :: chairman + character(10) :: line + + chairman%name="Charlie" + chairman%age=62 + + OPEN (UNIT=71, status = 'scratch', FORM='UNFORMATTED') + write (71) chairman + rewind (71) + + chairman%name = "Charles" + chairman%age = 0 + + read (71) chairman + close (unit = 71) + +! Straight comparisons fail at any level of optimization. + + write(line, "(A7)") chairman%name + if (trim (line) .ne. "Charlie") STOP 1 + line = " " + write(line, "(I4)") chairman%age + if (trim (line) .eq. " 62") print *, trim(line) +END PROGRAM test diff --git a/Fortran/gfortran/regression/dtio_9.f90 b/Fortran/gfortran/regression/dtio_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dtio_9.f90 @@ -0,0 +1,66 @@ +! { dg-do run } +! +! Tests dtio of transfer bind-C types. +! +! Note difficulties with c_char at -O1. This is why no character field is used. +! +MODULE p + USE ISO_C_BINDING + TYPE, BIND(C) :: person + integer(c_int) :: id_no + INTEGER(c_int) :: age + END TYPE person + INTERFACE WRITE(UNFORMATTED) + MODULE PROCEDURE pwuf + END INTERFACE + INTERFACE READ(UNFORMATTED) + MODULE PROCEDURE pruf + END INTERFACE + +CONTAINS + + SUBROUTINE pwuf (dtv,unit,iostat,iomsg) + type(person), INTENT(IN) :: dtv + INTEGER, INTENT(IN) :: unit + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + WRITE (UNIT=UNIT) DTV%id_no, DTV%age + END SUBROUTINE pwuf + + SUBROUTINE pruf (dtv,unit,iostat,iomsg) + type(person), INTENT(INOUT) :: dtv + INTEGER, INTENT(IN) :: unit + INTEGER, INTENT(OUT) :: iostat + CHARACTER (LEN=*), INTENT(INOUT) :: iomsg + READ (UNIT = UNIT) dtv%id_no, dtv%age + END SUBROUTINE pruf + +END MODULE p + +PROGRAM test + USE p + TYPE (person) :: chairman + CHARACTER (kind=c_char) :: cname(20) + integer (c_int) :: cage, cid_no + character(10) :: line + + cid_no = 1 + cage = 62 + chairman%id_no = cid_no + chairman%age = cage + + OPEN (UNIT=71, status = 'scratch', FORM='UNFORMATTED') + write (71) chairman + rewind (71) + + chairman%id_no = 0 + chairman%age = 0 + + read (71) chairman + close (unit = 71) + + write(line, "(I4)") chairman%id_no + if (trim (line) .ne. " 1") STOP 1 + write(line, "(I4)") chairman%age + if (trim (line) .ne. " 62") STOP 2 +end program diff --git a/Fortran/gfortran/regression/dummy_derived_typed.f90 b/Fortran/gfortran/regression/dummy_derived_typed.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dummy_derived_typed.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +subroutine s(t) ! { dg-error "Dummy argument" } + type t ! { dg-error "cannot be a derived" } + end type ! { dg-error "Expecting END SUBROUTINE" } +end diff --git a/Fortran/gfortran/regression/dummy_functions_1.f90 b/Fortran/gfortran/regression/dummy_functions_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dummy_functions_1.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! PR 18197: Check that dummy functions with RESULT variable and dimension works. +module innerfun +contains + function f(n,x) result(y) + integer, intent(in) :: n + real, dimension(:), intent(in) :: x + real, dimension(n) :: y + y = 1 + end function f +end module innerfun + +module outerfun +contains + subroutine foo(n,funname) + integer, intent(in) :: n + real, dimension(n) :: y + real, dimension(2) :: x + interface + function funname(n,x) result(y) + integer, intent(in) :: n + real, dimension(:), intent(in) :: x + real, dimension(n) :: y + end function funname + end interface + + y = funname(n, (/ 0.2, 0.3 /) ) + + end subroutine foo +end module outerfun + +program test + use outerfun + use innerfun + call foo(3,f) +end program test diff --git a/Fortran/gfortran/regression/dummy_optional_arg.f90 b/Fortran/gfortran/regression/dummy_optional_arg.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dummy_optional_arg.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! PR fortran/45495 +! +! Code originally submitted by Philip Mason +! +function jack(aa) + character(len=*), intent(in) :: aa + optional :: aa + character(len=len(aa)+1) :: jack ! { dg-error "cannot be OPTIONAL" } + jack = '' +end function jack + +function diane(aa) + character(len=*), intent(out) :: aa + character(len=len(aa)+1) :: diane + diane = '012345678901' + aa = 'abcdefghijklmn' +end function diane diff --git a/Fortran/gfortran/regression/dummy_procedure_1.f90 b/Fortran/gfortran/regression/dummy_procedure_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dummy_procedure_1.f90 @@ -0,0 +1,50 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! Test the patch for PR25098, where passing a variable as an +! actual argument to a formal argument that is a procedure +! went undiagnosed. +! +! Based on contribution by Joost VandeVondele +! +integer function y() + y = 1 +end +integer function z() + z = 1 +end + +module m1 +contains + subroutine s1(f) + interface + function f() + integer f + end function f + end interface + end subroutine s1 + subroutine s2(x) + integer :: x + end subroutine +end module m1 + + use m1 + external y + interface + function x() + integer x + end function x + end interface + + integer :: i, y, z + i=1 + call s1(i) ! { dg-error "Expected a procedure for argument" } + call s1(w) ! { dg-error "used as actual argument" } + call s1(x) ! explicit interface + call s1(y) ! declared external + call s1(z) ! { dg-error "Expected a procedure for argument" } + call s2(x) ! { dg-error "Invalid procedure argument" } +contains + integer function w() + w = 1 + end function w +end diff --git a/Fortran/gfortran/regression/dummy_procedure_10.f90 b/Fortran/gfortran/regression/dummy_procedure_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dummy_procedure_10.f90 @@ -0,0 +1,56 @@ +! { dg-do compile } +! +! PR 35831: [F95] Shape mismatch check missing for dummy procedure argument +! +! Contributed by Janus Weil + +program test_attributes + + call tester1 (a1) ! { dg-error "ASYNCHRONOUS mismatch in argument" } + call tester2 (a2) ! { dg-error "CONTIGUOUS mismatch in argument" } + call tester3 (a1) ! { dg-error "VALUE mismatch in argument" } + call tester4 (a1) ! { dg-error "VOLATILE mismatch in argument" } + +contains + + subroutine a1(aa) + real :: aa + end subroutine + + subroutine a2(bb) + real :: bb(:) + end subroutine + + subroutine tester1 (f1) + interface + subroutine f1 (a) + real, asynchronous :: a + end subroutine + end interface + end subroutine + + subroutine tester2 (f2) + interface + subroutine f2 (b) + real, contiguous :: b(:) + end subroutine + end interface + end subroutine + + subroutine tester3 (f3) + interface + subroutine f3 (c) + real, value :: c + end subroutine + end interface + end subroutine + + subroutine tester4 (f4) + interface + subroutine f4 (d) + real, volatile :: d + end subroutine + end interface + end subroutine + +end diff --git a/Fortran/gfortran/regression/dummy_procedure_11.f90 b/Fortran/gfortran/regression/dummy_procedure_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dummy_procedure_11.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! +! PR 60507: Passing function call into procedure argument not caught +! +! Contributed by Vladimir Fuka + +type :: t + procedure(g), pointer, nopass :: ppc +end type + +procedure(g), pointer :: pp +type(t)::x + +print *, f(g) +print *, f(g()) ! { dg-error "Expected a procedure for argument" } +pp => g +print *, f(pp) +print *, f(pp()) ! { dg-error "Expected a procedure for argument" } +x%ppc => g +print *, f(x%ppc) +print *, f(x%ppc()) ! { dg-error "Expected a procedure for argument" } + +contains + + real function f(fun) + procedure(g) :: fun + f = fun() + end function + + real function g() + g = 1. + end function + +end diff --git a/Fortran/gfortran/regression/dummy_procedure_2.f90 b/Fortran/gfortran/regression/dummy_procedure_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dummy_procedure_2.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! Checks the fix for the bug exposed in fixing PR25147 +! +! Contributed by Tobias Schlueter +! +module integrator + interface + function integrate(f,xmin,xmax) + implicit none + interface + function f(x) + real(8) :: f,x + intent(in) :: x + end function f + end interface + real(8) :: xmin, xmax, integrate + end function integrate + end interface +end module integrator + + use integrator + call foo1 () + call foo2 () +contains + subroutine foo1 () + real(8) :: f ! This was not trapped: PR25147/25098 + print *,integrate (f,0d0,3d0) ! { dg-error "Expected a procedure" } + end subroutine foo1 + subroutine foo2 () + real(8), external :: g ! This would give an error, incorrectly. + print *,integrate (g,0d0,3d0) + end subroutine foo2 +end diff --git a/Fortran/gfortran/regression/dummy_procedure_3.f90 b/Fortran/gfortran/regression/dummy_procedure_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dummy_procedure_3.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! PR37926 - the interface did not transfer the formal +! argument list for the call to 'asz' in the specification of 'p'. +! +! Contributed by Janus Weil +! +module m +contains + pure integer function mysize(a) + integer,intent(in) :: a(:) + mysize = size(a) + end function +end module + +program prog + use m + implicit none + character(3) :: str + integer :: i(3) = (/1,2,3/) + str = p(i,mysize) + if (len(str) .ne. 3) STOP 1 + if (str .ne. "BCD") STOP 2 +contains + function p(y,asz) + implicit none + integer :: y(:) + interface + pure integer function asz(c) + integer,intent(in) :: c(:) + end function + end interface + character(asz(y)) p + integer i + do i=1,asz(y) + p(i:i) = achar(iachar('A')+y(i)) + end do + end function +end diff --git a/Fortran/gfortran/regression/dummy_procedure_4.f90 b/Fortran/gfortran/regression/dummy_procedure_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dummy_procedure_4.f90 @@ -0,0 +1,46 @@ +! { dg-do compile } +! +! PR 46067: [F03] invalid procedure pointer assignment not detected +! +! Contributed by Janus Weil + +module m + + type test_type + integer :: id = 1 + end type + +contains + + real function fun1 (t,x) + real, intent(in) :: x + type(test_type) :: t + print *," id = ", t%id + fun1 = cos(x) + end function + +end module + + + use m + implicit none + + call test (fun1) ! { dg-error "Interface mismatch in dummy procedure" } + +contains + + subroutine test(proc) + interface + real function proc(t,x) + import :: test_type + real, intent(in) :: x + class(test_type) :: t + end function + end interface + type(test_type) :: funs + real :: r + r = proc(funs,0.) + print *, " proc(0) ",r + end subroutine + +end diff --git a/Fortran/gfortran/regression/dummy_procedure_5.f90 b/Fortran/gfortran/regression/dummy_procedure_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dummy_procedure_5.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! +! PR 50517: gfortran must detect that actual argument type is different from dummy argument type (r178939) +! +! Contributed by Vittorio Zecca + +program main + + type t + integer g + end type + + type u + integer g + end type + + type(u), external :: ufunc + call sub(ufunc) ! { dg-error "Type mismatch in function result" } + +contains + + subroutine sub(tfunc) + type(t), external :: tfunc + end subroutine + +end program diff --git a/Fortran/gfortran/regression/dummy_procedure_6.f90 b/Fortran/gfortran/regression/dummy_procedure_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dummy_procedure_6.f90 @@ -0,0 +1,69 @@ +! { dg-do compile } +! +! PR 35381: [F95] Shape mismatch check missing for dummy procedure argument +! +! Contributed by Janus Weil + +module m + + implicit none + +contains + + ! constant array bounds + + subroutine s1(a) + integer :: a(1:2) + end subroutine + + subroutine s2(a) + integer :: a(2:3) + end subroutine + + subroutine s3(a) + integer :: a(2:4) + end subroutine + + ! non-constant array bounds + + subroutine t1(a,b) + integer :: b + integer :: a(1:b,1:b) + end subroutine + + subroutine t2(a,b) + integer :: b + integer :: a(1:b,2:b+1) + end subroutine + + subroutine t3(a,b) + integer :: b + integer :: a(1:b,1:b+1) + end subroutine + +end module + + +program test + use m + implicit none + + call foo(s1) ! legal + call foo(s2) ! legal + call foo(s3) ! { dg-error "Shape mismatch in dimension" } + + call bar(t1) ! legal + call bar(t2) ! legal + call bar(t3) ! { dg-error "Shape mismatch in dimension" } + +contains + + subroutine foo(f) + procedure(s1) :: f + end subroutine + + subroutine bar(f) + procedure(t1) :: f + end subroutine + +end program diff --git a/Fortran/gfortran/regression/dummy_procedure_7.f90 b/Fortran/gfortran/regression/dummy_procedure_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dummy_procedure_7.f90 @@ -0,0 +1,63 @@ +! { dg-do run } +! +! PR fortran/52022 +! + +module check + integer, save :: icheck = 0 +end module check + +module t +implicit none + contains +subroutine sol(cost) + use check + interface + function cost(p) result(y) + double precision,dimension(:) :: p + double precision,dimension(:),allocatable :: y + end function cost + end interface + + if (any (cost([1d0,2d0]) /= [2.d0, 4.d0])) STOP 1 + icheck = icheck + 1 +end subroutine + +end module t + +module tt + procedure(cost1),pointer :: pcost +contains + subroutine init() + pcost=>cost1 + end subroutine + + function cost1(x) result(y) + double precision,dimension(:) :: x + double precision,dimension(:),allocatable :: y + allocate(y(2)) + y=2d0*x + end function cost1 + + + + function cost(x) result(y) + double precision,dimension(:) :: x + double precision,dimension(:),allocatable :: y + allocate(y(2)) + y=pcost(x) + end function cost +end module + +program test + use tt + use t + use check + implicit none + + call init() + if (any (cost([3.d0,7.d0]) /= [6.d0, 14.d0])) STOP 2 + if (icheck /= 0) STOP 3 + call sol(cost) + if (icheck /= 1) STOP 4 +end program test diff --git a/Fortran/gfortran/regression/dummy_procedure_8.f90 b/Fortran/gfortran/regression/dummy_procedure_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dummy_procedure_8.f90 @@ -0,0 +1,84 @@ +! { dg-do compile } +! +! PR 35831: [F95] Shape mismatch check missing for dummy procedure argument +! +! Contributed by Janus Weil + +implicit none + +call call_a(a1) ! { dg-error "Character length mismatch in function result" } +call call_b(b1) ! { dg-error "Shape mismatch" } +call call_c(c1) ! { dg-error "POINTER attribute mismatch in function result" } +call call_d(c1) ! { dg-error "ALLOCATABLE attribute mismatch in function result" } +call call_e(e1) ! { dg-error "CONTIGUOUS attribute mismatch in function result" } +call call_f(c1) ! { dg-error "PROCEDURE POINTER mismatch in function result" } + +contains + + character(1) function a1() + end function + + subroutine call_a(a3) + interface + character(2) function a3() + end function + end interface + end subroutine + + + function b1() + integer, dimension(1:3) :: b1 + end function + + subroutine call_b(b2) + interface + function b2() + integer, dimension(0:4) :: b2 + end function + end interface + end subroutine + + + integer function c1() + end function + + subroutine call_c(c2) + interface + function c2() + integer, pointer :: c2 + end function + end interface + end subroutine + + + subroutine call_d(d2) + interface + function d2() + integer, allocatable :: d2 + end function + end interface + end subroutine + + + function e1() + integer, dimension(:), pointer :: e1 + end function + + subroutine call_e(e2) + interface + function e2() + integer, dimension(:), pointer, contiguous :: e2 + end function + end interface + end subroutine + + + subroutine call_f(f2) + interface + function f2() + procedure(integer), pointer :: f2 + end function + end interface + end subroutine + +end diff --git a/Fortran/gfortran/regression/dummy_procedure_9.f90 b/Fortran/gfortran/regression/dummy_procedure_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dummy_procedure_9.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! +! PR 40453: [F95] Enhanced (recursive) argument checking +! +! Contributed by Tobias Burnus + +program RecursiveInterface + + call c(b2) ! { dg-error "Interface mismatch in dummy procedure" } + + contains + + subroutine a1(x) + real :: x + end subroutine + + subroutine a2(i) + integer :: i + end subroutine + + !!!!!!!!!!!!!!! + + subroutine b1 (f1) + procedure(a1) :: f1 + end subroutine + + subroutine b2 (f2) + procedure(a2) :: f2 + end subroutine + + !!!!!!!!!!!!!!! + + subroutine c(g) + procedure(b1) :: g + end subroutine + +end diff --git a/Fortran/gfortran/regression/dup_save_1.f90 b/Fortran/gfortran/regression/dup_save_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dup_save_1.f90 @@ -0,0 +1,57 @@ +! { dg-do run } +program save_1 + implicit none + integer i + integer foo1, foo2, foo3, foo4 + do i=1,10 + if (foo1().ne.i) then + STOP 1 + end if + if (foo2().ne.i) then + STOP 2 + end if + if (foo3().ne.i) then + STOP 3 + end if + if (foo4().ne.i) then + STOP 4 + end if + end do +end program save_1 + +integer function foo1 () + integer j + save + save ! { dg-warning "Blanket SAVE" } + data j /0/ + j = j + 1 + foo1 = j +end function foo1 + +integer function foo2 () + integer j + save j + save j ! { dg-warning "Duplicate SAVE" } + data j /0/ + j = j + 1 + foo2 = j +end function foo2 + +integer function foo3 () + integer j ! { dg-warning "Duplicate SAVE" } + save + save j ! { dg-warning "SAVE statement" } + data j /0/ + j = j + 1 + foo3 = j +end function foo3 + +integer function foo4 () + integer j ! { dg-warning "Duplicate SAVE" } + save j + save + data j /0/ + j = j + 1 + foo4 = j +end function foo4 + diff --git a/Fortran/gfortran/regression/dup_save_2.f90 b/Fortran/gfortran/regression/dup_save_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dup_save_2.f90 @@ -0,0 +1,57 @@ +! { dg-do compile } +! { dg-options " -std=f95" } +program save_2 + implicit none + integer i + integer foo1, foo2, foo3, foo4 + do i=1,10 + if (foo1().ne.i) then + STOP 1 + end if + if (foo2().ne.i) then + STOP 2 + end if + if (foo3().ne.i) then + STOP 3 + end if + if (foo4().ne.i) then + STOP 4 + end if + end do +end program save_2 + +integer function foo1 () + integer j + save + save ! { dg-error "Blanket SAVE" } + data j /0/ + j = j + 1 + foo1 = j +end function foo1 + +integer function foo2 () + integer j + save j + save j ! { dg-error "Duplicate SAVE" } + data j /0/ + j = j + 1 + foo2 = j +end function foo2 + +integer function foo3 () + integer j + save + save j ! { dg-error "SAVE statement" } + data j /0/ + j = j + 1 + foo3 = j +end function foo3 + +integer function foo4 () + integer j ! { dg-error "Duplicate SAVE" } + save j + save + data j /0/ + j = j + 1 + foo4 = j +end function foo4 diff --git a/Fortran/gfortran/regression/duplicate_labels.f90 b/Fortran/gfortran/regression/duplicate_labels.f90 --- /dev/null +++ b/Fortran/gfortran/regression/duplicate_labels.f90 @@ -0,0 +1,59 @@ +! { dg-do compile } +! PR 21257 +program dups + + integer i,j,k + + abc: do i = 1, 3 + abc: do j = 1, 3 ! { dg-error "Duplicate construct label" } + k = i + j + end do abc + end do abc ! { dg-error "Expecting END PROGRAM" } + + xyz: do i = 1, 2 + k = i + 2 + end do xyz + xyz: do j = 1, 5 ! { dg-error "Duplicate construct label" } + k = j + 2 + end do loop ! { dg-error "Expecting END PROGRAM" } + + her: if (i == 1) then + her: if (j == 1) then ! { dg-error "Duplicate construct label" } + k = i + j + end if her + end if her ! { dg-error "Expecting END PROGRAM" } + + his: if (i == 1) then + i = j + end if his + his: if (j === 1) then ! { dg-error "Duplicate construct label" } + print *, j + end if his ! { dg-error "Expecting END PROGRAM" } + + sgk: select case (i) + case (1) + sgk: select case (j) ! { dg-error "Duplicate construct label" } + case (10) + i = i + j + case (20) + j = j + i + end select sgk + case (2) ! { dg-error "Unexpected CASE statement" } + i = i + 1 + j = j + 1 + end select sgk ! { dg-error "Expecting END PROGRAM" } + + apl: select case (i) + case (1) + k = 2 + case (2) + j = 1 + end select apl + apl: select case (i) ! { dg-error "Duplicate construct label" } + case (1) ! { dg-error "Unexpected CASE statement" } + j = 2 + case (2) ! { dg-error "Unexpected CASE statement" } + k = 1 + end select apl ! { dg-error "Expecting END PROGRAM" } + +end program dups diff --git a/Fortran/gfortran/regression/duplicate_labels_2.f b/Fortran/gfortran/regression/duplicate_labels_2.f --- /dev/null +++ b/Fortran/gfortran/regression/duplicate_labels_2.f @@ -0,0 +1,25 @@ +! { dg-do compile } +! +! PR fortran/50071 +! Duplicate statement labels should not be rejected if they appear in +! different scoping units +! +! Contributed by Vittorio Zecca + +c gfortran complains about duplicate statement labels +c this is a legal program because types have their own scoping units +c and you may have same labels in different scoping units, +c as you may have same identifiers inside, like G. + type t1 +1 integer G + end type + type t2 +1 integer G + end type +c this is legal + goto 1 + print *,'bad' +1 continue + print *,'good' + end + diff --git a/Fortran/gfortran/regression/duplicate_type_1.f90 b/Fortran/gfortran/regression/duplicate_type_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/duplicate_type_1.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-std=f95" } + +! PR fortran/30239 +! Check for errors when a symbol gets declared a type twice, even if it +! is the same. + +INTEGER FUNCTION foo () + IMPLICIT NONE + INTEGER :: foo ! { dg-error "basic type of" } + INTEGER :: foo ! { dg-error "basic type of" } + foo = 42 +END FUNCTION foo + +INTEGER FUNCTION bar () RESULT (x) + IMPLICIT NONE + INTEGER :: x ! { dg-error "basic type of" } + + INTEGER :: y + INTEGER :: y ! { dg-error "basic type of" } + + x = 42 +END FUNCTION bar diff --git a/Fortran/gfortran/regression/duplicate_type_2.f90 b/Fortran/gfortran/regression/duplicate_type_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/duplicate_type_2.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-std=gnu -Wsurprising" } + +! PR fortran/30239 +! Check for errors when a symbol gets declared a type twice, even if it +! is the same. + +INTEGER FUNCTION foo () + IMPLICIT NONE + INTEGER :: foo ! { dg-error "basic type of" } + INTEGER :: foo ! { dg-error "basic type of" } + foo = 42 +END FUNCTION foo + +INTEGER FUNCTION bar () RESULT (x) + IMPLICIT NONE + INTEGER :: x ! { dg-error "basic type of" } + + INTEGER :: y + INTEGER :: y ! { dg-error "basic type of" } + + x = 42 +END FUNCTION bar diff --git a/Fortran/gfortran/regression/duplicate_type_3.f90 b/Fortran/gfortran/regression/duplicate_type_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/duplicate_type_3.f90 @@ -0,0 +1,48 @@ +! { dg-do compile } +! +! PR 39996: Double typing of function results not detected +! +! Contributed by Janus Weil + + interface + real function A () + end function + end interface + real :: A ! { dg-error "already has basic type of" } + + real :: B + interface + real function B () ! { dg-error "already has basic type of" } + end function ! { dg-error "Expecting END INTERFACE statement" } + end interface + + interface + function C () + real :: C + end function + end interface + real :: C ! { dg-error "already has basic type of" } + + real :: D + interface + function D () + real :: D ! { dg-error "already has basic type of" } + end function + end interface + + interface + function E () result (s) + real ::s + end function + end interface + real :: E ! { dg-error "already has basic type of" } + + real :: F + interface + function F () result (s) + real ::s ! { dg-error "already has basic type of" } + end function F + end interface + +end + diff --git a/Fortran/gfortran/regression/dynamic_dispatch_1.f03 b/Fortran/gfortran/regression/dynamic_dispatch_1.f03 --- /dev/null +++ b/Fortran/gfortran/regression/dynamic_dispatch_1.f03 @@ -0,0 +1,78 @@ +! { dg-do run } +! Tests dynamic dispatch of class functions. +! +! Contributed by Paul Thomas +! +module m + type :: t1 + integer :: i = 42 + procedure(make_real), pointer :: ptr + contains + procedure, pass :: real => make_real + procedure, pass :: make_integer + procedure, pass :: prod => i_m_j + generic, public :: extract => real, make_integer + end type t1 + + type, extends(t1) :: t2 + integer :: j = 99 + contains + procedure, pass :: real => make_real2 + procedure, pass :: make_integer => make_integer_2 + procedure, pass :: prod => i_m_j_2 + end type t2 +contains + real function make_real (arg) + class(t1), intent(in) :: arg + make_real = real (arg%i) + end function make_real + + real function make_real2 (arg) + class(t2), intent(in) :: arg + make_real2 = real (arg%j) + end function make_real2 + + integer function make_integer (arg, arg2) + class(t1), intent(in) :: arg + integer :: arg2 + make_integer = arg%i * arg2 + end function make_integer + + integer function make_integer_2 (arg, arg2) + class(t2), intent(in) :: arg + integer :: arg2 + make_integer_2 = arg%j * arg2 + end function make_integer_2 + + integer function i_m_j (arg) + class(t1), intent(in) :: arg + i_m_j = arg%i + end function i_m_j + + integer function i_m_j_2 (arg) + class(t2), intent(in) :: arg + i_m_j_2 = arg%j + end function i_m_j_2 +end module m + + use m + type, extends(t1) :: l1 + character(16) :: chr + end type l1 + class(t1), pointer :: a !=> NULL() + type(t1), target :: b + type(t2), target :: c + type(l1), target :: d + a => b ! declared type + if (a%real() .ne. real (42)) STOP 1 + if (a%prod() .ne. 42) STOP 2 + if (a%extract (2) .ne. 84) STOP 3 + a => c ! extension in module + if (a%real() .ne. real (99)) STOP 4 + if (a%prod() .ne. 99) STOP 5 + if (a%extract (3) .ne. 297) STOP 6 + a => d ! extension in main + if (a%real() .ne. real (42)) STOP 7 + if (a%prod() .ne. 42) STOP 8 + if (a%extract (4) .ne. 168) STOP 9 +end diff --git a/Fortran/gfortran/regression/dynamic_dispatch_10.f03 b/Fortran/gfortran/regression/dynamic_dispatch_10.f03 --- /dev/null +++ b/Fortran/gfortran/regression/dynamic_dispatch_10.f03 @@ -0,0 +1,169 @@ +! { dg-do run } +! +! [OOP] Fortran runtime error: internal error: bad hash value in dynamic dispatch +! +! Contributed by David Car + +module BaseStrategy + + type, public, abstract :: Strategy + contains + procedure(strategy_update), pass( this ), deferred :: update + procedure(strategy_pre_update), pass( this ), deferred :: preUpdate + procedure(strategy_post_update), pass( this ), deferred :: postUpdate + end type Strategy + + abstract interface + subroutine strategy_update( this ) + import Strategy + class (Strategy), target, intent(in) :: this + end subroutine strategy_update + end interface + + abstract interface + subroutine strategy_pre_update( this ) + import Strategy + class (Strategy), target, intent(in) :: this + end subroutine strategy_pre_update + end interface + + abstract interface + subroutine strategy_post_update( this ) + import Strategy + class (Strategy), target, intent(in) :: this + end subroutine strategy_post_update + end interface + +end module BaseStrategy + +!============================================================================== + +module LaxWendroffStrategy + + use BaseStrategy + + private :: update, preUpdate, postUpdate + + type, public, extends( Strategy ) :: LaxWendroff + class (Strategy), pointer :: child => null() + contains + procedure, pass( this ) :: update + procedure, pass( this ) :: preUpdate + procedure, pass( this ) :: postUpdate + end type LaxWendroff + +contains + + subroutine update( this ) + class (LaxWendroff), target, intent(in) :: this + + print *, 'Calling LaxWendroff update' + end subroutine update + + subroutine preUpdate( this ) + class (LaxWendroff), target, intent(in) :: this + + print *, 'Calling LaxWendroff preUpdate' + end subroutine preUpdate + + subroutine postUpdate( this ) + class (LaxWendroff), target, intent(in) :: this + + print *, 'Calling LaxWendroff postUpdate' + end subroutine postUpdate + +end module LaxWendroffStrategy + +!============================================================================== + +module KEStrategy + + use BaseStrategy + ! Uncomment the line below and it runs fine + ! use LaxWendroffStrategy + + private :: update, preUpdate, postUpdate + + type, public, extends( Strategy ) :: KE + class (Strategy), pointer :: child => null() + contains + procedure, pass( this ) :: update + procedure, pass( this ) :: preUpdate + procedure, pass( this ) :: postUpdate + end type KE + +contains + + subroutine init( this, other ) + class (KE), intent(inout) :: this + class (Strategy), target, intent(in) :: other + + this % child => other + end subroutine init + + subroutine update( this ) + class (KE), target, intent(in) :: this + + if ( associated( this % child ) ) then + call this % child % update() + end if + + print *, 'Calling KE update' + end subroutine update + + subroutine preUpdate( this ) + class (KE), target, intent(in) :: this + + if ( associated( this % child ) ) then + call this % child % preUpdate() + end if + + print *, 'Calling KE preUpdate' + end subroutine preUpdate + + subroutine postUpdate( this ) + class (KE), target, intent(in) :: this + + if ( associated( this % child ) ) then + call this % child % postUpdate() + end if + + print *, 'Calling KE postUpdate' + end subroutine postUpdate + +end module KEStrategy + +!============================================================================== + +program main + + use LaxWendroffStrategy + use KEStrategy + + type :: StratSeq + class (Strategy), pointer :: strat => null() + end type StratSeq + + type (LaxWendroff), target :: lw_strat + type (KE), target :: ke_strat + + type (StratSeq), allocatable, dimension( : ) :: seq + + allocate( seq(10) ) + + call init( ke_strat, lw_strat ) + call ke_strat % preUpdate() + call ke_strat % update() + call ke_strat % postUpdate() + ! call lw_strat % update() + + seq( 1 ) % strat => ke_strat + seq( 2 ) % strat => lw_strat + + call seq( 1 ) % strat % update() + + do i = 1, 2 + call seq( i ) % strat % update() + end do + +end diff --git a/Fortran/gfortran/regression/dynamic_dispatch_11.f03 b/Fortran/gfortran/regression/dynamic_dispatch_11.f03 --- /dev/null +++ b/Fortran/gfortran/regression/dynamic_dispatch_11.f03 @@ -0,0 +1,32 @@ +! { dg-do run } +! +! PR 42769: [OOP] ICE in resolve_typebound_procedure +! comment #27 +! +! Contributed by Janus Weil + + +module mod1 + type :: t1 + contains + procedure, nopass :: get => my_get + end type +contains + integer function my_get() + my_get = 1 + end function +end module + +module mod2 +contains + integer function my_get() ! must have the same name as the function in mod1 + my_get = 2 + end function +end module + + use mod2 + use mod1 ! order of use statements is important + class(t1),allocatable :: a + allocate(a) + if (a%get()/=1) STOP 1 +end diff --git a/Fortran/gfortran/regression/dynamic_dispatch_12.f90 b/Fortran/gfortran/regression/dynamic_dispatch_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/dynamic_dispatch_12.f90 @@ -0,0 +1,72 @@ +! { dg-do run } +! +! PR 59654: [4.8/4.9 Regression] [OOP] Broken function table with complex OO use case +! +! Contributed by Thomas Clune + +module TestResult_mod + implicit none + + type TestResult + integer :: numRun = 0 + contains + procedure :: run + procedure, nopass :: getNumRun + end type + +contains + + subroutine run (this) + class (TestResult) :: this + this%numRun = this%numRun + 1 + end subroutine + + subroutine getNumRun() + end subroutine + +end module + + +module BaseTestRunner_mod + implicit none + + type :: BaseTestRunner + contains + procedure, nopass :: norun + end type + +contains + + function norun () result(result) + use TestResult_mod, only: TestResult + type (TestResult) :: result + end function + +end module + + +module TestRunner_mod + use BaseTestRunner_mod, only: BaseTestRunner + implicit none +end module + + +program main + use TestRunner_mod, only: BaseTestRunner + use TestResult_mod, only: TestResult + implicit none + + type (TestResult) :: result + + call runtest (result) + +contains + + subroutine runtest (result) + use TestResult_mod, only: TestResult + class (TestResult) :: result + call result%run() + if (result%numRun /= 1) STOP 1 + end subroutine + +end diff --git a/Fortran/gfortran/regression/dynamic_dispatch_2.f03 b/Fortran/gfortran/regression/dynamic_dispatch_2.f03 --- /dev/null +++ b/Fortran/gfortran/regression/dynamic_dispatch_2.f03 @@ -0,0 +1,96 @@ +! { dg-do run } +! Tests dynamic dispatch of class subroutines. +! +! Contributed by Paul Thomas +! +module m + type :: t1 + integer :: i = 42 + procedure(make_real), pointer :: ptr + contains + procedure, pass :: real => make_real + procedure, pass :: make_integer + procedure, pass :: prod => i_m_j + generic, public :: extract => real, make_integer + end type t1 + + type, extends(t1) :: t2 + integer :: j = 99 + contains + procedure, pass :: real => make_real2 + procedure, pass :: make_integer => make_integer_2 + procedure, pass :: prod => i_m_j_2 + end type t2 +contains + subroutine make_real (arg, arg2) + class(t1), intent(in) :: arg + real :: arg2 + arg2 = real (arg%i) + end subroutine make_real + + subroutine make_real2 (arg, arg2) + class(t2), intent(in) :: arg + real :: arg2 + arg2 = real (arg%j) + end subroutine make_real2 + + subroutine make_integer (arg, arg2, arg3) + class(t1), intent(in) :: arg + integer :: arg2, arg3 + arg3 = arg%i * arg2 + end subroutine make_integer + + subroutine make_integer_2 (arg, arg2, arg3) + class(t2), intent(in) :: arg + integer :: arg2, arg3 + arg3 = arg%j * arg2 + end subroutine make_integer_2 + + subroutine i_m_j (arg, arg2) + class(t1), intent(in) :: arg + integer :: arg2 + arg2 = arg%i + end subroutine i_m_j + + subroutine i_m_j_2 (arg, arg2) + class(t2), intent(in) :: arg + integer :: arg2 + arg2 = arg%j + end subroutine i_m_j_2 +end module m + + use m + type, extends(t1) :: l1 + character(16) :: chr + end type l1 + class(t1), pointer :: a !=> NULL() + type(t1), target :: b + type(t2), target :: c + type(l1), target :: d + real :: r + integer :: i + + a => b ! declared type + call a%real(r) + if (r .ne. real (42)) STOP 1 + call a%prod(i) + if (i .ne. 42) STOP 2 + call a%extract (2, i) + if (i .ne. 84) STOP 3 + + a => c ! extension in module + call a%real(r) + if (r .ne. real (99)) STOP 4 + call a%prod(i) + if (i .ne. 99) STOP 5 + call a%extract (3, i) + if (i .ne. 297) STOP 6 + + a => d ! extension in main + call a%real(r) + if (r .ne. real (42)) STOP 7 + call a%prod(i) + if (i .ne. 42) STOP 8 + call a%extract (4, i) + if (i .ne. 168) STOP 9 +end diff --git a/Fortran/gfortran/regression/dynamic_dispatch_3.f03 b/Fortran/gfortran/regression/dynamic_dispatch_3.f03 --- /dev/null +++ b/Fortran/gfortran/regression/dynamic_dispatch_3.f03 @@ -0,0 +1,85 @@ +! { dg-do run } +! Tests dynamic dispatch of class functions, spread over +! different modules. Apart from the location of the derived +! type declarations, this test is the same as +! dynamic_dispatch_1.f03 +! +! Contributed by Paul Thomas +! +module m1 + type :: t1 + integer :: i = 42 + procedure(make_real), pointer :: ptr + contains + procedure, pass :: real => make_real + procedure, pass :: make_integer + procedure, pass :: prod => i_m_j + generic, public :: extract => real, make_integer + end type t1 +contains + real function make_real (arg) + class(t1), intent(in) :: arg + make_real = real (arg%i) + end function make_real + + integer function make_integer (arg, arg2) + class(t1), intent(in) :: arg + integer :: arg2 + make_integer = arg%i * arg2 + end function make_integer + + integer function i_m_j (arg) + class(t1), intent(in) :: arg + i_m_j = arg%i + end function i_m_j +end module m1 + +module m2 + use m1 + type, extends(t1) :: t2 + integer :: j = 99 + contains + procedure, pass :: real => make_real2 + procedure, pass :: make_integer => make_integer_2 + procedure, pass :: prod => i_m_j_2 + end type t2 +contains + real function make_real2 (arg) + class(t2), intent(in) :: arg + make_real2 = real (arg%j) + end function make_real2 + + integer function make_integer_2 (arg, arg2) + class(t2), intent(in) :: arg + integer :: arg2 + make_integer_2 = arg%j * arg2 + end function make_integer_2 + + integer function i_m_j_2 (arg) + class(t2), intent(in) :: arg + i_m_j_2 = arg%j + end function i_m_j_2 +end module m2 + + use m1 + use m2 + type, extends(t1) :: l1 + character(16) :: chr + end type l1 + class(t1), pointer :: a !=> NULL() + type(t1), target :: b + type(t2), target :: c + type(l1), target :: d + a => b ! declared type in module m1 + if (a%real() .ne. real (42)) STOP 1 + if (a%prod() .ne. 42) STOP 2 + if (a%extract (2) .ne. 84) STOP 3 + a => c ! extension in module m2 + if (a%real() .ne. real (99)) STOP 4 + if (a%prod() .ne. 99) STOP 5 + if (a%extract (3) .ne. 297) STOP 6 + a => d ! extension in main + if (a%real() .ne. real (42)) STOP 7 + if (a%prod() .ne. 42) STOP 8 + if (a%extract (4) .ne. 168) STOP 9 +end diff --git a/Fortran/gfortran/regression/dynamic_dispatch_4.f03 b/Fortran/gfortran/regression/dynamic_dispatch_4.f03 --- /dev/null +++ b/Fortran/gfortran/regression/dynamic_dispatch_4.f03 @@ -0,0 +1,94 @@ +! { dg-do run } +! Tests the fix for PR41648 in which the reference a%a%getit () was wrongly +! identified as a recursive call to getit. +! +! Contributed by Salvatore Filippone +! +module foo_mod + type foo + integer :: i + contains + procedure, pass(a) :: doit + procedure, pass(a) :: getit + end type foo + + private doit,getit +contains + subroutine doit(a) + class(foo) :: a + + a%i = 1 + end subroutine doit + function getit(a) result(res) + class(foo) :: a + integer :: res + + res = a%i + end function getit + +end module foo_mod + +module s_bar_mod + use foo_mod + type, extends(foo) :: s_bar + type(foo), allocatable :: a + contains + procedure, pass(a) :: doit + procedure, pass(a) :: getit + end type s_bar + private doit,getit + +contains + subroutine doit(a) + class(s_bar) :: a + allocate (a%a) + call a%a%doit() + end subroutine doit + function getit(a) result(res) + class(s_bar) :: a + integer :: res + + res = a%a%getit () * 2 + end function getit +end module s_bar_mod + +module a_bar_mod + use foo_mod + type, extends(foo) :: a_bar + type(foo), allocatable :: a(:) + contains + procedure, pass(a) :: doit + procedure, pass(a) :: getit + end type a_bar + private doit,getit + +contains + subroutine doit(a) + class(a_bar) :: a + allocate (a%a(1)) + call a%a(1)%doit () + end subroutine doit + function getit(a) result(res) + class(a_bar) :: a + integer :: res + + res = a%a(1)%getit () * 3 + end function getit +end module a_bar_mod + + use s_bar_mod + use a_bar_mod + type(foo), target :: b + type(s_bar), target :: c + type(a_bar), target :: d + class(foo), pointer :: a + a => b + call a%doit + if (a%getit () .ne. 1) STOP 1 + a => c + call a%doit + if (a%getit () .ne. 2) STOP 2 + a => d + call a%doit + if (a%getit () .ne. 3) STOP 3 +end diff --git a/Fortran/gfortran/regression/dynamic_dispatch_5.f03 b/Fortran/gfortran/regression/dynamic_dispatch_5.f03 --- /dev/null +++ b/Fortran/gfortran/regression/dynamic_dispatch_5.f03 @@ -0,0 +1,185 @@ +! { dg-do run } +! Tests the fix for PR4164656 in which the call to a%a%scal failed to compile. +! +! Contributed by Salvatore Filippone +! +module const_mod + integer, parameter :: longndig=12 + integer, parameter :: long_int_k_ = selected_int_kind(longndig) + integer, parameter :: dpk_ = kind(1.d0) + integer, parameter :: spk_ = kind(1.e0) +end module const_mod + +module base_mat_mod + use const_mod + type :: base_sparse_mat + integer, private :: m, n + integer, private :: state, duplicate + logical, private :: triangle, unitd, upper, sorted + contains + procedure, pass(a) :: get_nzeros + end type base_sparse_mat + private :: get_nzeros +contains + function get_nzeros(a) result(res) + implicit none + class(base_sparse_mat), intent(in) :: a + integer :: res + integer :: err_act + character(len=20) :: name='base_get_nzeros' + logical, parameter :: debug=.false. + res = -1 + end function get_nzeros +end module base_mat_mod + +module s_base_mat_mod + use base_mat_mod + type, extends(base_sparse_mat) :: s_base_sparse_mat + contains + procedure, pass(a) :: s_scals + procedure, pass(a) :: s_scal + generic, public :: scal => s_scals, s_scal + end type s_base_sparse_mat + private :: s_scals, s_scal + + type, extends(s_base_sparse_mat) :: s_coo_sparse_mat + + integer :: nnz + integer, allocatable :: ia(:), ja(:) + real(spk_), allocatable :: val(:) + contains + procedure, pass(a) :: get_nzeros => s_coo_get_nzeros + procedure, pass(a) :: s_scals => s_coo_scals + procedure, pass(a) :: s_scal => s_coo_scal + end type s_coo_sparse_mat + private :: s_coo_scals, s_coo_scal, s_coo_get_nzeros +contains + subroutine s_scals(d,a,info) + implicit none + class(s_base_sparse_mat), intent(inout) :: a + real(spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='s_scals' + logical, parameter :: debug=.false. + + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + end subroutine s_scals + + + subroutine s_scal(d,a,info) + implicit none + class(s_base_sparse_mat), intent(inout) :: a + real(spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act + character(len=20) :: name='s_scal' + logical, parameter :: debug=.false. + + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 700 + end subroutine s_scal + + function s_coo_get_nzeros(a) result(res) + implicit none + class(s_coo_sparse_mat), intent(in) :: a + integer :: res + res = a%nnz + end function s_coo_get_nzeros + + + subroutine s_coo_scal(d,a,info) + use const_mod + implicit none + class(s_coo_sparse_mat), intent(inout) :: a + real(spk_), intent(in) :: d(:) + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + info = 0 + do i=1,a%get_nzeros() + j = a%ia(i) + a%val(i) = a%val(i) * d(j) + enddo + end subroutine s_coo_scal + + subroutine s_coo_scals(d,a,info) + use const_mod + implicit none + class(s_coo_sparse_mat), intent(inout) :: a + real(spk_), intent(in) :: d + integer, intent(out) :: info + + Integer :: err_act,mnm, i, j, m + character(len=20) :: name='scal' + logical, parameter :: debug=.false. + + info = 0 + do i=1,a%get_nzeros() + a%val(i) = a%val(i) * d + enddo + end subroutine s_coo_scals +end module s_base_mat_mod + +module s_mat_mod + use s_base_mat_mod + type :: s_sparse_mat + class(s_base_sparse_mat), pointer :: a + contains + procedure, pass(a) :: s_scals + procedure, pass(a) :: s_scal + generic, public :: scal => s_scals, s_scal + end type s_sparse_mat + interface scal + module procedure s_scals, s_scal + end interface +contains + subroutine s_scal(d,a,info) + use const_mod + implicit none + class(s_sparse_mat), intent(inout) :: a + real(spk_), intent(in) :: d(:) + integer, intent(out) :: info + integer :: err_act + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. + print *, "s_scal" + call a%a%scal(d,info) + return + end subroutine s_scal + + subroutine s_scals(d,a,info) + use const_mod + implicit none + class(s_sparse_mat), intent(inout) :: a + real(spk_), intent(in) :: d + integer, intent(out) :: info + integer :: err_act + character(len=20) :: name='csnmi' + logical, parameter :: debug=.false. +! print *, "s_scals" + info = 0 + call a%a%scal(d,info) + return + end subroutine s_scals +end module s_mat_mod + + use s_mat_mod + class (s_sparse_mat), pointer :: a + type (s_sparse_mat), target :: b + type (s_base_sparse_mat), target :: c + integer info + b%a => c + a => b + call a%scal (1.0_spk_, info) + if (info .ne. 700) STOP 1 +end diff --git a/Fortran/gfortran/regression/dynamic_dispatch_6.f03 b/Fortran/gfortran/regression/dynamic_dispatch_6.f03 --- /dev/null +++ b/Fortran/gfortran/regression/dynamic_dispatch_6.f03 @@ -0,0 +1,67 @@ +! { dg-do run } +! +! PR 42144: [OOP] deferred TBPs do not work +! +! Contributed by Damian Rouson + +module field_module + implicit none + private + public :: field + type ,abstract :: field + end type +end module + +module periodic_5th_order_module + use field_module ,only : field + implicit none + type ,extends(field) :: periodic_5th_order + end type +end module + +module field_factory_module + implicit none + private + public :: field_factory + type, abstract :: field_factory + contains + procedure(create_interface), deferred :: create + end type + abstract interface + function create_interface(this) + use field_module ,only : field + import :: field_factory + class(field_factory), intent(in) :: this + class(field) ,pointer :: create_interface + end function + end interface +end module + +module periodic_5th_factory_module + use field_factory_module , only : field_factory + implicit none + private + public :: periodic_5th_factory + type, extends(field_factory) :: periodic_5th_factory + contains + procedure :: create=>new_periodic_5th_order + end type +contains + function new_periodic_5th_order(this) + use field_module ,only : field + use periodic_5th_order_module ,only : periodic_5th_order + class(periodic_5th_factory), intent(in) :: this + class(field) ,pointer :: new_periodic_5th_order + end function +end module + +program main + use field_module ,only : field + use field_factory_module ,only : field_factory + use periodic_5th_factory_module ,only : periodic_5th_factory + implicit none + class(field) ,pointer :: u + class(field_factory), allocatable :: field_creator + allocate (periodic_5th_factory :: field_creator) + u => field_creator%create() +end program diff --git a/Fortran/gfortran/regression/dynamic_dispatch_7.f03 b/Fortran/gfortran/regression/dynamic_dispatch_7.f03 --- /dev/null +++ b/Fortran/gfortran/regression/dynamic_dispatch_7.f03 @@ -0,0 +1,59 @@ +! { dg-do run } +! Test the fix for PR43291, which was a regression that caused +! incorrect type mismatch errors at line 46. In the course of +! fixing the PR, it was noted that the dynamic dispatch of the +! final typebound call was not occurring - hence the dg-do run. +! +! Contributed by Janus Weil +! +module m1 + type :: t1 + contains + procedure :: sizeof + end type +contains + integer function sizeof(a) + class(t1) :: a + sizeof = 1 + end function sizeof +end module + +module m2 + use m1 + type, extends(t1) :: t2 + contains + procedure :: sizeof => sizeof2 + end type +contains + integer function sizeof2(a) + class(t2) :: a + sizeof2 = 2 + end function +end module + +module m3 + use m2 + type :: t3 + class(t1), pointer :: a + contains + procedure :: sizeof => sizeof3 + end type +contains + integer function sizeof3(a) + class(t3) :: a + sizeof3 = a%a%sizeof() + end function +end module + + use m1 + use m2 + use m3 + type(t1), target :: x + type(t2), target :: y + type(t3) :: z + z%a => x + if ((z%sizeof() .ne. 1) .or. (z%a%sizeof() .ne. 1)) STOP 1 + z%a => y + if ((z%sizeof() .ne. 2) .or. (z%a%sizeof() .ne. 2)) STOP 2 +end + diff --git a/Fortran/gfortran/regression/dynamic_dispatch_8.f03 b/Fortran/gfortran/regression/dynamic_dispatch_8.f03 --- /dev/null +++ b/Fortran/gfortran/regression/dynamic_dispatch_8.f03 @@ -0,0 +1,105 @@ +! { dg-do run } +! +! PR 41829: [OOP] Runtime error with dynamic dispatching. Tests +! dynamic dispatch in a case where the caller knows nothing about +! the dynamic type at compile time. +! +! Contributed by Salvatore Filippone +! +module foo_mod + type foo + integer :: i + contains + procedure, pass(a) :: doit + procedure, pass(a) :: getit + end type foo + + private doit,getit +contains + subroutine doit(a) + class(foo) :: a + + a%i = 1 +! write(*,*) 'FOO%DOIT base version' + end subroutine doit + function getit(a) result(res) + class(foo) :: a + integer :: res + + res = a%i + end function getit + +end module foo_mod +module foo2_mod + use foo_mod + + type, extends(foo) :: foo2 + integer :: j + contains + procedure, pass(a) :: doit => doit2 + procedure, pass(a) :: getit => getit2 + end type foo2 + + private doit2, getit2 + +contains + + subroutine doit2(a) + class(foo2) :: a + + a%i = 2 + a%j = 3 +! write(*,*) 'FOO2%DOIT derived version' + end subroutine doit2 + function getit2(a) result(res) + class(foo2) :: a + integer :: res + + res = a%j + end function getit2 + +end module foo2_mod + +module bar_mod + use foo_mod + type bar + class(foo), allocatable :: a + contains + procedure, pass(a) :: doit + procedure, pass(a) :: getit + end type bar + private doit,getit + +contains + subroutine doit(a) + class(bar) :: a + + call a%a%doit() + end subroutine doit + function getit(a) result(res) + class(bar) :: a + integer :: res + + res = a%a%getit() + end function getit +end module bar_mod + + +program testd10 + use foo_mod + use foo2_mod + use bar_mod + + type(bar) :: a + + allocate(foo :: a%a) + call a%doit() +! write(*,*) 'Getit value : ', a%getit() + if (a%getit() .ne. 1) STOP 1 + deallocate(a%a) + allocate(foo2 :: a%a) + call a%doit() +! write(*,*) 'Getit value : ', a%getit() + if (a%getit() .ne. 3) STOP 2 + +end program testd10 diff --git a/Fortran/gfortran/regression/dynamic_dispatch_9.f03 b/Fortran/gfortran/regression/dynamic_dispatch_9.f03 --- /dev/null +++ b/Fortran/gfortran/regression/dynamic_dispatch_9.f03 @@ -0,0 +1,51 @@ +! { dg-do run } +! +! [OOP] Ensure that different specifc interfaces are +! handled properly by dynamic dispatch. +! +! Contributed by Salvatore Filippone +! +module m + + type :: t + contains + procedure :: a + generic :: gen => a + end type + + type,extends(t) :: t2 + contains + procedure :: b + generic :: gen => b + end type + +contains + + real function a(ct,x) + class(t) :: ct + real :: x + a=2*x + end function + + integer function b(ct,x) + class(t2) :: ct + integer :: x + b=3*x + end function + +end + + + use m + class(t), allocatable :: o1 + type (t) :: t1 + class(t2), allocatable :: o2 + + allocate(o1) + allocate(o2) + + if (t1%gen(2.0) .ne. o1%gen(2.0)) STOP 1 + if (t1%gen(2.0) .ne. o2%gen(2.0)) STOP 2 + if (o2%gen(3) .ne. 9) STOP 3 + +end diff --git a/Fortran/gfortran/regression/e_d_fmt.f90 b/Fortran/gfortran/regression/e_d_fmt.f90 --- /dev/null +++ b/Fortran/gfortran/regression/e_d_fmt.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! Verify that the D format uses 'D' as the exponent character. +! " " " E " " 'E' " " " " +CHARACTER*10 c1, c2 +REAL(kind=8) r +r = 1.0 +write(c1,"(e9.2)") r +write(c2,"(d9.2)") r + +if (trim(adjustl(c1)) .ne. "0.10E+01") STOP 1 +if (trim(adjustl(c2)) .ne. "0.10D+01") STOP 2 + +END diff --git a/Fortran/gfortran/regression/edit_real_1.f90 b/Fortran/gfortran/regression/edit_real_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/edit_real_1.f90 @@ -0,0 +1,78 @@ +! { dg-do run } +! Check real value edit descriptors +! Also checks that rounding is performed correctly +program edit_real_1 + character(len=20) s + character(len=20) x + character(len=200) t + parameter (x = "xxxxxxxxxxxxxxxxxxxx") + + ! W append a "z" onto each test to check the field is the correct width + s = x + ! G -> F format + write (s, '(G10.3,A)') 12.36, "z" + if (s .ne. " 12.4 z") STOP 1 + s = x + ! G -> E format + write (s, '(G10.3,A)') -0.0012346, "z" + if (s .ne. "-0.123E-02z") STOP 2 + s = x + ! Gw.eEe format + write (s, '(G10.3e1,a)') 12.34, "z" + if (s .ne. " 12.3 z") STOP 3 + ! E format with excessive precision + write (t, '(E199.192,A)') 1.5, "z" + if ((t(1:7) .ne. " 0.1500") .or. (t(194:200) .ne. "00E+01z")) STOP 4 + ! EN format + s = x + write (s, '(EN15.3,A)') 12873.6, "z" + if (s .ne. " 12.874E+03z") STOP 5 + ! EN format, negative exponent + s = x + write (s, '(EN15.3,A)') 12.345e-6, "z" + if (s .ne. " 12.345E-06z") STOP 6 + ! ES format + s = x + write (s, '(ES10.3,A)') 16.235, "z" + if (s .ne. " 1.624E+01z") STOP 7 + ! F format, small number + s = x + write (s, '(F10.8,A)') 1.0e-20, "z" + if (s .ne. "0.00000000z") STOP 8 + ! E format, very large number. + ! Used to overflow with positive scale factor + s = x + write (s, '(1PE10.3,A)') huge(0d0), "z" + ! The actual value is target specific, so just do a basic check + if ((s(1:1) .eq. "*") .or. (s(7:7) .ne. "+") .or. & + (s(11:11) .ne. "z")) STOP 9 + ! F format, round up with carry to most significant digit. + s = x + write (s, '(F10.3,A)') 0.9999, "z" + if (s .ne. " 1.000z") STOP 10 + ! F format, round up with carry to most significant digit < 0.1. + s = x + write (s, '(F10.3,A)') 0.0099, "z" + if (s .ne. " 0.010z") STOP 11 + ! E format, round up with carry to most significant digit. + s = x + write (s, '(E10.3,A)') 0.9999, "z" + if (s .ne. " 0.100E+01z") STOP 12 + ! EN format, round up with carry to most significant digit. + s = x + write (s, '(EN15.3,A)') 999.9999, "z" + if (s .ne. " 1.000E+03z") STOP 13 + ! E format, positive scale factor + s = x + write (s, '(2PE10.4,A)') 1.2345, "z" + if (s .ne. '12.345E-01z') STOP 14 + ! E format, negative scale factor + s = x + write (s, '(-2PE10.4,A)') 1.250001, "z" + if (s .ne. '0.0013E+03z') STOP 15 + ! E format, single digit precision + s = x + write (s, '(E10.1,A)') 1.1, "z" + if (s .ne. ' 0.1E+01z') STOP 16 +end + diff --git a/Fortran/gfortran/regression/elemental_args_check_1.f90 b/Fortran/gfortran/regression/elemental_args_check_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_args_check_1.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! PR fortran/33343 +! +! Check conformance of array actual arguments to +! elemental function. +! +! Contributed by Mikael Morin +! + module geometry + implicit none + integer, parameter :: prec = 8 + integer, parameter :: length = 10 + contains + elemental function Mul(a, b) + real(kind=prec) :: a + real(kind=prec) :: b, Mul + intent(in) :: a, b + Mul = a * b + end function Mul + + pure subroutine calcdAcc2(vectors, angles) + real(kind=prec), dimension(:) :: vectors + real(kind=prec), dimension(size(vectors),2) :: angles + intent(in) :: vectors, angles + real(kind=prec), dimension(size(vectors)) :: ax + real(kind=prec), dimension(size(vectors),2) :: tmpAcc + tmpAcc(1,:) = Mul(angles(1,1:2),ax(1)) ! Ok + tmpAcc(:,1) = Mul(angles(:,1),ax) ! OK + tmpAcc(:,:) = Mul(angles(:,:),ax) ! { dg-error "Incompatible ranks in elemental procedure" } + end subroutine calcdAcc2 + end module geometry diff --git a/Fortran/gfortran/regression/elemental_args_check_2.f90 b/Fortran/gfortran/regression/elemental_args_check_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_args_check_2.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! PR fortran/34660 +! +! Check for elemental constrain C1277 (F2003). +! Contributed by Joost VandeVondele. +! +MODULE M1 +IMPLICIT NONE +CONTAINS + PURE ELEMENTAL SUBROUTINE S1(I,F) + INTEGER, INTENT(IN) :: I + INTERFACE + PURE INTEGER FUNCTION F(I) ! { dg-error "Dummy procedure 'f' not allowed in elemental procedure" } + INTEGER, INTENT(IN) :: I + END FUNCTION F + END INTERFACE + END SUBROUTINE S1 +END MODULE M1 diff --git a/Fortran/gfortran/regression/elemental_args_check_3.f90 b/Fortran/gfortran/regression/elemental_args_check_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_args_check_3.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } + +! Check for constraints restricting arguments of ELEMENTAL procedures. + +! Contributed by Daniel Kraft, d@domob.eu. + +PROGRAM main + IMPLICIT NONE + +CONTAINS + + IMPURE ELEMENTAL SUBROUTINE foobar & + (a, & ! { dg-error "must be scalar" } + b, & ! { dg-error "POINTER attribute" } + c, & ! { dg-error "ALLOCATABLE attribute" } + d) ! { dg-error "must have its INTENT specified or have the VALUE attribute" } + INTEGER, INTENT(IN) :: a(:) + INTEGER, POINTER, INTENT(IN) :: b + INTEGER, ALLOCATABLE, INTENT(IN) :: c + INTEGER :: d + END SUBROUTINE foobar + +END PROGRAM main diff --git a/Fortran/gfortran/regression/elemental_args_check_4.f90 b/Fortran/gfortran/regression/elemental_args_check_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_args_check_4.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! +! PR 50547: dummy procedure argument of PURE shall be PURE +! +! Contributed by Janus Weil + +elemental function fun (sub) + interface + pure subroutine sub ! { dg-error "not allowed in elemental procedure" } + end subroutine + end interface +end function diff --git a/Fortran/gfortran/regression/elemental_args_check_5.f90 b/Fortran/gfortran/regression/elemental_args_check_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_args_check_5.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! + type t + end type t + type t2 + end type t2 +contains +elemental subroutine foo0(v) ! OK + class(t), intent(in) :: v +end subroutine + +elemental subroutine foo1(w) ! { dg-error "Argument 'w' of elemental procedure at .1. cannot have the ALLOCATABLE attribute" } + class(t), allocatable, intent(in) :: w +end subroutine + +elemental subroutine foo2(x) ! { dg-error "Argument 'x' of elemental procedure at .1. cannot have the POINTER attribute" } + class(t), pointer, intent(in) :: x +end subroutine + +elemental subroutine foo3(y) ! { dg-error "Coarray dummy argument 'y' at .1. to elemental procedure" } + class(t2), intent(in) :: y[*] +end subroutine + +elemental subroutine foo4(z) ! { dg-error "Argument 'z' of elemental procedure at .1. must be scalar" } + class(t), intent(in) :: z(:) +end subroutine + +end diff --git a/Fortran/gfortran/regression/elemental_args_check_6.f90 b/Fortran/gfortran/regression/elemental_args_check_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_args_check_6.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/52013 +! +type t +end type t +contains + elemental subroutine f(x) + class(t), intent(inout) :: x ! Valid + end subroutine + elemental subroutine g(y) ! { dg-error "Coarray dummy argument 'y' at .1. to elemental procedure" } + class(t), intent(inout) :: y[*] + end subroutine +end diff --git a/Fortran/gfortran/regression/elemental_args_check_7.f90 b/Fortran/gfortran/regression/elemental_args_check_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_args_check_7.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! +! PR fortran/55638 +! +! Additionally, VALUE no INTENT is required (and only "intent(in)" allowed) +! + + elemental subroutine foo(x, y, z) + integer, intent(inout) :: x + integer, VALUE :: y + integer, VALUE, intent(in) :: z + x = y + end subroutine foo + + impure elemental subroutine foo2(x, y, z) ! { dg-error "Argument 'x' of elemental procedure 'foo2' at .1. must have its INTENT specified or have the VALUE attribute" } + integer :: x + integer, VALUE :: y + integer, VALUE :: z + x = y + end subroutine foo2 + + subroutine foo3(x, y, z) + integer, VALUE, intent(in) :: x + integer, VALUE, intent(inout) :: y ! { dg-error "VALUE attribute conflicts with INTENT.INOUT. attribute" } + integer, VALUE, intent(out) :: z ! { dg-error "VALUE attribute conflicts with INTENT.OUT. attribute" } + end subroutine foo3 diff --git a/Fortran/gfortran/regression/elemental_assignment_1.f90 b/Fortran/gfortran/regression/elemental_assignment_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_assignment_1.f90 @@ -0,0 +1,59 @@ +! { dg-do run } +! PR 67539 - this used to give a segfault at runtime. +! Test case by "mrestelli". + +module m + implicit none + + type :: t_a + real, allocatable :: x + end type t_a + + interface assignment(=) + module procedure copy_t_a + end interface + +contains + + elemental subroutine copy_t_a(y,x) + type(t_a), intent(in) :: x + type(t_a), intent(out) :: y + allocate( y%x , source=x%x ) + end subroutine copy_t_a + + elemental function new_t_a(x) result(res) + real, intent(in) :: x + type(t_a) :: res + allocate( res%x ) + res%x = x + end function new_t_a + +end module m + + +program p + use m + implicit none + + integer :: i + type(t_a) :: tmp + type(t_a), allocatable :: v(:) + + allocate( v(2) ) + + v = new_t_a(1.5) ! -> segmentation fault + + !tmp = new_t_a(1.5) ! -> OK + !v = tmp + + !do i=1,size(v) ! -> also OK + ! v(i) = new_t_a(1.5) + !enddo + + do i=1,size(v) + write(*,*) " i = ",i + write(*,*) allocated(v(i)%x) + write(*,*) v(i)%x + enddo + +end program p diff --git a/Fortran/gfortran/regression/elemental_bind_c.f90 b/Fortran/gfortran/regression/elemental_bind_c.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_bind_c.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! PR fortran/33412 +! +elemental subroutine a() bind(c) ! { dg-error "BIND.C. attribute conflicts with ELEMENTAL" } +end subroutine a ! { dg-error "Expecting END PROGRAM" } + +elemental function b() bind(c) ! { dg-error "BIND.C. attribute conflicts with ELEMENTAL" } +end function b ! { dg-error "Expecting END PROGRAM" } +end diff --git a/Fortran/gfortran/regression/elemental_by_value_1.f90 b/Fortran/gfortran/regression/elemental_by_value_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_by_value_1.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! +! PR fortran/59026 +! +! Contributed by F-X Coudert +! +! Failed to dereference the argument in scalarized loop. +! +elemental integer function foo(x) + integer, value :: x + foo = x + 1 +end function + + interface + elemental integer function foo(x) + integer, value :: x + end function + end interface + + if (foo(42) .ne. 43) STOP 1 + if (any (foo([0,1]) .ne. [1,2])) STOP 2 +end diff --git a/Fortran/gfortran/regression/elemental_dependency_1.f90 b/Fortran/gfortran/regression/elemental_dependency_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_dependency_1.f90 @@ -0,0 +1,82 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/35681 +! Test the use of temporaries in case of elemental subroutines. + +PROGRAM main + IMPLICIT NONE + INTEGER, PARAMETER :: sz = 5 + INTEGER :: i + INTEGER :: a(sz) = (/ (i, i=1,sz) /) + INTEGER :: b(sz) + + b = a + CALL double(a(sz-b+1), a) ! { dg-warning "might interfere with actual" } + ! Don't check the result, as the above is invalid + ! and might produce unexpected results (overlapping vector subscripts). + + + b = a + CALL double (a, a) ! same range, no temporary + IF (ANY(a /= 2*b)) STOP 1 + + + b = a + CALL double (a+1, a) ! same range, no temporary + IF (ANY(a /= 2*b+2)) STOP 2 + + + b = a + CALL double ((a(1:sz)), a(1:sz)) ! same range, no temporary + IF (ANY(a /= 2*b)) STOP 3 + + + b = a + CALL double(a(1:sz-1), a(2:sz)) ! { dg-warning "might interfere with actual" } + ! Don't check the result, as the above is invalid, + ! and might produce unexpected results (arguments overlap). + + + b = a + CALL double((a(1:sz-1)), a(2:sz)) ! paren expression, temporary created +! { dg-final { scan-tree-dump-times "A\.16\\\[4\\\]" 1 "original" } } + + IF (ANY(a /= (/ b(1), (2*b(i), i=1,sz-1) /))) STOP 4 + + + b = a + CALL double(a(1:sz-1)+1, a(2:sz)) ! op expression, temporary created +! { dg-final { scan-tree-dump-times "A\.25\\\[4\\\]" 1 "original" } } + + IF (ANY(a /= (/ b(1), (2*b(i)+2, i=1,sz-1) /))) STOP 5 + + + b = a + CALL double(self(a), a) ! same range, no temporary + IF (ANY(a /= 2*b)) STOP 6 + + + b = a + CALL double(self(a(1:sz-1)), a(2:sz)) ! function expr, temporary created +! { dg-final { scan-tree-dump-times "A\.37\\\[4\\\]" 1 "original" } } + + IF (ANY(a /= (/ b(1), (2*b(i), i=1,sz-1) /))) STOP 7 + + +CONTAINS + ELEMENTAL SUBROUTINE double(a, b) + IMPLICIT NONE + INTEGER, INTENT(IN) :: a + INTEGER, INTENT(OUT) :: b + b = 2 * a + END SUBROUTINE double + ELEMENTAL FUNCTION self(a) + IMPLICIT NONE + INTEGER, INTENT(IN) :: a + INTEGER :: self + self = a + END FUNCTION self +END PROGRAM main + +! { dg-final { scan-tree-dump-times "_gfortran_internal_unpack" 3 "original" } } diff --git a/Fortran/gfortran/regression/elemental_dependency_2.f90 b/Fortran/gfortran/regression/elemental_dependency_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_dependency_2.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! +! PR fortran/38487 +! Spurious warning on pointers as elemental subroutine actual arguments +! +! Contributed by Harald Anlauf + +module gfcbug82 + implicit none + type t + real, pointer :: q(:) =>NULL() + real, pointer :: r(:) =>NULL() + end type t + type (t), save :: x, y + real, dimension(:), pointer, save :: a => NULL(), b => NULL() + real, save :: c(5), d +contains + elemental subroutine add (q, r) + real, intent (inout) :: q + real, intent (in) :: r + q = q + r + end subroutine add + + subroutine foo () + call add (y% q, x% r) + call add (y% q, b ) + call add (a , x% r) + call add (a , b ) + call add (y% q, d ) + call add (a , d ) + call add (c , x% r) + call add (c , b ) + end subroutine foo +end module gfcbug82 diff --git a/Fortran/gfortran/regression/elemental_dependency_3.f90 b/Fortran/gfortran/regression/elemental_dependency_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_dependency_3.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/38669 +! Temporary created for pointer as actual argument of an elemental subroutine +! +! Original testcase by Harald Anlauf + +program gfcbu84_main + implicit none + integer :: jplev, k_lev + real :: p(42) + real, pointer :: q(:) + jplev = 42 + k_lev = 1 + allocate (q(jplev)) + call tq_tvgh (q(k_lev:), p(k_lev:)) + deallocate (q) + + contains + elemental subroutine tq_tvgh (t, p) + real ,intent (out) :: t + real ,intent (in) :: p + t=p + end subroutine tq_tvgh +end program gfcbu84_main +! { dg-final { scan-tree-dump-times "atmp" 0 "original" } } diff --git a/Fortran/gfortran/regression/elemental_dependency_4.f90 b/Fortran/gfortran/regression/elemental_dependency_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_dependency_4.f90 @@ -0,0 +1,167 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } +! { dg-require-visibility "" } +! +! Tests the fix for PR64952, in which the assignment to 'array' should +! have generated a temporary because of the references to the lhs in +! the function 'Fred'. +! +! Original report, involving function 'Nick' +! Contributed by Nick Maclaren on clf +! https://groups.google.com/forum/#!topic/comp.lang.fortran/TvVY5j3GPmg +! +! Other tests are due to Mikael Morin +! +MODULE M + INTEGER, PRIVATE :: i + REAL :: arraym(5) = (/ (i+0.0, i = 1,5) /) +CONTAINS + ELEMENTAL FUNCTION Bill (n, x) + REAL :: Bill + INTEGER, INTENT(IN) :: n + REAL, INTENT(IN) :: x + Bill = x+SUM(arraym(:n-1))+SUM(arraym(n+1:)) + END FUNCTION Bill + + ELEMENTAL FUNCTION Charles (x) + REAL :: Charles + REAL, INTENT(IN) :: x + Charles = x + END FUNCTION Charles +END MODULE M + +ELEMENTAL FUNCTION Peter(n, x) + USE M + REAL :: Peter + INTEGER, INTENT(IN) :: n + REAL, INTENT(IN) :: x + Peter = Bill(n, x) +END FUNCTION Peter + +PROGRAM Main + use M + INTEGER :: i, index(5) = (/ (i, i = 1,5) /) + REAL :: array(5) = (/ (i+0.0, i = 1,5) /) + + INTERFACE + ELEMENTAL FUNCTION Peter(n, x) + REAL :: Peter + INTEGER, INTENT(IN) :: n + REAL, INTENT(IN) :: x + END FUNCTION Peter + END INTERFACE + + PROCEDURE(Robert2), POINTER :: missme => Null() + + ! Original testcase + array = Nick(index,array) + If (any (array .ne. array(1))) STOP 1 + + array = (/ (i+0.0, i = 1,5) /) + ! This should not create a temporary + array = Charles(array) + If (any (array .ne. index)) STOP 2 + ! { dg-final { scan-tree-dump-times "array\\\[\[^\\\]\]*\\\]\\s*=\\s*charles\\s*\\(&array\\\[\[^\\\]\]*\\\]\\);" 1 "original" } } + + ! Check use association of the function works correctly. + arraym = Bill(index,arraym) + if (any (arraym .ne. arraym(1))) STOP 3 + + ! Check siblings interact correctly. + array = (/ (i+0.0, i = 1,5) /) + array = Henry(index) + if (any (array .ne. array(1))) STOP 4 + + array = (/ (i+0.0, i = 1,5) /) + ! This should not create a temporary + array = index + Henry2(0) - array + ! { dg-final { scan-tree-dump-times "array\\\[\[^\\\]\]*\\\]\\s*=\\s*\\(\\(real\\(kind=4\\)\\)\\s*index\\\[\[^\\\]\]*\\\]\\s*\\+\\s*D.\\d*\\)\\s*-\\s*array\\\[\[^\\\]\]*\\\];" 1 "original" } } + if (any (array .ne. 15.0)) STOP 5 + + arraym = (/ (i+0.0, i = 1,5) /) + arraym = Peter(index, arraym) + if (any (arraym .ne. 15.0)) STOP 6 + + array = (/ (i+0.0, i = 1,5) /) + array = Robert(index) + if (any (arraym .ne. 15.0)) STOP 7 + + missme => Robert2 + array = (/ (i+0.0, i = 1,5) /) + array = David(index) + if (any (arraym .ne. 15.0)) STOP 8 + + array = (/ (i+0.0, i = 1,5) /) + array = James(index) + if (any (arraym .ne. 15.0)) STOP 9 + + array = (/ (i+0.0, i = 1,5) /) + array = Romeo(index) + if (any (arraym .ne. 15.0)) STOP 10 + +CONTAINS + ELEMENTAL FUNCTION Nick (n, x) + REAL :: Nick + INTEGER, INTENT(IN) :: n + REAL, INTENT(IN) :: x + Nick = x+SUM(array(:n-1))+SUM(array(n+1:)) + END FUNCTION Nick + +! Note that the inverse order of Henry and Henry2 is trivial. +! This way round, Henry2 has to be resolved before Henry can +! be marked as having an inherited external array reference. + ELEMENTAL FUNCTION Henry2 (n) + REAL :: Henry2 + INTEGER, INTENT(IN) :: n + Henry2 = n + SUM(array(:n-1))+SUM(array(n+1:)) + END FUNCTION Henry2 + + ELEMENTAL FUNCTION Henry (n) + REAL :: Henry + INTEGER, INTENT(IN) :: n + Henry = Henry2(n) + END FUNCTION Henry + + PURE FUNCTION Robert2(n) + REAL :: Robert2 + INTEGER, INTENT(IN) :: n + Robert2 = Henry(n) + END FUNCTION Robert2 + + ELEMENTAL FUNCTION Robert(n) + REAL :: Robert + INTEGER, INTENT(IN) :: n + Robert = Robert2(n) + END FUNCTION Robert + + ELEMENTAL FUNCTION David (n) + REAL :: David + INTEGER, INTENT(IN) :: n + David = missme(n) + END FUNCTION David + + ELEMENTAL SUBROUTINE James2 (o, i) + REAL, INTENT(OUT) :: o + INTEGER, INTENT(IN) :: i + o = Henry(i) + END SUBROUTINE James2 + + ELEMENTAL FUNCTION James(n) + REAL :: James + INTEGER, INTENT(IN) :: n + CALL James2(James, n) + END FUNCTION James + + FUNCTION Romeo2(n) + REAL :: Romeo2 + INTEGER, INTENT(in) :: n + Romeo2 = Henry(n) + END FUNCTION Romeo2 + + IMPURE ELEMENTAL FUNCTION Romeo(n) + REAL :: Romeo + INTEGER, INTENT(IN) :: n + Romeo = Romeo2(n) + END FUNCTION Romeo +END PROGRAM Main + diff --git a/Fortran/gfortran/regression/elemental_dependency_5.f90 b/Fortran/gfortran/regression/elemental_dependency_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_dependency_5.f90 @@ -0,0 +1,62 @@ +! { dg-do run } +! { dg-require-visibility "" } +! +! Tests the fix for PR64952. +! +! Original report by Nick Maclaren on clf +! https://groups.google.com/forum/#!topic/comp.lang.fortran/TvVY5j3GPmg +! See elemental_dependency_4.f90 +! +! This test contributed by Mikael Morin +! +MODULE M + INTEGER, PRIVATE :: i + + TYPE, ABSTRACT :: t + REAL :: f + CONTAINS + PROCEDURE(Fred_ifc), DEFERRED, PASS :: tbp + END TYPE t + TYPE, EXTENDS(t) :: t2 + CONTAINS + PROCEDURE :: tbp => Fred + END TYPE t2 + + TYPE(t2) :: array(5) = (/ (t2(i+0.0), i = 1,5) /) + + INTERFACE + ELEMENTAL FUNCTION Fred_ifc (x, n) + IMPORT + REAL :: Fred + CLASS(T), INTENT(IN) :: x + INTEGER, INTENT(IN) :: n + END FUNCTION Fred_ifc + END INTERFACE + +CONTAINS + ELEMENTAL FUNCTION Fred (x, n) + REAL :: Fred + CLASS(T2), INTENT(IN) :: x + INTEGER, INTENT(IN) :: n + Fred = x%f+SUM(array(:n-1)%f)+SUM(array(n+1:)%f) + END FUNCTION Fred +END MODULE M + +PROGRAM Main + USE M + INTEGER :: i, index(5) = (/ (i, i = 1,5) /) + + array%f = array%tbp(index) + if (any (array%f .ne. array(1)%f)) STOP 1 + + array%f = index + call Jack(array) + CONTAINS + SUBROUTINE Jack(dummy) + CLASS(t) :: dummy(:) + dummy%f = dummy%tbp(index) + !print *, dummy%f + if (any (dummy%f .ne. 15.0)) STOP 2 + END SUBROUTINE +END PROGRAM Main + diff --git a/Fortran/gfortran/regression/elemental_dependency_6.f90 b/Fortran/gfortran/regression/elemental_dependency_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_dependency_6.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! +! PR fortran/66089 +! Check that we do create a temporary for C(1) below in the assignment +! to C. + + type :: t + integer :: c + end type t + + type(t), dimension(5) :: b, c + + b = t(7) + c = t(13) + c = plus(c(1), b) +! print *, c + if (any(c%c /= 20)) STOP 1 + +contains + + elemental function plus(lhs, rhs) + type(t), intent(in) :: lhs, rhs + type(t) :: plus + plus%c = lhs%c + rhs%c + end function plus + +end diff --git a/Fortran/gfortran/regression/elemental_dependency_7.f90 b/Fortran/gfortran/regression/elemental_dependency_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_dependency_7.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! PR fortran/107819 - ICE in gfc_check_argument_var_dependency +! Contributed by G.Steinmetz +! +! Note: the testcase is considered non-conforming for m>1 due to aliasing + +program p + implicit none + integer, parameter :: m = 1 + integer :: i + integer :: a(m) = [(-i,i=1,m)] + integer :: n(m) = [(i,i=m,1,-1)] + integer :: b(m) + b = a + call s (a(n), a) ! { dg-warning "might interfere with actual argument" } + + ! Compare to separate application of subroutine in element order + do i = 1, size (b) + call s (b(n(i)), b(i)) + end do + if (any (a /= b)) stop 1 +contains + elemental subroutine s (x, y) + integer, value :: x + integer, intent(out) :: y + y = x + end +end diff --git a/Fortran/gfortran/regression/elemental_function_1.f90 b/Fortran/gfortran/regression/elemental_function_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_function_1.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +! PR fortran/52059 +! +! + +subroutine baz + real(kind=8) :: a(99), b + interface bar + function bar (x, y) + integer, intent(in) :: x, y + real(kind=8), dimension((y-x)) :: bar + end function bar + end interface + b = 1.0_8 + a = foo (bar(0,35) / dble(34), b) +contains + elemental real(kind=8) function foo(x, y) + real(kind=8), intent(in) :: x, y + foo = 1 + end function foo +end subroutine baz diff --git a/Fortran/gfortran/regression/elemental_function_2.f90 b/Fortran/gfortran/regression/elemental_function_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_function_2.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! +! Test the fix for PR87239 in which the call to the elemental function +! 'gettwo' was being added before the scalarization loop in the assignment. +! Since the result temporary was being declared in the loop body, this +! drove the gimplifier crazy. It is sufficient to compile this testcase +! since it used to ICE. +! +! Contributed by Juergen Reuter +! +module test + implicit none +contains + + elemental function gettwo( s ) result( res ) + character(*), intent(in) :: s + character(len(s)) :: res + + res = s( 1 : 2 ) + endfunction gettwo + +endmodule test + +program main + use test + implicit none + character(10) :: inp( 5 ) + integer :: i + + ! character(10), allocatable :: out(:) ! this works + character(:), allocatable :: out(:) ! this was stuffed + + inp = [ 'aaa', 'bbb', 'ccc', 'ddd', 'eee' ] + + out = gettwo( inp ) + + do i = 1, size (out, 1) + if (trim (out(i)) .ne. inp(i)(1:2)) stop 1 + end do +endprogram main diff --git a/Fortran/gfortran/regression/elemental_function_3.f90 b/Fortran/gfortran/regression/elemental_function_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_function_3.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! +! Test the fix for PR84109 in which the call to the elemental function +! 'adjustl' was being added before the scalarization loop in the assignment. +! Since the result temporary was being declared in the loop body, this +! drove the gimplifier crazy. It is sufficient to compile this testcase +! since it used to ICE. This is the intrinsic counterpart to PR87239, +! which is tested for the absence of an ICE in elemental_function_2.f90. +! In this fix, a further improvement was to keep scalar calls outside the +! scalarization loop and this is tested with 'my_adjustl'. +! +! Contributed by Willem Vermin +! +program prog + implicit none + character(len=:), allocatable :: c(:) + integer :: cnt = 0 + + allocate(character(len=20) :: c(10)) + c = " ab " + c = adjustl(c) ! Used to ICE + if (trim (c(1)) .ne. "ab") stop 1 + + c = my_adjustl (" abcdefg ") + if (trim (c(1)) .ne. "abcdefg") stop 2 + if (cnt .ne. 1) stop 3 ! Outside the scalarization loop + if (size (c, 1) .ne. 10) stop 4 + if (len (c) .ne. 20) stop 5 + + cnt = 0 + c = my_adjustl ([" uv ", " xy "]) + if (trim (c(2)) .ne. "xy") stop 6 + if (cnt .ne. size (c, 1)) stop 7 ! Inside the scalarization loop + if (size (c, 1) .ne. 2) stop 8 + +contains + + impure elemental function my_adjustl(arg) result (res) + character(*), intent(in) :: arg + character(len = len (arg)) :: res + res = adjustl (arg) + cnt = cnt + 1 ! Test how many calls are made + end function +end program diff --git a/Fortran/gfortran/regression/elemental_function_4.f90 b/Fortran/gfortran/regression/elemental_function_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_function_4.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! +! Tests the fix for PR83999, where the invalid function 'f' caused an ICE. +! +! Contributed by Gerhard Steinmetz +! +program p + type t + integer :: a + end type + type(t) :: x(3) + x = f() + print *, x +contains + elemental function f() result(z) ! { dg-error "must have a scalar result" } + type(t), pointer :: z(:) + end +end diff --git a/Fortran/gfortran/regression/elemental_function_5.f90 b/Fortran/gfortran/regression/elemental_function_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_function_5.f90 @@ -0,0 +1,46 @@ +! { dg-do compile } +! +! Test the fix for PR98472. +! +! Contributed by Rui Coelho +! +module a + type, abstract :: base + contains + procedure(elem_func), deferred, nopass :: add + end type base + + type, extends(base) :: derived + contains + procedure, nopass :: add => add_derived + end type derived + + abstract interface + elemental function elem_func(x, y) result(out) + integer, intent(in) :: x, y + integer :: out + end function elem_func + end interface + +contains + elemental function add_derived(x, y) result(out) + integer, intent(in) :: x, y + integer :: out + out = x + y + end function add_derived +end module a + +program main + use a + call foo +contains + subroutine foo + integer, dimension(:), allocatable :: vec + class(base), allocatable :: instance + allocate(derived :: instance) + allocate(vec, source=instance%add([1, 2], [1, 2])) ! ICE here + if (any (vec .ne. [2, 4])) stop 1 + end +end program main + + diff --git a/Fortran/gfortran/regression/elemental_initializer_1.f90 b/Fortran/gfortran/regression/elemental_initializer_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_initializer_1.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! Tests the fix for elemental functions not being allowed in +! specification expressions in pure procedures. +! +! Testcase from iso_varying_string by Rich Townsend +! The allocatable component has been changed to a pointer for this testcase. +! +module iso_varying_string + + type varying_string + private + character(LEN=1), dimension(:), pointer :: chars + end type varying_string + + interface len + module procedure len_ + end interface len + +contains + + pure function char_auto (string) result (char_string) + type(varying_string), intent(in) :: string + character(LEN=len(string)) :: char_string ! Error was here + char_string = "" + end function char_auto + + elemental function len_ (string) result (length) + type(varying_string), intent(in) :: string + integer :: length + length = 1 + end function len_ + +end module iso_varying_string diff --git a/Fortran/gfortran/regression/elemental_intrinsic_1.f03 b/Fortran/gfortran/regression/elemental_intrinsic_1.f03 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_intrinsic_1.f03 @@ -0,0 +1,11 @@ +! { dg-do compile } + +! Conformance-checking of arguments was not done for intrinsic elemental +! subroutines, check this works now. + +! This is the test from PR fortran/35681, comment #1 (second program). + + integer, dimension(10) :: ILA1 = (/1,2,3,4,5,6,7,8,9,10/) + call mvbits ((ILA1((/9/))), 2, 4, ILA1, 3) ! { dg-error "Different shape" } + write (*,'(10(I3))') ila1 + end diff --git a/Fortran/gfortran/regression/elemental_non_intrinsic_dummy_1.f90 b/Fortran/gfortran/regression/elemental_non_intrinsic_dummy_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_non_intrinsic_dummy_1.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! Tests the fix for 20871, in which elemental non-intrinsic procedures were +! permitted to be dummy arguments. +! +! Contributed by Joost VandeVondele +! +MODULE TT +CONTAINS + ELEMENTAL INTEGER FUNCTION two(N) + INTEGER, INTENT(IN) :: N + two=2**N + END FUNCTION +END MODULE +USE TT + INTEGER, EXTERNAL :: SUB + write(6,*) SUB(two) ! { dg-error "not allowed as an actual argument " } +END +INTEGER FUNCTION SUB(XX) + INTEGER :: XX + SUB=XX() +END diff --git a/Fortran/gfortran/regression/elemental_optional_args_1.f90 b/Fortran/gfortran/regression/elemental_optional_args_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_optional_args_1.f90 @@ -0,0 +1,53 @@ +! { dg-do compile } +! { dg-options "-pedantic" } +! Check the fix for PR20893, in which actual arguments could violate: +! "(5) If it is an array, it shall not be supplied as an actual argument to +! an elemental procedure unless an array of the same rank is supplied as an +! actual argument corresponding to a nonoptional dummy argument of that +! elemental procedure." (12.4.1.5) +! +! Contributed by Joost VandeVondele +! + CALL T1(1,2) +CONTAINS + SUBROUTINE T1(A1,A2,A3) + INTEGER :: A1,A2, A4(2), A5(2) + INTEGER, OPTIONAL :: A3(2) + interface + elemental function efoo (B1,B2,B3) result(bar) + INTEGER, intent(in) :: B1, B2 + integer :: bar + INTEGER, OPTIONAL, intent(in) :: B3 + end function efoo + end interface + +! check an intrinsic function + write(6,*) MAX(A1,A2,A3) ! { dg-warning "array and OPTIONAL" } + write(6,*) MAX(A1,A3,A2) + write(6,*) MAX(A1,A4,A3) +! check an internal elemental function + write(6,*) foo(A1,A2,A3) ! { dg-warning "array and OPTIONAL" } + write(6,*) foo(A1,A3,A2) + write(6,*) foo(A1,A4,A3) +! check an external elemental function + write(6,*) efoo(A1,A2,A3) ! { dg-warning "array and OPTIONAL" } + write(6,*) efoo(A1,A3,A2) + write(6,*) efoo(A1,A4,A3) +! check an elemental subroutine + call foobar (A5,A2,A4) + call foobar (A5,A4,A4) + END SUBROUTINE + elemental function foo (B1,B2,B3) result(bar) + INTEGER, intent(in) :: B1, B2 + integer :: bar + INTEGER, OPTIONAL, intent(in) :: B3 + bar = 1 + end function foo + elemental subroutine foobar (B1,B2,B3) + INTEGER, intent(OUT) :: B1 + INTEGER, optional, intent(in) :: B2, B3 + B1 = 1 + end subroutine foobar + +END + diff --git a/Fortran/gfortran/regression/elemental_optional_args_2.f90 b/Fortran/gfortran/regression/elemental_optional_args_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_optional_args_2.f90 @@ -0,0 +1,80 @@ +! { dg-do run } +! +! PR fortran/50981 +! The program used to dereference a NULL pointer when trying to access +! an optional dummy argument to be passed to an elemental subprocedure. +! +! Original testcase from Andriy Kostyuk + +PROGRAM test + IMPLICIT NONE + REAL(KIND=8), DIMENSION(2) :: aa, rr + + aa(1)=10. + aa(2)=11. + + + ! WRITE(*,*) 'Both f1 and ff work if the optional parameter is present:' + + rr=f1(aa,1) + ! WRITE(*,*) ' rr(1)=', rr(1), ' rr(2)=', rr(2) + IF (ANY(rr /= (/ 110, 132 /))) STOP 1 + + rr=0 + rr=ff(aa,1) + ! WRITE(*,*) ' rr(1)=', rr(1), ' rr(2)=', rr(2) + IF (ANY(rr /= (/ 110, 132 /))) STOP 2 + + + ! WRITE(*,*) 'But only f1 works if the optional parameter is absent:' + + rr=0 + rr=f1(aa) + ! WRITE(*,*) ' rr(1)=', rr(1), ' rr(2)=', rr(2) + IF (ANY(rr /= (/ 110, 132 /))) STOP 3 + + rr = 0 + rr=ff(aa) + ! WRITE(*,*) ' rr(1)=', rr(1), ' rr(2)=', rr(2) + IF (ANY(rr /= (/ 110, 132 /))) STOP 4 + + +CONTAINS + + ELEMENTAL REAL(KIND=8) FUNCTION ff(a,b) + IMPLICIT NONE + REAL(KIND=8), INTENT(IN) :: a + INTEGER, INTENT(IN), OPTIONAL :: b + REAL(KIND=8), DIMENSION(2) :: ac + ac(1)=a + ac(2)=a**2 + ff=SUM(gg(ac,b)) + END FUNCTION ff + + ELEMENTAL REAL(KIND=8) FUNCTION f1(a,b) + IMPLICIT NONE + REAL(KIND=8), INTENT(IN) :: a + INTEGER, INTENT(IN), OPTIONAL :: b + REAL(KIND=8), DIMENSION(2) :: ac + ac(1)=a + ac(2)=a**2 + f1=gg(ac(1),b)+gg(ac(2),b) ! This is the same as in ff, but without using the elemental feature of gg + END FUNCTION f1 + + ELEMENTAL REAL(KIND=8) FUNCTION gg(a,b) + IMPLICIT NONE + REAL(KIND=8), INTENT(IN) :: a + INTEGER, INTENT(IN), OPTIONAL :: b + INTEGER ::b1 + IF(PRESENT(b)) THEN + b1=b + ELSE + b1=1 + ENDIF + gg=a**b1 + END FUNCTION gg + + +END PROGRAM test + + diff --git a/Fortran/gfortran/regression/elemental_optional_args_3.f90 b/Fortran/gfortran/regression/elemental_optional_args_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_optional_args_3.f90 @@ -0,0 +1,85 @@ +! { dg-do run } +! +! PR fortran/50981 +! The program used to dereference a NULL pointer when trying to access +! a pointer dummy argument to be passed to an elemental subprocedure. +! +! Original testcase from Andriy Kostyuk + +PROGRAM test + IMPLICIT NONE + REAL(KIND=8), DIMENSION(2) :: aa, rr + INTEGER, TARGET :: c + INTEGER, POINTER :: b + + aa(1)=10. + aa(2)=11. + + b=>c + b=1 + + ! WRITE(*,*) 'Both f1 and ff work if the optional parameter is present:' + + rr=f1(aa,b) + ! WRITE(*,*) ' rr(1)=', rr(1), ' rr(2)=', rr(2) + IF (ANY(rr /= (/ 110, 132 /))) STOP 1 + + rr=0 + rr=ff(aa,b) + ! WRITE(*,*) ' rr(1)=', rr(1), ' rr(2)=', rr(2) + IF (ANY(rr /= (/ 110, 132 /))) STOP 2 + + + b => NULL() + ! WRITE(*,*) 'But only f1 works if the optional parameter is absent:' + + rr=0 + rr=f1(aa, b) + ! WRITE(*,*) ' rr(1)=', rr(1), ' rr(2)=', rr(2) + IF (ANY(rr /= (/ 110, 132 /))) STOP 3 + + rr = 0 + rr=ff(aa, b) + ! WRITE(*,*) ' rr(1)=', rr(1), ' rr(2)=', rr(2) + IF (ANY(rr /= (/ 110, 132 /))) STOP 4 + + +CONTAINS + + FUNCTION ff(a,b) + IMPLICIT NONE + REAL(KIND=8), INTENT(IN) :: a(:) + REAL(KIND=8), DIMENSION(SIZE(a)) :: ff + INTEGER, INTENT(IN), POINTER :: b + REAL(KIND=8), DIMENSION(2, SIZE(a)) :: ac + ac(1,:)=a + ac(2,:)=a**2 + ff=SUM(gg(ac,b), dim=1) + END FUNCTION ff + + FUNCTION f1(a,b) + IMPLICIT NONE + REAL(KIND=8), INTENT(IN) :: a(:) + REAL(KIND=8), DIMENSION(SIZE(a)) :: f1 + INTEGER, INTENT(IN), POINTER :: b + REAL(KIND=8), DIMENSION(2, SIZE(a)) :: ac + ac(1,:)=a + ac(2,:)=a**2 + f1=gg(ac(1,:),b)+gg(ac(2,:),b) ! This is the same as in ff, but without using the elemental feature of gg + END FUNCTION f1 + + ELEMENTAL REAL(KIND=8) FUNCTION gg(a,b) + IMPLICIT NONE + REAL(KIND=8), INTENT(IN) :: a + INTEGER, INTENT(IN), OPTIONAL :: b + INTEGER ::b1 + IF(PRESENT(b)) THEN + b1=b + ELSE + b1=1 + ENDIF + gg=a**b1 + END FUNCTION gg + + +END PROGRAM test diff --git a/Fortran/gfortran/regression/elemental_optional_args_4.f90 b/Fortran/gfortran/regression/elemental_optional_args_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_optional_args_4.f90 @@ -0,0 +1,84 @@ +! { dg-do run } +! +! PR fortran/50981 +! The program used to dereference a NULL pointer when trying to access +! an allocatable dummy argument to be passed to an elemental subprocedure. +! +! Original testcase from Andriy Kostyuk + +PROGRAM test + IMPLICIT NONE + REAL(KIND=8), DIMENSION(2) :: aa, rr + INTEGER, ALLOCATABLE :: b + + aa(1)=10. + aa(2)=11. + + ALLOCATE(b) + b=1 + + ! WRITE(*,*) 'Both f1 and ff work if the optional parameter is present:' + + rr=f1(aa,b) + ! WRITE(*,*) ' rr(1)=', rr(1), ' rr(2)=', rr(2) + IF (ANY(rr /= (/ 110, 132 /))) STOP 1 + + rr=0 + rr=ff(aa,b) + ! WRITE(*,*) ' rr(1)=', rr(1), ' rr(2)=', rr(2) + IF (ANY(rr /= (/ 110, 132 /))) STOP 2 + + + DEALLOCATE(b) + ! WRITE(*,*) 'But only f1 works if the optional parameter is absent:' + + rr=0 + rr=f1(aa, b) + ! WRITE(*,*) ' rr(1)=', rr(1), ' rr(2)=', rr(2) + IF (ANY(rr /= (/ 110, 132 /))) STOP 3 + + rr = 0 + rr=ff(aa, b) + ! WRITE(*,*) ' rr(1)=', rr(1), ' rr(2)=', rr(2) + IF (ANY(rr /= (/ 110, 132 /))) STOP 4 + + +CONTAINS + + FUNCTION ff(a,b) + IMPLICIT NONE + REAL(KIND=8), INTENT(IN) :: a(:) + REAL(KIND=8), DIMENSION(SIZE(a)) :: ff + INTEGER, INTENT(IN), ALLOCATABLE :: b + REAL(KIND=8), DIMENSION(2, SIZE(a)) :: ac + ac(1,:)=a + ac(2,:)=a**2 + ff=SUM(gg(ac,b), dim=1) + END FUNCTION ff + + FUNCTION f1(a,b) + IMPLICIT NONE + REAL(KIND=8), INTENT(IN) :: a(:) + REAL(KIND=8), DIMENSION(SIZE(a)) :: f1 + INTEGER, INTENT(IN), ALLOCATABLE :: b + REAL(KIND=8), DIMENSION(2, SIZE(a)) :: ac + ac(1,:)=a + ac(2,:)=a**2 + f1=gg(ac(1,:),b)+gg(ac(2,:),b) ! This is the same as in ff, but without using the elemental feature of gg + END FUNCTION f1 + + ELEMENTAL REAL(KIND=8) FUNCTION gg(a,b) + IMPLICIT NONE + REAL(KIND=8), INTENT(IN) :: a + INTEGER, INTENT(IN), OPTIONAL :: b + INTEGER ::b1 + IF(PRESENT(b)) THEN + b1=b + ELSE + b1=1 + ENDIF + gg=a**b1 + END FUNCTION gg + + +END PROGRAM test diff --git a/Fortran/gfortran/regression/elemental_optional_args_5.f03 b/Fortran/gfortran/regression/elemental_optional_args_5.f03 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_optional_args_5.f03 @@ -0,0 +1,246 @@ +! { dg-do run } +! +! PR fortran/50981 +! Test the handling of optional, polymorphic and non-polymorphic arguments +! to elemental procedures. +! +! Original testcase by Tobias Burnus + +implicit none +type t + integer :: a +end type t + +type t2 + integer, allocatable :: a + integer, allocatable :: a2(:) + integer, pointer :: p => null() + integer, pointer :: p2(:) => null() +end type t2 + +type(t), allocatable :: ta, taa(:) +type(t), pointer :: tp, tpa(:) +class(t), allocatable :: ca, caa(:) +class(t), pointer :: cp, cpa(:) + +type(t2) :: x + +integer :: s, v(2) + +tp => null() +tpa => null() +cp => null() +cpa => null() + +! =============== sub1 ================== +! SCALAR COMPONENTS: Non alloc/assoc + +s = 3 +v = [9, 33] + +call sub1 (s, x%a, .false.) +call sub1 (v, x%a, .false.) +!print *, s, v +if (s /= 3) STOP 1 +if (any (v /= [9, 33])) STOP 2 + +call sub1 (s, x%p, .false.) +call sub1 (v, x%p, .false.) +!print *, s, v +if (s /= 3) STOP 3 +if (any (v /= [9, 33])) STOP 4 + + +! SCALAR COMPONENTS: alloc/assoc + +allocate (x%a, x%p) +x%a = 4 +x%p = 5 +call sub1 (s, x%a, .true.) +call sub1 (v, x%a, .true.) +!print *, s, v +if (s /= 4*2) STOP 5 +if (any (v /= [4*2, 4*2])) STOP 6 + +call sub1 (s, x%p, .true.) +call sub1 (v, x%p, .true.) +!print *, s, v +if (s /= 5*2) STOP 7 +if (any (v /= [5*2, 5*2])) STOP 8 + + +! ARRAY COMPONENTS: Non alloc/assoc + +v = [9, 33] + +call sub1 (v, x%a2, .false.) +!print *, v +if (any (v /= [9, 33])) STOP 9 + +call sub1 (v, x%p2, .false.) +!print *, v +if (any (v /= [9, 33])) STOP 10 + + +! ARRAY COMPONENTS: alloc/assoc + +allocate (x%a2(2), x%p2(2)) +x%a2(:) = [84, 82] +x%p2 = [35, 58] + +call sub1 (v, x%a2, .true.) +!print *, v +if (any (v /= [84*2, 82*2])) STOP 11 + +call sub1 (v, x%p2, .true.) +!print *, v +if (any (v /= [35*2, 58*2])) STOP 12 + + +! =============== sub_t ================== +! SCALAR DT: Non alloc/assoc + +s = 3 +v = [9, 33] + +call sub_t (s, ta, .false.) +call sub_t (v, ta, .false.) +!print *, s, v +if (s /= 3) STOP 13 +if (any (v /= [9, 33])) STOP 14 + +call sub_t (s, tp, .false.) +call sub_t (v, tp, .false.) +!print *, s, v +if (s /= 3) STOP 15 +if (any (v /= [9, 33])) STOP 16 + +call sub_t (s, ca, .false.) +call sub_t (v, ca, .false.) +!print *, s, v +if (s /= 3) STOP 17 +if (any (v /= [9, 33])) STOP 18 + +call sub_t (s, cp, .false.) +call sub_t (v, cp, .false.) +!print *, s, v +if (s /= 3) STOP 19 +if (any (v /= [9, 33])) STOP 20 + +! SCALAR COMPONENTS: alloc/assoc + +allocate (ta, tp, ca, cp) +ta%a = 4 +tp%a = 5 +ca%a = 6 +cp%a = 7 + +call sub_t (s, ta, .true.) +call sub_t (v, ta, .true.) +!print *, s, v +if (s /= 4*2) STOP 21 +if (any (v /= [4*2, 4*2])) STOP 22 + +call sub_t (s, tp, .true.) +call sub_t (v, tp, .true.) +!print *, s, v +if (s /= 5*2) STOP 23 +if (any (v /= [5*2, 5*2])) STOP 24 + +call sub_t (s, ca, .true.) +call sub_t (v, ca, .true.) +!print *, s, v +if (s /= 6*2) STOP 25 +if (any (v /= [6*2, 6*2])) STOP 26 + +call sub_t (s, cp, .true.) +call sub_t (v, cp, .true.) +!print *, s, v +if (s /= 7*2) STOP 27 +if (any (v /= [7*2, 7*2])) STOP 28 + +! ARRAY COMPONENTS: Non alloc/assoc + +v = [9, 33] + +call sub_t (v, taa, .false.) +!print *, v +if (any (v /= [9, 33])) STOP 29 + +call sub_t (v, tpa, .false.) +!print *, v +if (any (v /= [9, 33])) STOP 30 + +call sub_t (v, caa, .false.) +!print *, v +if (any (v /= [9, 33])) STOP 31 + +call sub_t (v, cpa, .false.) +!print *, v +if (any (v /= [9, 33])) STOP 32 + +deallocate(ta, tp, ca, cp) + + +! ARRAY COMPONENTS: alloc/assoc + +allocate (taa(2), tpa(2)) +taa(1:2)%a = [44, 444] +tpa(1:2)%a = [55, 555] +allocate (caa(2), source=[t(66), t(666)]) +allocate (cpa(2), source=[t(77), t(777)]) + +select type (caa) +type is (t) + if (any (caa(:)%a /= [66, 666])) STOP 33 +end select + +select type (cpa) +type is (t) + if (any (cpa(:)%a /= [77, 777])) STOP 34 +end select + +call sub_t (v, taa, .true.) +!print *, v +if (any (v /= [44*2, 444*2])) STOP 35 + +call sub_t (v, tpa, .true.) +!print *, v +if (any (v /= [55*2, 555*2])) STOP 36 + + +call sub_t (v, caa, .true.) +!print *, v +if (any (v /= [66*2, 666*2])) STOP 37 + +call sub_t (v, cpa, .true.) +!print *, v +if (any (v /= [77*2, 777*2])) STOP 38 + +deallocate (taa, tpa, caa, cpa) + + +contains + + elemental subroutine sub1 (x, y, alloc) + integer, intent(inout) :: x + integer, intent(in), optional :: y + logical, intent(in) :: alloc + if (alloc .neqv. present (y)) & + x = -99 + if (present(y)) & + x = y*2 + end subroutine sub1 + + elemental subroutine sub_t(x, y, alloc) + integer, intent(inout) :: x + type(t), intent(in), optional :: y + logical, intent(in) :: alloc + if (alloc .neqv. present (y)) & + x = -99 + if (present(y)) & + x = y%a*2 + end subroutine sub_t + +end + diff --git a/Fortran/gfortran/regression/elemental_optional_args_6.f90 b/Fortran/gfortran/regression/elemental_optional_args_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_optional_args_6.f90 @@ -0,0 +1,57 @@ +! { dg-do run } +! { dg-options "-Wpedantic" } +! +! PR fortran/53692 +! +! Check that the nonabsent arrary is used for scalarization: +! Either the NONOPTIONAL one or, if there are none, any array. +! +! Based on a program by Daniel C Chen +! +Program main + implicit none + integer :: arr1(2), arr2(2) + arr1 = [ 1, 2 ] + arr2 = [ 1, 2 ] + call sub1 (arg2=arr2) + + call two () +contains + subroutine sub1 (arg1, arg2) + integer, optional :: arg1(:) + integer :: arg2(:) +! print *, fun1 (arg1, arg2) + if (size (fun1 (arg1, arg2)) /= 2) STOP 1 + if (any (fun1 (arg1, arg2) /= [1,2])) STOP 2 + end subroutine + + elemental function fun1 (arg1, arg2) + integer,intent(in), optional :: arg1 + integer,intent(in) :: arg2 + integer :: fun1 + fun1 = arg2 + end function +end program + +subroutine two () + implicit none + integer :: arr1(2), arr2(2) + arr1 = [ 1, 2 ] + arr2 = [ 1, 2 ] + call sub2 (arr1, arg2=arr2) +contains + subroutine sub2 (arg1, arg2) + integer, optional :: arg1(:) + integer, optional :: arg2(:) +! print *, fun2 (arg1, arg2) + if (size (fun2 (arg1, arg2)) /= 2) STOP 3 ! { dg-warning "is an array and OPTIONAL" } + if (any (fun2 (arg1, arg2) /= [1,2])) STOP 4 ! { dg-warning "is an array and OPTIONAL" } + end subroutine + + elemental function fun2 (arg1,arg2) + integer,intent(in), optional :: arg1 + integer,intent(in), optional :: arg2 + integer :: fun2 + fun2 = arg2 + end function +end subroutine two diff --git a/Fortran/gfortran/regression/elemental_optional_args_7.f90 b/Fortran/gfortran/regression/elemental_optional_args_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_optional_args_7.f90 @@ -0,0 +1,37 @@ +! { dg-do run } +! +! The handling of scalar optional arguments passed to elemental procedure +! did not keep actual arguments and dummy arguments synchronized while +! walking them in gfc_walk_elemental_function_args, leading to a +! null pointer dereference in the generated code. +! + implicit none + + integer, parameter :: n = 3 + + call do_test + +contains + + elemental function five(nonopt1, opt1, nonopt2, opt2) + integer, intent(in), optional :: opt1, opt2 + integer, intent(in) :: nonopt1, nonopt2 + integer :: five + + if (.not. present(opt1) .and. .not. present(opt2)) then + five = 5 + else + five = -7 + end if + end function five + + subroutine do_test(opt) + integer, optional :: opt + integer :: i = -1, a(n) = (/ (i, i=1,n) /) + integer :: b(n) + + b = five(a, nonopt2=i, opt2=opt) + if (any(b /= 5)) STOP 1 + end subroutine do_test + +end diff --git a/Fortran/gfortran/regression/elemental_pointer_1.f90 b/Fortran/gfortran/regression/elemental_pointer_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_pointer_1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! Tests the fix for pr20875. +! Note 12.7.1 "For a function, the result shall be scalar and shall not have the POINTER attribute." +MODULE Test +CONTAINS + ELEMENTAL FUNCTION LL(I) + INTEGER, INTENT(IN) :: I + INTEGER :: LL + POINTER :: LL ! { dg-error " POINTER attribute conflicts with ELEMENTAL attribute" } + END FUNCTION LL +END MODULE Test diff --git a/Fortran/gfortran/regression/elemental_result_1.f90 b/Fortran/gfortran/regression/elemental_result_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_result_1.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! Tests the fix for PR20874 in which array valued elemental +! functions were permitted. +! +! Contributed by Joost VandeVondele +! +MODULE Test +CONTAINS + ELEMENTAL FUNCTION LL(I) ! { dg-error "must have a scalar result" } + INTEGER, INTENT(IN) :: I + INTEGER :: LL(2) + END FUNCTION LL +! +! This was already OK. +! + ELEMENTAL FUNCTION MM(I) + INTEGER, INTENT(IN) :: I + INTEGER, pointer :: MM ! { dg-error "conflicts with ELEMENTAL" } + END FUNCTION MM +END MODULE Test diff --git a/Fortran/gfortran/regression/elemental_result_2.f90 b/Fortran/gfortran/regression/elemental_result_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_result_2.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! +! Test part of the fix for PR99124 which adds errors for class results +! That violate F2018, C15100. +! +! Contributed by Gerhard Steinmetz +! +module m + type t + integer :: i + contains + procedure :: f + generic :: operator(+) => f + end type +contains + elemental function f(a, b) & + result(c) ! { dg-error "shall not have an ALLOCATABLE or POINTER attribute" } + class(t), intent(in) :: a, b + class(t), allocatable :: c + c = t(a%i + b%i) + end + elemental function g(a, b) & + result(c) ! { dg-error "shall not have an ALLOCATABLE or POINTER attribute" } + class(t), intent(in) :: a, b + class(t), pointer :: c + c => null () + end + elemental function h(a, b) & ! { dg-error "must have a scalar result" } + result(c) ! { dg-error "must be dummy, allocatable or pointer" } + class(t), intent(in) :: a, b + class(t) :: c(2) + end +end diff --git a/Fortran/gfortran/regression/elemental_scalar_args_1.f90 b/Fortran/gfortran/regression/elemental_scalar_args_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_scalar_args_1.f90 @@ -0,0 +1,86 @@ +! { dg-do compile } +! Test the fix for PR43843, in which the temporary for b(1) in +! test_member was an indirect reference, rather then the value. +! +! Contributed by Kyle Horne +! Reported by Tobias Burnus +! Reported by Harald Anlauf (PR43841) +! +module polar_mod + implicit none + complex, parameter :: i = (0.0,1.0) + real, parameter :: pi = 3.14159265359 + real, parameter :: e = exp (1.0) + type :: polar_t + real :: l, th + end type + type(polar_t) :: one = polar_t (1.0, 0) + interface operator(/) + module procedure div_pp + end interface + interface operator(.ne.) + module procedure ne_pp + end interface +contains + elemental function div_pp(u,v) result(o) + type(polar_t), intent(in) :: u, v + type(polar_t) :: o + complex :: a, b, c + a = u%l*exp (i*u%th*pi) + b = v%l*exp (i*v%th*pi) + c = a/b + o%l = abs (c) + o%th = atan2 (imag (c), real (c))/pi + end function div_pp + elemental function ne_pp(u,v) result(o) + type(polar_t), intent(in) :: u, v + LOGICAL :: o + if (u%l .ne. v%l) then + o = .true. + else if (u%th .ne. v%th) then + o = .true. + else + o = .false. + end if + end function ne_pp +end module polar_mod + +program main + use polar_mod + implicit none + call test_member + call test_other + call test_scalar + call test_real +contains + subroutine test_member + type(polar_t), dimension(3) :: b + b = polar_t (2.0,0.5) + b(:) = b(:)/b(1) + if (any (b .ne. one)) STOP 1 + end subroutine test_member + subroutine test_other + type(polar_t), dimension(3) :: b + type(polar_t), dimension(3) :: c + b = polar_t (3.0,1.0) + c = polar_t (3.0,1.0) + b(:) = b(:)/c(1) + if (any (b .ne. one)) STOP 2 + end subroutine test_other + subroutine test_scalar + type(polar_t), dimension(3) :: b + type(polar_t) :: c + b = polar_t (4.0,1.5) + c = b(1) + b(:) = b(:)/c + if (any (b .ne. one)) STOP 3 + end subroutine test_scalar + subroutine test_real + real,dimension(3) :: b + real :: real_one + b = 2.0 + real_one = b(2)/b(1) + b(:) = b(:)/b(1) + if (any (b .ne. real_one)) STOP 4 + end subroutine test_real +end program main diff --git a/Fortran/gfortran/regression/elemental_scalar_args_2.f90 b/Fortran/gfortran/regression/elemental_scalar_args_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_scalar_args_2.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! Test the fix for PR55618, in which character scalar function arguments to +! elemental functions would gain an extra indirect reference thus causing +! failures in Vst17.f95, Vst 30.f95 and Vst31.f95 in the iso_varying_string +! testsuite, where elemental tests are done. +! +! Reported by Tobias Burnus +! + integer, dimension (2) :: i = [1,2] + integer :: j = 64 + character (len = 2) :: chr1 = "lm" + character (len = 1), dimension (2) :: chr2 = ["r", "s"] + if (any (foo (i, bar()) .ne. ["a", "b"])) STOP 1! This would fail + if (any (foo (i, "xy") .ne. ["x", "y"])) STOP 2! OK - not a function + if (any (foo (i, chr1) .ne. ["l", "m"])) STOP 3! ditto + if (any (foo (i, char (j)) .ne. ["A", "B"])) STOP 4! This would fail + if (any (foo (i, chr2) .ne. ["s", "u"])) STOP 5! OK - not a scalar + if (any (foo (i, bar2()) .ne. ["e", "g"])) STOP 6! OK - not a scalar function +contains + elemental character(len = 1) function foo (arg1, arg2) + integer, intent (in) :: arg1 + character(len = *), intent (in) :: arg2 + if (len (arg2) > 1) then + foo = arg2(arg1:arg1) + else + foo = char (ichar (arg2) + arg1) + end if + end function + character(len = 2) function bar () + bar = "ab" + end function + function bar2 () result(res) + character (len = 1), dimension(2) :: res + res = ["d", "e"] + end function +end diff --git a/Fortran/gfortran/regression/elemental_subroutine_1.f90 b/Fortran/gfortran/regression/elemental_subroutine_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_subroutine_1.f90 @@ -0,0 +1,60 @@ +! { dg-do run } +! Test the fix for pr22146, where and elemental subroutine with +! array actual arguments would cause an ICE in gfc_conv_function_call. +! The module is the original test case and the rest is a basic +! functional test of the scalarization of the function call. +! +! Contributed by Erik Edelmann +! and Paul Thomas + + module pr22146 + +contains + + elemental subroutine foo(a) + integer, intent(out) :: a + a = 0 + end subroutine foo + + subroutine bar() + integer :: a(10) + call foo(a) + end subroutine bar + +end module pr22146 + + use pr22146 + real, dimension (2) :: x, y + real :: u, v + x = (/1.0, 2.0/) + u = 42.0 + + call bar () + +! Check the various combinations of scalar and array. + call foobar (x, y) + if (any(y.ne.-x)) STOP 1 + + call foobar (u, y) + if (any(y.ne.-42.0)) STOP 2 + + call foobar (u, v) + if (v.ne.-42.0) STOP 3 + + v = 2.0 + call foobar (v, x) + if (any(x /= -2.0)) STOP 4 + +! Test an expression in the INTENT(IN) argument + x = (/1.0, 2.0/) + call foobar (cos (x) + u, y) + if (any(abs (y + cos (x) + u) .gt. 4.0e-6)) STOP 5 + +contains + + elemental subroutine foobar (a, b) + real, intent(IN) :: a + real, intent(out) :: b + b = -a + end subroutine foobar +end diff --git a/Fortran/gfortran/regression/elemental_subroutine_10.f90 b/Fortran/gfortran/regression/elemental_subroutine_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_subroutine_10.f90 @@ -0,0 +1,68 @@ +! { dg-do run } +! +! PR fortran/60066 +! +! Contributed by F Martinez Fadrique +! +! Fixed by the patch for PR59906 but adds another, different test. +! +module m_assertion_character + implicit none + type :: t_assertion_character + character(len=8) :: name + contains + procedure :: assertion_character + procedure :: write => assertion_array_write + end type t_assertion_character +contains + impure elemental subroutine assertion_character( ast, name ) + class(t_assertion_character), intent(out) :: ast + character(len=*), intent(in) :: name + ast%name = name + end subroutine assertion_character + subroutine assertion_array_write( ast, unit ) + class(t_assertion_character), intent(in) :: ast + character(*), intent(inOUT) :: unit + write(unit,*) trim (unit(2:len(unit)))//trim (ast%name) + end subroutine assertion_array_write +end module m_assertion_character + +module m_assertion_array_character + use m_assertion_character + implicit none + type :: t_assertion_array_character + type(t_assertion_character), dimension(:), allocatable :: rast + contains + procedure :: assertion_array_character + procedure :: write => assertion_array_character_write + end type t_assertion_array_character +contains + subroutine assertion_array_character( ast, name, nast ) + class(t_assertion_array_character), intent(out) :: ast + character(len=*), intent(in) :: name + integer, intent(in) :: nast + integer :: i + allocate ( ast%rast(nast) ) + call ast%rast%assertion_character ( name ) + end subroutine assertion_array_character + subroutine assertion_array_character_write( ast, unit ) + class(t_assertion_array_character), intent(in) :: ast + CHARACTER(*), intent(inOUT) :: unit + integer :: i + do i = 1, size (ast%rast) + call ast%rast(i)%write (unit) + end do + end subroutine assertion_array_character_write +end module m_assertion_array_character + +program main + use m_assertion_array_character + implicit none + type(t_assertion_array_character) :: ast + character(len=8) :: name + character (26) :: line = '' + name = 'test' + call ast%assertion_array_character ( name, 5 ) + call ast%write (line) + if (line(2:len (line)) .ne. "testtesttesttesttest") STOP 1 +end program main diff --git a/Fortran/gfortran/regression/elemental_subroutine_11.f90 b/Fortran/gfortran/regression/elemental_subroutine_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_subroutine_11.f90 @@ -0,0 +1,248 @@ +! { dg-do run } +! +! Check error of pr65894 are fixed. +! Contributed by Juergen Reuter +! Andre Vehreschild + +module simple_string + ! Minimal iso_varying_string implementation needed. + implicit none + + type string_t + private + character(len=1), dimension(:), allocatable :: cs + end type string_t + +contains + elemental function var_str(c) result (s) + character(*), intent(in) :: c + type(string_t) :: s + integer :: l,i + + l = len(c) + allocate(s%cs(l)) + forall(i = 1:l) + s%cs(i) = c(i:i) + end forall + end function var_str + +end module simple_string +module model_data + use simple_string + + implicit none + private + + public :: field_data_t + public :: model_data_t + + type :: field_data_t + !private + integer :: pdg = 0 + type(string_t), dimension(:), allocatable :: name + contains + procedure :: init => field_data_init + procedure :: get_pdg => field_data_get_pdg + end type field_data_t + + type :: model_data_t + !private + type(string_t) :: name + type(field_data_t), dimension(:), allocatable :: field + contains + generic :: init => model_data_init + procedure, private :: model_data_init + generic :: get_pdg => & + model_data_get_field_pdg_index + procedure, private :: model_data_get_field_pdg_index + generic :: get_field_ptr => & + model_data_get_field_ptr_pdg + procedure, private :: model_data_get_field_ptr_pdg + procedure :: get_field_ptr_by_index => model_data_get_field_ptr_index + procedure :: init_sm_test => model_data_init_sm_test + end type model_data_t + +contains + + subroutine field_data_init (prt, pdg) + class(field_data_t), intent(out) :: prt + integer, intent(in) :: pdg + prt%pdg = pdg + end subroutine field_data_init + + elemental function field_data_get_pdg (prt) result (pdg) + integer :: pdg + class(field_data_t), intent(in) :: prt + pdg = prt%pdg + end function field_data_get_pdg + + subroutine model_data_init (model, name, & + n_field) + class(model_data_t), intent(out) :: model + type(string_t), intent(in) :: name + integer, intent(in) :: n_field + model%name = name + allocate (model%field (n_field)) + end subroutine model_data_init + + function model_data_get_field_pdg_index (model, i) result (pdg) + class(model_data_t), intent(in) :: model + integer, intent(in) :: i + integer :: pdg + pdg = model%field(i)%get_pdg () + end function model_data_get_field_pdg_index + + function model_data_get_field_ptr_pdg (model, pdg, check) result (ptr) + class(model_data_t), intent(in), target :: model + integer, intent(in) :: pdg + logical, intent(in), optional :: check + type(field_data_t), pointer :: ptr + integer :: i, pdg_abs + if (pdg == 0) then + ptr => null () + return + end if + pdg_abs = abs (pdg) + if (lbound(model%field, 1) /= 1) STOP 1 + if (ubound(model%field, 1) /= 19) STOP 2 + do i = 1, size (model%field) + if (model%field(i)%get_pdg () == pdg_abs) then + ptr => model%field(i) + return + end if + end do + ptr => null () + end function model_data_get_field_ptr_pdg + + function model_data_get_field_ptr_index (model, i) result (ptr) + class(model_data_t), intent(in), target :: model + integer, intent(in) :: i + type(field_data_t), pointer :: ptr + if (lbound(model%field, 1) /= 1) STOP 3 + if (ubound(model%field, 1) /= 19) STOP 4 + ptr => model%field(i) + end function model_data_get_field_ptr_index + + subroutine model_data_init_sm_test (model) + class(model_data_t), intent(out) :: model + type(field_data_t), pointer :: field + integer, parameter :: n_field = 19 + call model%init (var_str ("SM_test"), & + n_field) + field => model%get_field_ptr_by_index (1) + call field%init (1) + end subroutine model_data_init_sm_test + +end module model_data + +module flavors + use model_data + + implicit none + private + + public :: flavor_t + + type :: flavor_t + private + integer :: f = 0 + type(field_data_t), pointer :: field_data => null () + contains + generic :: init => & + flavor_init0_model + procedure, private :: flavor_init0_model + end type flavor_t + +contains + + impure elemental subroutine flavor_init0_model (flv, f, model) + class(flavor_t), intent(inout) :: flv + integer, intent(in) :: f + class(model_data_t), intent(in), target :: model + ! Check the field l/ubound at various stages, because w/o the patch + ! the bounds get mixed up. + if (lbound(model%field, 1) /= 1) STOP 5 + if (ubound(model%field, 1) /= 19) STOP 6 + flv%f = f + flv%field_data => model%get_field_ptr (f, check=.true.) + end subroutine flavor_init0_model +end module flavors + +module beams + use model_data + use flavors + implicit none + private + public :: beam_1 + public :: beam_2 +contains + subroutine beam_1 (u) + integer, intent(in) :: u + type(flavor_t), dimension(2) :: flv + real, dimension(2) :: pol_f + type(model_data_t), target :: model + call model%init_sm_test () + call flv%init ([1,-1], model) + pol_f(1) = 0.5 + end subroutine beam_1 + subroutine beam_2 (u, model) + integer, intent(in) :: u + type(flavor_t), dimension(2) :: flv + real, dimension(2) :: pol_f + class(model_data_t), intent(in), target :: model + call flv%init ([1,-1], model) + pol_f(1) = 0.5 + end subroutine beam_2 +end module beams + +module evaluators + ! This module is just here for a compile check. + implicit none + private + type :: quantum_numbers_mask_t + contains + generic :: operator(.or.) => quantum_numbers_mask_or + procedure, private :: quantum_numbers_mask_or + end type quantum_numbers_mask_t + + type :: index_map_t + integer, dimension(:), allocatable :: entry + end type index_map_t + type :: prt_mask_t + logical, dimension(:), allocatable :: entry + end type prt_mask_t + type :: qn_mask_array_t + type(quantum_numbers_mask_t), dimension(:), allocatable :: mask + end type qn_mask_array_t + +contains + elemental function quantum_numbers_mask_or (mask1, mask2) result (mask) + type(quantum_numbers_mask_t) :: mask + class(quantum_numbers_mask_t), intent(in) :: mask1, mask2 + end function quantum_numbers_mask_or + + subroutine make_product_interaction & + (prt_is_connected, qn_mask_in, qn_mask_rest) + type(prt_mask_t), dimension(2), intent(in) :: prt_is_connected + type(qn_mask_array_t), dimension(2), intent(in) :: qn_mask_in + type(quantum_numbers_mask_t), intent(in) :: qn_mask_rest + type(index_map_t), dimension(2) :: prt_index_in + integer :: i + type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask + allocate (qn_mask (2)) + do i = 1, 2 + qn_mask(prt_index_in(i)%entry) = & + pack (qn_mask_in(i)%mask, prt_is_connected(i)%entry) & + .or. qn_mask_rest + ! Without the patch above line produced an ICE. + end do + end subroutine make_product_interaction +end module evaluators +program main + use beams + use model_data + type(model_data_t) :: model + call model%init_sm_test() + call beam_1 (6) + call beam_2 (6, model) +end program main diff --git a/Fortran/gfortran/regression/elemental_subroutine_2.f90 b/Fortran/gfortran/regression/elemental_subroutine_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_subroutine_2.f90 @@ -0,0 +1,64 @@ +! { dg-do run } +! Test the fix for pr22146, where and elemental subroutine with +! array actual arguments would cause an ICE in gfc_conv_function_call. +! This test checks that the main uses for elemental subroutines work +! correctly; namely, as module procedures and as procedures called +! from elemental functions. The compiler would ICE on the former with +! the first version of the patch. +! +! Contributed by Paul Thomas + +module type + type itype + integer :: i + character(1) :: ch + end type itype +end module type + +module assign + interface assignment (=) + module procedure itype_to_int + end interface +contains + elemental subroutine itype_to_int (i, it) + use type + type(itype), intent(in) :: it + integer, intent(out) :: i + i = it%i + end subroutine itype_to_int + + elemental function i_from_itype (it) result (i) + use type + type(itype), intent(in) :: it + integer :: i + i = it + end function i_from_itype + +end module assign + +program test_assign + use type + use assign + type(itype) :: x(2, 2) + integer :: i(2, 2) + +! Test an elemental subroutine call from an elementary function. + x = reshape ((/(itype (j, "a"), j = 1,4)/), (/2,2/)) + forall (j = 1:2, k = 1:2) + i(j, k) = i_from_itype (x (j, k)) + end forall + if (any(reshape (i, (/4/)).ne.(/1,2,3,4/))) STOP 1 + +! Check the interface assignment (not part of the patch). + x = reshape ((/(itype (j**2, "b"), j = 1,4)/), (/2,2/)) + i = x + if (any(reshape (i, (/4/)).ne.(/1,4,9,16/))) STOP 2 + +! Use the interface assignment within a forall block. + x = reshape ((/(itype (j**3, "c"), j = 1,4)/), (/2,2/)) + forall (j = 1:2, k = 1:2) + i(j, k) = x (j, k) + end forall + if (any(reshape (i, (/4/)).ne.(/1,8,27,64/))) STOP 3 + +end program test_assign diff --git a/Fortran/gfortran/regression/elemental_subroutine_3.f90 b/Fortran/gfortran/regression/elemental_subroutine_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_subroutine_3.f90 @@ -0,0 +1,50 @@ +! { dg-do run } +! Test the fix for PR25746, in which dependency checking was not being +! done for elemental subroutines and therefore for interface assignments. +! +! This test is based on +! http://home.comcast.net/~kmbtib/Fortran_stuff/elem_assign.f90 +! as reported by Harald Anlauf in the PR. +! +module elem_assign + implicit none + type mytype + integer x + end type mytype + interface assignment(=) + module procedure myassign + end interface assignment(=) + contains + elemental subroutine myassign(x,y) + type(mytype), intent(out) :: x + type(mytype), intent(in) :: y +! Multiply the components by 2 to verify that this is being called. + x%x = y%x*2 + end subroutine myassign +end module elem_assign + +program test + use elem_assign + implicit none + type(mytype) :: y(6), x(6) = (/mytype(1),mytype(20),mytype(300),& + mytype(4000),mytype(50000),& + mytype(1000000)/) + type(mytype) :: z(2, 3) +! The original case - dependency between lhs and rhs. + x = x((/2,3,1,4,5,6/)) + if (any(x%x .ne. (/40, 600, 2, 8000, 100000, 2000000/))) STOP 1 +! Slightly more elborate case with non-trivial array ref on lhs. + x(4:1:-1) = x((/1,3,2,4/)) + if (any(x%x .ne. (/16000, 1200, 4, 80, 100000, 2000000/))) STOP 2 +! Check that no-dependence case works.... + y = x + if (any(y%x .ne. (/32000, 2400, 8, 160, 200000, 4000000/))) STOP 3 +! ...and now a case that caused headaches during the preparation of the patch + x(2:5) = x(1:4) + if (any(x%x .ne. (/16000, 32000, 2400, 8, 160, 2000000/))) STOP 4 +! Check offsets are done correctly in multi-dimensional cases + z = reshape (x, (/2,3/)) + z(:, 3:2:-1) = z(:, 1:2) + y = reshape (z, (/6/)) + if (any(y%x .ne. (/ 64000, 128000, 19200, 64, 128000, 256000/))) STOP 5 +end program test diff --git a/Fortran/gfortran/regression/elemental_subroutine_4.f90 b/Fortran/gfortran/regression/elemental_subroutine_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_subroutine_4.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! Test the fix for PR25099, in which conformance checking was not being +! done for elemental subroutines and therefore for interface assignments. +! +! Contributed by Joost VandeVondele +! +module elem_assign + implicit none + type mytype + integer x + end type mytype + interface assignment(=) + module procedure myassign + end interface assignment(=) + contains + elemental subroutine myassign(x,y) + type(mytype), intent(out) :: x + type(mytype), intent(in) :: y + x%x = y%x + end subroutine myassign +end module elem_assign + + use elem_assign + integer :: I(2,2),J(2) + type (mytype) :: w(2,2), x(4), y(5), z(4) +! The original PR + CALL S(I,J) ! { dg-error "Incompatible ranks in elemental procedure" } +! Check interface assignments + x = w ! { dg-error "Incompatible ranks in elemental procedure" } + x = y ! { dg-error "Different shape for elemental procedure" } + x = z +CONTAINS + ELEMENTAL SUBROUTINE S(I,J) + INTEGER, INTENT(IN) :: I,J + END SUBROUTINE S +END diff --git a/Fortran/gfortran/regression/elemental_subroutine_5.f90 b/Fortran/gfortran/regression/elemental_subroutine_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_subroutine_5.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! PR fortran/33231 +! +! Elemental function: +! Intent OUT/INOUT dummy: Actual needs to be an array +! if any actual is an array +! +program prog +implicit none +integer :: i, j(2) +call sub(i,1,2) ! OK, only scalar +call sub(j,1,2) ! OK, scalar IN, array OUT +call sub(j,[1,2],3) ! OK, scalar & array IN, array OUT +call sub(j,[1,2],[1,2]) ! OK, all arrays + +call sub(i,1,2) ! OK, only scalar +call sub(i,[1,2],3) ! { dg-error "is a scalar" } +call sub(i,[1,2],[1,2]) ! { dg-error "is a scalar" } +contains +elemental subroutine sub(a,b,c) + integer :: func, a, b, c + intent(in) :: b,c + intent(out) :: a + a = b +c +end subroutine sub +end program prog diff --git a/Fortran/gfortran/regression/elemental_subroutine_6.f90 b/Fortran/gfortran/regression/elemental_subroutine_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_subroutine_6.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! PR35184 ICE in gfc_conv_array_index_offset +MODULE foo + TYPE, PUBLIC :: bar + PRIVATE + REAL :: value + END TYPE bar + INTERFACE ASSIGNMENT (=) + MODULE PROCEDURE assign_bar + END INTERFACE ASSIGNMENT (=) +CONTAINS + ELEMENTAL SUBROUTINE assign_bar (to, from) + TYPE(bar), INTENT(OUT) :: to + TYPE(bar), INTENT(IN) :: from + to%value= from%value + END SUBROUTINE + SUBROUTINE my_sub (in, out) + IMPLICIT NONE + TYPE(bar), DIMENSION(:,:), POINTER :: in + TYPE(bar), DIMENSION(:,:), POINTER :: out + ALLOCATE( out(1:42, 1:42) ) + out(1, 1:42) = in(1, 1:42) + END SUBROUTINE +END MODULE foo diff --git a/Fortran/gfortran/regression/elemental_subroutine_7.f90 b/Fortran/gfortran/regression/elemental_subroutine_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_subroutine_7.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! +! PR fortran/38669 +! Loop bounds temporaries used before being defined for elemental subroutines +! +! Original testcase by Harald Anlauf + +program gfcbu84_main + implicit none + integer :: jplev, k_lev + integer :: p(42) + real :: r(42) + integer, pointer :: q(:) + jplev = 42 + k_lev = 1 + call random_number (r) + p = 41 * r + 1 + allocate (q(jplev)) + + q = 0 + call tq_tvgh (q(k_lev:), p(k_lev:)) + if (any (p /= q)) STOP 1 + + q = 0 + call tq_tvgh (q(k_lev:), (p(k_lev:))) + if (any (p /= q)) STOP 2 + + q = 0 + call tq_tvgh (q(k_lev:), (p(p(k_lev:)))) + if (any (p(p) /= q)) STOP 3 + + deallocate (q) + + contains + elemental subroutine tq_tvgh (t, p) + integer ,intent (out) :: t + integer ,intent (in) :: p + t=p + end subroutine tq_tvgh +end program gfcbu84_main diff --git a/Fortran/gfortran/regression/elemental_subroutine_8.f90 b/Fortran/gfortran/regression/elemental_subroutine_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_subroutine_8.f90 @@ -0,0 +1,50 @@ +! { dg-do compile } +! +! PR fortran/58099 +! +! See also interpretation request F03-0130 in 09-217 and 10-006T5r1. +! +! - ELEMENTAL is only permitted for external names with PROCEDURE/INTERFACE +! but not for dummy arguments or proc-pointers +! - Using PROCEDURE with an elemental intrinsic as interface name a is valid, +! but doesn't make the proc-pointer/dummy argument elemental +! + + interface + elemental real function x(y) + real, intent(in) :: y + end function x + end interface + intrinsic :: sin + procedure(x) :: xx1 ! OK + procedure(x), pointer :: xx2 ! { dg-error "Procedure pointer 'xx2' at .1. shall not be elemental" } + procedure(real), pointer :: pp + procedure(sin) :: bar ! OK + procedure(sin), pointer :: foo ! { dg-error "Procedure pointer 'foo' at .1. shall not be elemental" } + pp => sin !OK +contains + subroutine sub1(z) ! { dg-error "Dummy procedure 'z' at .1. shall not be elemental" } + procedure(x) :: z + end subroutine sub1 + subroutine sub2(z) ! { dg-error "Procedure pointer 'z' at .1. shall not be elemental" } + procedure(x), pointer :: z + end subroutine sub2 + subroutine sub3(z) + interface + elemental real function z(y) ! { dg-error "Dummy procedure 'z' at .1. shall not be elemental" } + real, intent(in) :: y + end function z + end interface + end subroutine sub3 + subroutine sub4(z) + interface + elemental real function z(y) ! { dg-error "Procedure pointer 'z' at .1. shall not be elemental" } + real, intent(in) :: y + end function z + end interface + pointer :: z + end subroutine sub4 + subroutine sub5(z) ! { dg-error "Dummy procedure 'z' at .1. shall not be elemental" } + procedure(sin) :: z + end subroutine sub5 +end diff --git a/Fortran/gfortran/regression/elemental_subroutine_9.f90 b/Fortran/gfortran/regression/elemental_subroutine_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/elemental_subroutine_9.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! +! PR fortran/59906 +! +! Contributed by H Anlauf +! +! Failed generate character scalar for scalarized loop for elemantal call. +! +program x + implicit none + call y('bbb') +contains + + subroutine y(str) + character(len=*), intent(in) :: str + character(len=len_trim(str)) :: str_aux + character(len=3) :: str3 = 'abc' + + str_aux = str + + ! Compiled but did not give correct result + if (any (str_cmp((/'aaa','bbb'/), str) .neqv. [.FALSE.,.TRUE.])) STOP 1 + + ! Did not compile + if (any (str_cmp((/'bbb', 'aaa'/), str_aux) .neqv. [.TRUE.,.FALSE.])) STOP 2 + + ! Verify patch + if (any (str_cmp((/'bbb', 'aaa'/), str3) .neqv. [.FALSE.,.FALSE.])) STOP 3 + if (any (str_cmp((/'bbb', 'aaa'/), 'aaa') .neqv. [.FALSE.,.TRUE.])) STOP 4 + + end subroutine y + + elemental logical function str_cmp(str1, str2) + character(len=*), intent(in) :: str1 + character(len=*), intent(in) :: str2 + str_cmp = (str1 == str2) + end function str_cmp + +end program x diff --git a/Fortran/gfortran/regression/empty_derived_type.f90 b/Fortran/gfortran/regression/empty_derived_type.f90 --- /dev/null +++ b/Fortran/gfortran/regression/empty_derived_type.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +module stuff + implicit none + type, bind(C) :: junk ! { dg-warning "may be inaccessible by the C companion" } + ! Empty! + end type junk +end module stuff diff --git a/Fortran/gfortran/regression/empty_format_1.f90 b/Fortran/gfortran/regression/empty_format_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/empty_format_1.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR 17709 +! We weren't resetting the internal EOR flag correctly, so the second read +! wasn't advancing to the next line. +program main + integer io_unit + character*20 str + io_unit = 10 + open (unit=io_unit,status='scratch',form='formatted') + write (io_unit, '(A)') "Line1" + write (io_unit, '(A)') "Line2" + write (io_unit, '(A)') "Line3" + rewind (io_unit) + read (io_unit,'(A)') str + if (str .ne. "Line1") STOP 1 + read (io_unit,'()') + read (io_unit,'(A)') str + if (str .ne. "Line3") STOP 2 + close(unit=io_unit) +end + diff --git a/Fortran/gfortran/regression/empty_function_1.f90 b/Fortran/gfortran/regression/empty_function_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/empty_function_1.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! +! PR fortran/38252 +! FUNCTION rejected if both specification and execution part are empty +! +! Contributed by Daniel Kraft + +INTEGER FUNCTION test () +CONTAINS +END FUNCTION test diff --git a/Fortran/gfortran/regression/empty_label.f b/Fortran/gfortran/regression/empty_label.f --- /dev/null +++ b/Fortran/gfortran/regression/empty_label.f @@ -0,0 +1,4 @@ +C { dg-do compile } +100 ! { dg-error "Statement label without statement" } + end + diff --git a/Fortran/gfortran/regression/empty_label.f90 b/Fortran/gfortran/regression/empty_label.f90 --- /dev/null +++ b/Fortran/gfortran/regression/empty_label.f90 @@ -0,0 +1,3 @@ +! { dg-do compile } +100 ! { dg-error "Statement label without statement" } +end diff --git a/Fortran/gfortran/regression/empty_label_typedecl.f90 b/Fortran/gfortran/regression/empty_label_typedecl.f90 --- /dev/null +++ b/Fortran/gfortran/regression/empty_label_typedecl.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +subroutine s + type t + 1 ! { dg-error "Statement label without statement" } + end type +end subroutine diff --git a/Fortran/gfortran/regression/empty_type.f90 b/Fortran/gfortran/regression/empty_type.f90 --- /dev/null +++ b/Fortran/gfortran/regression/empty_type.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! PR fortran/34202 +! ICE on contruction of empty types +! Testcase contributed by Tobias Burnus + +program bug4a + implicit none + type bug4 + ! Intentionally left empty + end type bug4 + + type compound + type(bug4) b + end type compound + + type(bug4), parameter :: f = bug4() + type(compound), parameter :: g = compound(bug4()) +end program bug4a + diff --git a/Fortran/gfortran/regression/end_associate_label_1.f90 b/Fortran/gfortran/regression/end_associate_label_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/end_associate_label_1.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! PR fortran/50071 +! A label in an END ASSOCIATE statement was ignored; as a result, a GOTO +! to such a label was rejected. +! +! Contributed by Tobias Burnus + + integer :: i + associate (j => i) + goto 1 + print *, 'Hello' +1 end associate +end diff --git a/Fortran/gfortran/regression/end_block_label_1.f90 b/Fortran/gfortran/regression/end_block_label_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/end_block_label_1.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! PR fortran/50071 +! A label in an END BLOCK statement was ignored; as a result, a GOTO +! to such a label was rejected. +! +! Contributed by Tobias Burnus + + block + goto 1 + print *, 'Hello' +1 end block +end + diff --git a/Fortran/gfortran/regression/end_subroutine_1.f90 b/Fortran/gfortran/regression/end_subroutine_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/end_subroutine_1.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +interface + subroutine foo() + end + integer function bar() + end +end interface +contains + subroutine test() + end + integer function f() + f = 42 + end +end diff --git a/Fortran/gfortran/regression/end_subroutine_2.f90 b/Fortran/gfortran/regression/end_subroutine_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/end_subroutine_2.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +program main +interface + subroutine foo() + end + integer function bar() + end +end interface +contains + subroutine test() + end ! { dg-error "Fortran 2008: END statement instead of END SUBROUTINE" } + end subroutine ! To silence successive errors +end program + +subroutine test2() +contains + integer function f() + f = 42 + end ! { dg-error "Fortran 2008: END statement instead of END FUNCTION" } + end function ! To silence successive errors +end subroutine test2 + diff --git a/Fortran/gfortran/regression/endfile.f b/Fortran/gfortran/regression/endfile.f --- /dev/null +++ b/Fortran/gfortran/regression/endfile.f @@ -0,0 +1,18 @@ +! { dg-do run } +! PR25550 file data corrupted after reading end of file. +! Derived from example given in PR from Dale Ranta. +! Contributed by Jerry DeLisle + integer data + data=-1 + open(unit=11,status='scratch',form='unformatted') + write(11)data + read(11,end=1000 )data + STOP 1 + 1000 continue + rewind (11) + read(11)data + 1001 continue + if(data.ne.-1) STOP 1 + end + + diff --git a/Fortran/gfortran/regression/endfile.f90 b/Fortran/gfortran/regression/endfile.f90 --- /dev/null +++ b/Fortran/gfortran/regression/endfile.f90 @@ -0,0 +1,31 @@ +! { dg-do run { target fd_truncate } } +! pr18364 endfile does not truncate file. +! write out 20 records +! rewind +! read 10 records +! endfile +! close file +! open file +! detect file has only 10 records + implicit none + integer i,j + open(unit=10,file='test.dat',access='sequential',status='replace') + do i=1, 20 + write (10,'(I4)') i + end do + rewind(10) + do i=1,10 + read (10,'(I4)') j + end do + endfile(10) + close(10) + open(unit=10,file='test.dat',access='sequential',status='old') + do i=1,20 + read (10,'(I4)',end=99) j + end do + ! should never get here + STOP 1 + 99 continue ! end of file + if (j.ne.10) STOP 2 + close(10,status='delete') + end diff --git a/Fortran/gfortran/regression/endfile_2.f90 b/Fortran/gfortran/regression/endfile_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/endfile_2.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! pr18778 abort on endfile without opening unit + program test + implicit none + integer i + endfile(8) + rewind(8) + read(8,end=0023)i + STOP 1! should never get here + stop + 0023 continue + close(8,status='delete') + end diff --git a/Fortran/gfortran/regression/endfile_3.f90 b/Fortran/gfortran/regression/endfile_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/endfile_3.f90 @@ -0,0 +1,9 @@ +! { dg-do run { target fd_truncate } } +! pr44477 READ/WRITE not allowed after ENDFILE +!------------------------------------------- + open(10, form='formatted', & + action='write', position='rewind', status="scratch") + endfile(10) + write(10,'(a)') "aa" ! { dg-shouldfail "Cannot perform ENDFILE" } +end + diff --git a/Fortran/gfortran/regression/endfile_4.f90 b/Fortran/gfortran/regression/endfile_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/endfile_4.f90 @@ -0,0 +1,8 @@ +! { dg-do run { target fd_truncate } } +! pr44477 ENDFILE not allowed after ENDFILE +!------------------------------------------- + open(10, form='formatted', & + action='write', position='rewind', status="scratch") + endfile(10) + endfile(10) ! { dg-shouldfail "Cannot perform ENDFILE" } +end diff --git a/Fortran/gfortran/regression/entry_1.f90 b/Fortran/gfortran/regression/entry_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_1.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! Test alternate entry points in a module procedure +! Also check that references to sibling entry points are resolved correctly. +module m +contains +subroutine indirecta (p) + call p (3, 4) +end subroutine +subroutine indirectb (p) + call p (5) +end subroutine + +subroutine test1 + implicit none + call indirecta (foo) + call indirectb (bar) +end subroutine + +subroutine foo(a, b) + integer a, b + logical, save :: was_foo = .false. + if ((a .ne. 3) .or. (b .ne. 4)) STOP 1 + was_foo = .true. +entry bar(a) + if (was_foo) then + if ((a .ne. 3) .or. (b .ne. 4)) STOP 2 + else + if (a .ne. 5) STOP 3 + end if + was_foo = .false. +end subroutine + +subroutine test2 + call foo (3, 4) + call bar (5) +end subroutine +end module + +program p + use m + call foo (3, 4) + call bar (5) + call test1 () + call test2 () +end program diff --git a/Fortran/gfortran/regression/entry_10.f90 b/Fortran/gfortran/regression/entry_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_10.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! Test fix for PR31474, in which the use of ENTRYs as module +! procedures in a generic interface would cause an internal error. +! +! Contributed by Michael Richmond +! +module a + interface b + module procedure c, d + end interface +contains + real function d (i) + real c, i + integer j + d = 1.0 + return + entry c (j) + d = 2.0 + end function + real function e (i) + real f, i + integer j + e = 3.0 + return + entry f (j) + e = 4.0 + end function +end module + + use a + if (b (1.0) .ne. 1.0) STOP 1 + if (b (1 ) .ne. 2.0) STOP 2 + if (e (1.0) .ne. 3.0) STOP 3 + if (f (1 ) .ne. 4.0) STOP 4 +end diff --git a/Fortran/gfortran/regression/entry_11.f90 b/Fortran/gfortran/regression/entry_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_11.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! PR31609 module that calls a contained function with an ENTRY point +! Test case derived from the PR + +MODULE ksbin1_aux_mod + CONTAINS + SUBROUTINE sub + i = k() + END SUBROUTINE sub + FUNCTION j () + print *, "in j" + j = 111 + ENTRY k () + print *, "in k" + k = 222 + END FUNCTION j +END MODULE ksbin1_aux_mod + +program testit + use ksbin1_aux_mod + l = j() + print *, l + l = k() + print *, l +end program testit \ No newline at end of file diff --git a/Fortran/gfortran/regression/entry_12.f90 b/Fortran/gfortran/regression/entry_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_12.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! Tests the fix for pr31609, where module procedure entries found +! themselves in the wrong namespace. This test checks that all +! combinations of generic and specific calls work correctly. +! +! Contributed by Paul Thomas as comment #8 to the pr. +! +MODULE ksbin1_aux_mod + interface foo + module procedure j + end interface + interface bar + module procedure k + end interface + interface foobar + module procedure j, k + end interface + CONTAINS + FUNCTION j () + j = 1 + return + ENTRY k (i) + k = 2 + END FUNCTION j +END MODULE ksbin1_aux_mod + + use ksbin1_aux_mod + if (any ((/foo (), bar (99), foobar (), foobar (99), j (), k (99)/) .ne. & + (/1, 2, 1, 2, 1, 2/))) STOP 1 +end diff --git a/Fortran/gfortran/regression/entry_13.f90 b/Fortran/gfortran/regression/entry_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_13.f90 @@ -0,0 +1,78 @@ +! { dg-do run } +! Tests the fix for pr31214, in which the typespec for the entry would be lost, +! thereby causing the function to be disallowed, since the function and entry +! types did not match. +! +! Contributed by Joost VandeVondele +! +module type_mod + implicit none + + type x + real x + end type x + type y + real x + end type y + type z + real x + end type z + + interface assignment(=) + module procedure equals + end interface assignment(=) + + interface operator(//) + module procedure a_op_b, b_op_a + end interface operator(//) + + interface operator(==) + module procedure a_po_b, b_po_a + end interface operator(==) + + contains + subroutine equals(x,y) + type(z), intent(in) :: y + type(z), intent(out) :: x + + x%x = y%x + end subroutine equals + + function a_op_b(a,b) + type(x), intent(in) :: a + type(y), intent(in) :: b + type(z) a_op_b + type(z) b_op_a + a_op_b%x = a%x + b%x + return + entry b_op_a(b,a) + b_op_a%x = a%x - b%x + end function a_op_b + + function a_po_b(a,b) + type(x), intent(in) :: a + type(y), intent(in) :: b + type(z) a_po_b + type(z) b_po_a + entry b_po_a(b,a) + a_po_b%x = a%x/b%x + end function a_po_b +end module type_mod + +program test + use type_mod + implicit none + type(x) :: x1 = x(19.0_4) + type(y) :: y1 = y(7.0_4) + type(z) z1 + + z1 = x1//y1 + if (abs(z1%x - (19.0_4 + 7.0_4)) > epsilon(x1%x)) STOP 1 + z1 = y1//x1 + if (abs(z1%x - (19.0_4 - 7.0_4)) > epsilon(x1%x)) STOP 2 + + z1 = x1==y1 + if (abs(z1%x - 19.0_4/7.0_4) > epsilon(x1%x)) STOP 3 + z1 = y1==x1 + if (abs(z1%x - 19.0_4/7.0_4) > epsilon(x1%x)) STOP 4 +end program test diff --git a/Fortran/gfortran/regression/entry_14.f90 b/Fortran/gfortran/regression/entry_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_14.f90 @@ -0,0 +1,101 @@ +! { dg-do run } +! +! PR fortran/34137 +! +! Entry was previously not possible in a module. +! Checks also whether the different result combinations +! work properly. +! +module m1 + implicit none +contains +function func(a) + implicit none + integer :: a, func + real :: ent + func = a*4 + return +entry ent(a) + ent = -a*2.0 + return +end function func +end module m1 + +module m2 + implicit none +contains +function func(a) + implicit none + integer :: a, func + real :: func2 + func = a*8 + return +entry ent(a) result(func2) + func2 = -a*4.0 + return +end function func +end module m2 + +module m3 + implicit none +contains +function func(a) result(res) + implicit none + integer :: a, res + real :: func2 + res = a*12 + return +entry ent(a) result(func2) + func2 = -a*6.0 + return +end function func +end module m3 + + +module m4 + implicit none +contains +function func(a) result(res) + implicit none + integer :: a, res + real :: ent + res = a*16 + return +entry ent(a) + ent = -a*8.0 + return +end function func +end module m4 + +program main + implicit none + call test1() + call test2() + call test3() + call test4() +contains + subroutine test1() + use m1 + implicit none + if(func(3) /= 12) STOP 1 + if(abs(ent(7) + 14.0) > tiny(1.0)) STOP 2 + end subroutine test1 + subroutine test2() + use m2 + implicit none + if(func(9) /= 72) STOP 3 + if(abs(ent(11) + 44.0) > tiny(1.0)) STOP 4 + end subroutine test2 + subroutine test3() + use m3 + implicit none + if(func(13) /= 156) STOP 5 + if(abs(ent(17) + 102.0) > tiny(1.0)) STOP 6 + end subroutine test3 + subroutine test4() + use m4 + implicit none + if(func(23) /= 368) STOP 7 + if(abs(ent(27) + 216.0) > tiny(1.0)) STOP 8 + end subroutine test4 +end program main diff --git a/Fortran/gfortran/regression/entry_15.f90 b/Fortran/gfortran/regression/entry_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_15.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! +! PR fortran/34137 +! +! Entry was previously not possible in a module. +! Checks also whether the different result combinations +! work properly. +! +module m2 + implicit none +contains +function func(a) + implicit none + integer :: a, func + real :: func2 + func = a*8 + return +entry ent(a) result(func2) + ent = -a*4.0 ! { dg-error "is not a variable" } + return +end function func +end module m2 + +module m3 + implicit none +contains +function func(a) result(res) + implicit none + integer :: a, res + real :: func2 + res = a*12 + return +entry ent(a) result(func2) + ent = -a*6.0 ! { dg-error "is not a variable" } + return +end function func +end module m3 diff --git a/Fortran/gfortran/regression/entry_16.f90 b/Fortran/gfortran/regression/entry_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_16.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! Tests the fix for PR33499 in which the ENTRY cx_radc was not +! getting its TYPE. +! +! Contributed by Michael Richmond +! +MODULE complex + IMPLICIT NONE + PRIVATE + PUBLIC :: cx, OPERATOR(+), OPERATOR(.eq.) + TYPE cx + integer :: re + integer :: im + END TYPE cx + INTERFACE OPERATOR (+) + MODULE PROCEDURE cx_cadr, cx_radc + END INTERFACE + INTERFACE OPERATOR (.eq.) + MODULE PROCEDURE cx_eq + END INTERFACE + CONTAINS + FUNCTION cx_cadr(z, r) + ENTRY cx_radc(r, z) + TYPE (cx) :: cx_cadr, cx_radc + TYPE (cx), INTENT(IN) :: z + integer, INTENT(IN) :: r + cx_cadr%re = z%re + r + cx_cadr%im = z%im + END FUNCTION cx_cadr + FUNCTION cx_eq(u, v) + TYPE (cx), INTENT(IN) :: u, v + logical :: cx_eq + cx_eq = (u%re .eq. v%re) .and. (u%im .eq. v%im) + END FUNCTION cx_eq +END MODULE complex + + use complex + type(cx) :: a = cx (1, 2), c, d + logical :: f + integer :: b = 3 + if (.not.((a + b) .eq. (b + a))) STOP 1 + if (.not.((a + b) .eq. cx (4, 2))) STOP 2 +end diff --git a/Fortran/gfortran/regression/entry_17.f90 b/Fortran/gfortran/regression/entry_17.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_17.f90 @@ -0,0 +1,55 @@ +function test1(n) + integer :: n + character(n) :: test1 + character(n) :: bar1 + test1 = "" + return +entry bar1() + bar1 = "" +end function test1 + +function test2() + character(1) :: test2 + character(1) :: bar2 + test2 = "" + return +entry bar2() + bar2 = "" +end function test2 + +function test3() ! { dg-warning "Obsolescent feature" } + character(*) :: test3 + character(*) :: bar3 ! { dg-warning "Obsolescent feature" } + test3 = "" + return +entry bar3() + bar3 = "" +end function test3 + +function test4(n) ! { dg-warning "returning variables of different string lengths" } + integer :: n + character(n) :: test4 + character(*) :: bar4 ! { dg-warning "Obsolescent feature" } + test4 = "" + return +entry bar4() + bar4 = "" +end function test4 + +function test5() ! { dg-warning "returning variables of different string lengths" } + character(1) :: test5 + character(2) :: bar5 + test5 = "" + return +entry bar5() + bar5 = "" +end function test5 + +function test6() ! { dg-warning "Obsolescent feature|returning variables of different string lengths" } + character(*) :: test6 + character(2) :: bar6 + test6 = "" + return +entry bar6() + bar6 = "" +end function test6 diff --git a/Fortran/gfortran/regression/entry_18.f90 b/Fortran/gfortran/regression/entry_18.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_18.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! Test fix for PR37583, in which: +! (i) the reference to glocal prior to the ENTRY caused an internal +! error and +! (ii) the need for a RECURSIVE attribute was ignored. +! +! Contributed by Arjen Markus +! +module gsub +contains +recursive subroutine suba( g ) ! prefix with "RECURSIVE" + interface + real function g(x) + real x + end function + end interface + real :: x, y + call mysub( glocala ) + return +entry glocala( x, y ) + y = x +end subroutine +subroutine subb( g ) + interface + real function g(x) + real x + end function + end interface + real :: x, y + call mysub( glocalb ) ! { dg-warning "Non-RECURSIVE" } + return +entry glocalb( x, y ) + y = x +end subroutine +end module diff --git a/Fortran/gfortran/regression/entry_19.f90 b/Fortran/gfortran/regression/entry_19.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_19.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +! +! Entry is obsolete in Fortran 2008 +! +subroutine foo() +entry bar() ! { dg-warning "Fortran 2008 obsolescent feature: ENTRY" } +end diff --git a/Fortran/gfortran/regression/entry_2.f90 b/Fortran/gfortran/regression/entry_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_2.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! Arguments to procedures with multiple entry points may be absent, however +! they are not optional, unless explicitly maked as such. +subroutine foo(i, a, b) + logical a(2, 2) + logical b(1) + ! Check we don't get an "DIM must not be optional" error + a = any(b, i) +entry bar() +end subroutine diff --git a/Fortran/gfortran/regression/entry_20.f90 b/Fortran/gfortran/regression/entry_20.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_20.f90 @@ -0,0 +1,148 @@ +! { dg-do compile } +! +! PR fortran/50898 +! A symbol was freed prematurely during resolution, +! despite remaining reachable +! +! Original testcase from + +MODULE MODULE_pmat2 + +IMPLICIT NONE + +INTERFACE cad1b; MODULE PROCEDURE cad1b; END INTERFACE +INTERFACE csb1b; MODULE PROCEDURE csb1b; END INTERFACE +INTERFACE copbt; MODULE PROCEDURE copbt; END INTERFACE +INTERFACE conbt; MODULE PROCEDURE conbt; END INTERFACE +INTERFACE copmb; MODULE PROCEDURE copmb; END INTERFACE +INTERFACE conmb; MODULE PROCEDURE conmb; END INTERFACE +INTERFACE copbm; MODULE PROCEDURE copbm; END INTERFACE +INTERFACE conbm; MODULE PROCEDURE conbm; END INTERFACE +INTERFACE mulvb; MODULE PROCEDURE mulvb; END INTERFACE +INTERFACE madvb; MODULE PROCEDURE madvb; END INTERFACE +INTERFACE msbvb; MODULE PROCEDURE msbvb; END INTERFACE +INTERFACE mulxb; MODULE PROCEDURE mulxb; END INTERFACE +INTERFACE madxb; MODULE PROCEDURE madxb; END INTERFACE +INTERFACE msbxb; MODULE PROCEDURE msbxb; END INTERFACE + +integer, parameter :: i_kind=4 +integer, parameter :: r_kind=4 +real(r_kind), parameter :: zero=0.0 +real(r_kind), parameter :: one=1.0 +real(r_kind), parameter :: two=2.0 + +CONTAINS + +SUBROUTINE cad1b(a,m1,mah1,mah2,mirror2) +implicit none +INTEGER(i_kind), INTENT(IN ) :: m1,mah1,mah2,mirror2 +REAL(r_kind), INTENT(INOUT) :: a(0:m1-1,-mah1:mah2) +RETURN +ENTRY csb1b(a,m1,mah1,mah2,mirror2) +END SUBROUTINE cad1b + +SUBROUTINE copbt(a,b,m1,m2,mah1,mah2) +implicit none +INTEGER(i_kind), INTENT(IN ) :: m1, m2, mah1, mah2 +REAL(r_kind), INTENT(IN ) :: a(m1,-mah1:mah2) +REAL(r_kind), INTENT( OUT) :: b(m2,-mah2:mah1) +RETURN +ENTRY conbt(a,b,m1,m2,mah1,mah2) +END SUBROUTINE copbt + +SUBROUTINE copmb(afull,aband,m1,m2,mah1,mah2) +implicit none +INTEGER(i_kind), INTENT(IN ) :: m1, m2, mah1, mah2 +REAL(r_kind), DIMENSION(m1,m2), INTENT(IN ) :: afull +REAL(r_kind), DIMENSION(m1,-mah1:mah2),INTENT( OUT) :: aband +RETURN +ENTRY conmb(afull,aband,m1,m2,mah1,mah2) +END SUBROUTINE copmb + +SUBROUTINE copbm(aband,afull,m1,m2,mah1,mah2) +implicit none +INTEGER(i_kind), INTENT(IN ) :: m1, m2, mah1, mah2 +REAL(r_kind), DIMENSION(m1,-mah1:mah2),INTENT(IN ) :: aband +REAL(r_kind), DIMENSION(m1,m2), INTENT( OUT) :: afull +RETURN +ENTRY conbm(aband,afull,m1,m2,mah1,mah2) +END SUBROUTINE copbm + +SUBROUTINE mulbb(a,b,c,m1,m2,mah1,mah2,mbh1,mbh2,mch1,mch2) +implicit none +INTEGER(i_kind), INTENT(IN ) :: m1, m2, mah1, mah2, mbh1, mbh2, mch1, mch2 +REAL(r_kind), INTENT(IN ) :: a(m1,-mah1:mah2), b(m2,-mbh1:mbh2) +REAL(r_kind), INTENT(INOUT) :: c(m1,-mch1:mch2) +INTEGER(i_kind) :: nch1, nch2, j, k, jpk, i1,i2 +c=zero +ENTRY madbb(a,b,c,m1,m2,mah1,mah2,mbh1,mbh2,mch1,mch2) +nch1=mah1+mbh1; nch2=mah2+mbh2 +IF(nch1 /= mch1 .OR. nch2 /= mch2)STOP 'In MULBB, dimensions inconsistent' +DO j=-mah1,mah2 + DO k=-mbh1,mbh2; jpk=j+k; i1=MAX(1,1-j); i2=MIN(m1,m2-j) + c(i1:i2,jpk)=c(i1:i2,jpk)+a(i1:i2,j)*b(j+i1:j+i2,k) + ENDDO +ENDDO +END SUBROUTINE mulbb + +SUBROUTINE MULVB(v1,a,v2, m1,m2,mah1,mah2) +implicit none +INTEGER(i_kind), INTENT(IN ) :: m1, m2, mah1, mah2 +REAL(r_kind), INTENT(IN ) :: v1(m1), a(m1,-mah1:mah2) +REAL(r_kind), INTENT( OUT) :: v2(m2) +INTEGER(i_kind) :: j, i1,i2 +v2=zero +ENTRY madvb(v1,a,v2, m1,m2,mah1,mah2) +DO j=-mah1,mah2; i1=MAX(1,1-j); i2=MIN(m1,m2-j) + v2(j+i1:j+i2)=v2(j+i1:j+i2)+v1(i1:i2)*a(i1:i2,j) +ENDDO +RETURN +ENTRY msbvb(v1,a,v2, m1,m2,mah1,mah2) +DO j=-mah1,mah2; i1=MAX(1,1-j); i2=MIN(m1,m2-j) + v2(j+i1:j+i2)=v2(j+i1:j+i2)-v1(i1:i2)*a(i1:i2,j) +ENDDO +END SUBROUTINE mulvb + +SUBROUTINE mulxb(v1,a,v2, m1,m2,mah1,mah2,my) +implicit none +INTEGER(i_kind), INTENT(IN ) :: m1, m2, mah1, mah2, my +REAL(r_kind), INTENT(IN ) :: v1(m1,my), a(m1,-mah1:mah2) +REAL(r_kind), INTENT( OUT) :: v2(m2,my) +INTEGER(i_kind) :: i,j +v2=zero +ENTRY madxb(v1,a,v2, m1,m2,mah1,mah2,my) +DO j=-mah1,mah2 + DO i=MAX(1,1-j),MIN(m1,m2-j); v2(j+i,:)=v2(j+i,:)+v1(i,:)*a(i,j); ENDDO +ENDDO +RETURN +ENTRY msbxb(v1,a,v2, m1,m2,mah1,mah2,my) +DO j=-mah1,mah2 + DO i=MAX(1,1-j),MIN(m1,m2-j); v2(j+i,:)=v2(j+i,:)-v1(i,:)*a(i,j); ENDDO +ENDDO +END SUBROUTINE mulxb + +SUBROUTINE mulyb(v1,a,v2, m1,m2,mah1,mah2,mx) +implicit none +INTEGER(i_kind), INTENT(IN ) :: m1, m2, mah1, mah2, mx +REAL(r_kind), INTENT(IN ) :: v1(mx,m1), a(m1,-mah1:mah2) +REAL(r_kind), INTENT( OUT) :: v2(mx,m2) +INTEGER(i_kind) :: i,j +v2=zero +ENTRY madyb(v1,a,v2, m1,m2,mah1,mah2,mx) +DO j=-mah1,mah2 + DO i=MAX(1,1-j),MIN(m1,m2-j) + v2(:,j+i)=v2(:,j+i)+v1(:,i)*a(i,j) + ENDDO +ENDDO +RETURN +ENTRY msbyb(v1,a,v2, m1,m2,mah1,mah2,mx) + DO j=-mah1,mah2 + DO i=MAX(1,1-j),MIN(m1,m2-j) + v2(:,j+i)=v2(:,j+i)-v1(:,i)*a(i,j) + ENDDO + ENDDO +RETURN +END SUBROUTINE mulyb + +END MODULE MODULE_pmat2 + diff --git a/Fortran/gfortran/regression/entry_21.f90 b/Fortran/gfortran/regression/entry_21.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_21.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! PR fortran/66044 +! +! Original code from Gerhard Steinmetz +! +subroutine p +end subroutine p + +entry e ! { dg-error "Unexpected ENTRY statement" } +end + +module m + type t + contains + entry e ! { dg-error "Unexpected ENTRY statement" } + end type +end module m diff --git a/Fortran/gfortran/regression/entry_22.f90 b/Fortran/gfortran/regression/entry_22.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_22.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-additional-options "-pedantic" } +! PR fortran/89981 - this used to give a wrong warning (error with +! -pedantic) +program main + call bar(i) + call baz(i) ! { dg-error "Type mismatch in argument" } +end program main +subroutine foo(r) + entry bar(i) + entry baz(r) +end subroutine foo diff --git a/Fortran/gfortran/regression/entry_23.f b/Fortran/gfortran/regression/entry_23.f --- /dev/null +++ b/Fortran/gfortran/regression/entry_23.f @@ -0,0 +1,57 @@ +! { dg-do run } +! PR 97799 - this used to segfault intermittently. +! Test case by George Hockney. + PROGRAM MAIN + IMPLICIT NONE + + character *(20) CA(4) ! four cells of length 20 + + call CHAR_ENTRY(CA) ! call char_sub through entry + + write (*,*) CA ! write result -- not needed for bug + call CHAR_SUB(CA) ! call char_sb directly -- not needed + write (*,*) CA ! write result -- not needed for bug + STOP + END + + + + SUBROUTINE CHAR_SUB(CARRAY) ! sets carray cells to 'Something' + IMPLICIT NONE + + CHARACTER*(*) CARRAY(*) + + integer i + integer nelts + + nelts = 4 ! same as size of array in main program + write (*,*) 'CHAR_SUB' + write (*,*) 'len(carray(1))', len(carray(1)) ! len is OK at 20 + call flush() ! since the next loop segfaults + do 1 i=1, nelts + CARRAY(i) = 'Something' + 1 continue + RETURN + END + + + SUBROUTINE TOP_ENTRY +! +! TOP_ENTRY is never called directly. It organizes entry points +! and sometimes saves variables for other entry points. Its +! signature does not matter for the failure +! + IMPLICIT NONE +! +! Declare input variables for all entry points. Just one here +! + CHARACTER*(*) CARRAY(*) +! +! Entry point CHAR_ENTRY +! + ENTRY CHAR_ENTRY( CARRAY) + CALL CHAR_SUB(CARRAY) + RETURN + + END SUBROUTINE TOP_ENTRY + diff --git a/Fortran/gfortran/regression/entry_24.f90 b/Fortran/gfortran/regression/entry_24.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_24.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! PR fortran/87737 - improve check on function entry characteristics + +function f() ! { dg-error "mismatched characteristics" } + character(:), allocatable :: f + character(1) :: g + f = 'f' + return +entry g() + g = 'g' +end + +function f2() ! { dg-error "mismatched characteristics" } + character(1) :: f2 + character(1), allocatable :: g2 + f2 = 'f' + return +entry g2() + g2 = 'g' +end diff --git a/Fortran/gfortran/regression/entry_25.f90 b/Fortran/gfortran/regression/entry_25.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_25.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR fortran/102311 - ICE during error recovery checking entry characteristics + +module m +contains + function f() ! { dg-error "mismatched characteristics" } + character(:), allocatable :: f + character(1) :: g + f = 'f' + entry g() + g = 'g' + end +end diff --git a/Fortran/gfortran/regression/entry_3.f90 b/Fortran/gfortran/regression/entry_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_3.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! Test assumed shape arrays in procedures with multiple entry points. +! Arguments that aren't present in all entry points must be treated like +! optional arguments. +module entry_4 +contains +subroutine foo(a) + integer, dimension(:) :: a + integer, dimension(:) :: b + a = (/1, 2/) + return +entry bar(b) + b = (/3, 4/) +end subroutine +end module + +program entry_4_prog + use entry_4 + integer :: a(2) + a = 0 + call foo(a) + if (any (a .ne. (/1, 2/))) STOP 1 + call bar(a) + if (any (a .ne. (/3, 4/))) STOP 2 +end program diff --git a/Fortran/gfortran/regression/entry_4.f90 b/Fortran/gfortran/regression/entry_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_4.f90 @@ -0,0 +1,28 @@ +! { dg-do compile { target i?86-*-* x86_64-*-* } } +function f1 () result (r) ! { dg-error "cannot be a POINTER" } +integer, pointer :: r +real e1 +allocate (r) +r = 6 +return +entry e1 () +e1 = 12 +entry e1a () +e1a = 13 +end function +function f2 () +integer, dimension (2, 7, 6) :: e2 ! { dg-error "cannot be an array" } +f2 = 6 +return +entry e2 () +e2 (:, :, :) = 2 +end function +integer(kind=8) function f3 () ! { dg-error "cannot be of type" } +complex(kind=8) e3 ! { dg-error "cannot be of type" } +f3 = 1 +return +entry e3 () +e3 = 2 +entry e3a () +e3a = 3 +end function diff --git a/Fortran/gfortran/regression/entry_5.f90 b/Fortran/gfortran/regression/entry_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_5.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR 24008 +! an argument list to the entry is required +REAL FUNCTION funct() + funct = 0.0 + RETURN +! + ENTRY enter RESULT (answer) ! { dg-error "Unclassifiable statement" } + answer = 1.0 + RETURN +END FUNCTION funct diff --git a/Fortran/gfortran/regression/entry_6.f90 b/Fortran/gfortran/regression/entry_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_6.f90 @@ -0,0 +1,54 @@ +! { dg-do run } +! Tests the fix for PR24558, which reported that module +! alternate function entries did not work. +! +! Contributed by Erik Edelmann +! +module foo +contains + function n1 (a) + integer :: n1, n2, a, b + integer, save :: c + c = a + n1 = c**3 + return + entry n2 (b) + n2 = c * b + n2 = n2**2 + return + end function n1 + function z1 (u) + complex :: z1, z2, u, v + z1 = (1.0, 2.0) * u + return + entry z2 (v) + z2 = (3, 4) * v + return + end function z1 + function n3 (d) + integer :: n3, d + n3 = n2(d) * n1(d) ! Check sibling references. + return + end function n3 + function c1 (a) + character(4) :: c1, c2, a, b + c1 = a + if (a .eq. "abcd") c1 = "ABCD" + return + entry c2 (b) + c2 = b + if (b .eq. "wxyz") c2 = "WXYZ" + return + end function c1 +end module foo + use foo + if (n1(9) .ne. 729) STOP 1 + if (n2(2) .ne. 324) STOP 2 + if (n3(19) .ne. 200564019) STOP 3 + if (c1("lmno") .ne. "lmno") STOP 4 + if (c1("abcd") .ne. "ABCD") STOP 5 + if (c2("lmno") .ne. "lmno") STOP 6 + if (c2("wxyz") .ne. "WXYZ") STOP 7 + if (z1((3,4)) .ne. (-5, 10)) STOP 8 + if (z2((5,6)) .ne. (-9, 38)) STOP 9 + end diff --git a/Fortran/gfortran/regression/entry_7.f90 b/Fortran/gfortran/regression/entry_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_7.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +! Check that PR20877 and PR25047 are fixed by the patch for +! PR24558. Both modules would emit the error: +! insert_bbt(): Duplicate key found! +! because of the prior references to a module function entry. +! +! Contributed by Joost VandeVondele +! +MODULE TT +CONTAINS + FUNCTION K(I) RESULT(J) + ENTRY J() ! { dg-error "conflicts with RESULT attribute" } + END FUNCTION K + + integer function foo () + character*4 bar ! { dg-error "type CHARACTER" } + foo = 21 + return + entry bar () + bar = "abcd" + end function +END MODULE TT diff --git a/Fortran/gfortran/regression/entry_8.f90 b/Fortran/gfortran/regression/entry_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_8.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! Check for PR 27478 + FUNCTION X() + ENTRY X1 + IF (X .GT. 0) CALL FOO(X) + IF (Y .GT. 0) CALL FOO(Y) + END + + FUNCTION TSL(PIN) + ENTRY TSL1(PIN) + IF (DBLE(TSL) .GT. PIN) TSL = 705.47 + TSL= PPP(TSL) + END diff --git a/Fortran/gfortran/regression/entry_9.f90 b/Fortran/gfortran/regression/entry_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_9.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! Check whether RESULT of ENTRY defaults to entry-name. +! PR fortran/30873 +! +! Contributed by Joost VandeVondele +! +MODULE M1 + CONTAINS + FUNCTION F2(K) + INTEGER :: F2,K + F2=E1(K) + END FUNCTION F2 + + RECURSIVE FUNCTION F1(I) + INTEGER :: F1,I,E1 + F1=F2(I) + RETURN + ENTRY E1(I) + E1=-I + RETURN + END FUNCTION F1 +END MODULE M1 + +program main + use m1 + if (E1(5) /= -5) STOP 1 + if (F2(4) /= -4) STOP 2 + if (F1(1) /= -1) STOP 3 +end program main diff --git a/Fortran/gfortran/regression/entry_array_specs_1.f90 b/Fortran/gfortran/regression/entry_array_specs_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_array_specs_1.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! Tests the fix for PR25091 and PR25092 in which mismatched array +! specifications between entries of the same procedure were not diagnosed. + +! Contributed by Joost VandeVondele + +! This was PR25091 - no diagnostic given on error + FUNCTION F1() RESULT(RES_F1) ! { dg-error "mismatched array specifications" } + INTEGER RES_F1(2,2) + INTEGER RES_E1(4) + ENTRY E1() RESULT(RES_E1) + END FUNCTION + +! This was PR25092 - no diagnostic given on error + FUNCTION F2() RESULT(RES_F2) ! { dg-error "mismatched array specifications" } + INTEGER :: RES_F2(4) + INTEGER :: RES_E2(3) + ENTRY E2() RESULT(RES_E2) + END FUNCTION + +! Check that the versions without explicit results give the error + FUNCTION F3() ! { dg-error "mismatched array specifications" } + INTEGER :: F3(4) + INTEGER :: E3(2,2) + ENTRY E3() + END FUNCTION + + FUNCTION F4() ! { dg-error "mismatched array specifications" } + INTEGER :: F4(4) + INTEGER :: E4(3) + ENTRY E4() + END FUNCTION + +! Check that conforming entries are OK. + FUNCTION F5() + INTEGER :: F5(4,5,6) + INTEGER :: E5(4,5,6) + ENTRY E5() + END FUNCTION diff --git a/Fortran/gfortran/regression/entry_array_specs_2.f b/Fortran/gfortran/regression/entry_array_specs_2.f --- /dev/null +++ b/Fortran/gfortran/regression/entry_array_specs_2.f @@ -0,0 +1,31 @@ +! { dg-do run } +! Tests the patch for PR30025, aka 25818, in which the initialization +! code for the array a, was causing a segfault in runtime for a call +! to x, since n is missing. +! +! COntributed by Elizabeth Yip + program test_entry + common // j + real a(10) + a(1) = 999. + call x + if (j .ne. 1) STOP 1 + call y(a,10) + if (j .ne. 2) STOP 2 + stop + end + subroutine x + common // j + real a(n) + j = 1 + return + entry y(a,n) + call foo(a(1)) + end + subroutine foo(a) + common // j + real a + j = 2 + return + end + diff --git a/Fortran/gfortran/regression/entry_array_specs_3.f90 b/Fortran/gfortran/regression/entry_array_specs_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_array_specs_3.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR fortran/34861, in which the test of conformity of the result array bounds +! would barf because they are not known at compile time in this case. +! +! Contributed by Dick Hendrickson +! +FUNCTION I_IMFUD0 ( IDA2 , NDS4, NDS3) RESULT(I_IMFUDP) + INTEGER :: NDS4, NDS3 + INTEGER :: IDA2(5,NDS4,NDS3,2) + INTEGER :: I_IMFUDP(SIZE(IDA2,1), SIZE(IDA2,2), SIZE(IDA2,3), SIZE(IDA2,4)) + ENTRY I_IMFUDX (NDS4, NDS3, IDA2) RESULT(I_IMFUDP) + ENTRY I_IMFUDY (NDS3, NDS4, IDA2) RESULT(I_IMFUDP) + ENTRY I_IMFUDZ (NDS3, IDA2, NDS4) RESULT(I_IMFUDP) + I_IMFUDP = 1-IDA2(:,:,:,::NDS4-NDS3) +END FUNCTION diff --git a/Fortran/gfortran/regression/entry_dummy_ref_1.f90 b/Fortran/gfortran/regression/entry_dummy_ref_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_dummy_ref_1.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! Tests fix for PR25090 in which references in specification +! expressions to variables that were not entry formal arguments +! would be missed. +! +! Contributed by Joost VandeVondele +! + SUBROUTINE S1(I) + CHARACTER(LEN=I+J) :: a + real :: x(i:j), z + a = "" ! { dg-error "before the ENTRY statement in which it is a parameter" } + x = 0.0 ! { dg-error "before the ENTRY statement in which it is a parameter" } + ENTRY E1(J) + END SUBROUTINE S1 + END diff --git a/Fortran/gfortran/regression/entry_dummy_ref_2.f90 b/Fortran/gfortran/regression/entry_dummy_ref_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_dummy_ref_2.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! Tests fix for PR25058 in which references to dummy +! parameters before the entry would be missed. +! +! Contributed by Joost VandeVondele +! +MODULE M1 +CONTAINS +FUNCTION F1(I) RESULT(RF1) + INTEGER :: I,K,RE1,RF1 + RE1=K ! { dg-error "before the ENTRY statement" } + RETURN + ENTRY E1(K) RESULT(RE1) + RE1=-I + RETURN +END FUNCTION F1 +END MODULE M1 +END diff --git a/Fortran/gfortran/regression/entry_dummy_ref_3.f90 b/Fortran/gfortran/regression/entry_dummy_ref_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/entry_dummy_ref_3.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! +! PR fortran/33818 +! + +subroutine ExportZMX(lu) + implicit none + integer :: lu + interface + function LowerCase(str) + character(*),intent(in) :: str + character(len(str)) :: LowerCase + end function LowerCase + end interface + character(*),parameter :: UNAME(1:1)=(/'XXX'/) + write(lu,'(a)') 'UNIT '//UpperCase(UNAME(1)) + write(lu,'(a)') 'Unit '//LowerCase(UNAME(1)) +entry ExportSEQ(lu) +contains + function UpperCase(str) result(res) + character(*),intent(in) :: str + character(len(str)) res + res=str + end function +end diff --git a/Fortran/gfortran/regression/enum_1.f90 b/Fortran/gfortran/regression/enum_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/enum_1.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! Program to test ENUM parsing + +program main + implicit none + enum, bind (c) + enumerator :: red, black + enumerator blue + end enum + if (red /= 0) STOP 1 +end program main diff --git a/Fortran/gfortran/regression/enum_10.c b/Fortran/gfortran/regression/enum_10.c --- /dev/null +++ b/Fortran/gfortran/regression/enum_10.c @@ -0,0 +1,27 @@ +/* This testcase is meant to be compiled together with enum_10.f90 */ + +extern void abort (void); + +typedef enum + { MAX1 = 127 } onebyte; + +void f1_ (onebyte *i, int *j) +{ + if (*i != *j) abort (); +} + +typedef enum + { MAX2 = 32767 } twobyte; + +void f2_ (twobyte *i, int *j) +{ + if (*i != *j) abort (); +} + +typedef enum + { MAX4 = 2000000 } fourbyte; /* don't need the precise value. */ + +void f4_ (fourbyte *i, int *j) +{ + if (*i != *j) abort (); +} diff --git a/Fortran/gfortran/regression/enum_10.f90 b/Fortran/gfortran/regression/enum_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/enum_10.f90 @@ -0,0 +1,62 @@ +! { dg-do run } +! { dg-options "-fshort-enums -w" } +! { dg-options "-fshort-enums -w -Wl,--no-enum-size-warning" { target arm_eabi } } +! { dg-additional-sources enum_10.c } +! Make sure short enums are indeed interoperable with the +! corresponding C type. + +module enum_10 +enum, bind( c ) + enumerator :: one1 = 1, two1, max1 = huge(1_1) +end enum + +enum, bind( c ) + enumerator :: one2 = 1, two2, max2 = huge(1_2) +end enum + +enum, bind( c ) + enumerator :: one4 = 1, two4, max4 = huge(1_4) +end enum +end module enum_10 + +use enum_10 + +interface f1 + subroutine f1(i,j) + use enum_10 + integer (kind(max1)) :: i + integer :: j + end subroutine f1 +end interface + + +interface f2 + subroutine f2(i,j) + use enum_10 + integer (kind(max2)) :: i + integer :: j + end subroutine f2 +end interface + + +interface f4 + subroutine f4(i,j) + use enum_10 + integer (kind(max4)) :: i + integer :: j + end subroutine f4 +end interface + + +call f1 (one1, 1) +call f1 (two1, 2) +call f1 (max1, huge(1_1)+0) ! Adding 0 to get default integer + +call f2 (one2, 1) +call f2 (two2, 2) +call f2 (max2, huge(1_2)+0) + +call f4 (one4, 1) +call f4 (two4, 2) +call f4 (max4, huge(1_4)+0) +end diff --git a/Fortran/gfortran/regression/enum_2.f90 b/Fortran/gfortran/regression/enum_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/enum_2.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! Program to test ENUM parsing errors + +program main + implicit none + enum, bind (c) + enumerator :: red, black + integer :: x ! { dg-error "Unexpected data declaration" } + enumerator blue = 1 ! { dg-error "Syntax error in ENUMERATOR definition" } + end enum + + red = 42 ! { dg-error "variable definition context" } + + enumerator :: sun ! { dg-error "ENUM" } +end program main diff --git a/Fortran/gfortran/regression/enum_3.f90 b/Fortran/gfortran/regression/enum_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/enum_3.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! Program to test ENUM parsing errors + +program main + implicit none + enum, bind (c) + enumerator :: red, black = 2.2 ! { dg-error "initialized with integer expression" } + enumerator :: blue = "x" ! { dg-error "initialized with integer expression" } + end enum ! { dg-error "has no ENUMERATORS" } + +end program main diff --git a/Fortran/gfortran/regression/enum_4.f90 b/Fortran/gfortran/regression/enum_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/enum_4.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! Program to test ENUM parsing errors + +program main + implicit none + enum, bind (c) + enumerator :: red, black = 2 + enumerator :: blue = 1, red ! { dg-error "already has basic type" } + end enum + + enum, bind (c) + enumerator :: r, b(10) = 2 ! { dg-error "Syntax error" } + enumerator , save :: g = 1 ! { dg-error "Syntax error" } + end ! { dg-error " END ENUM" } + +end program main ! { dg-error "Expecting END ENUM statement" } +! { dg-error "Unexpected end of file" "" { target "*-*-*" } 0 } diff --git a/Fortran/gfortran/regression/enum_5.f90 b/Fortran/gfortran/regression/enum_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/enum_5.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! Program to test ENUM parsing errors + +program main + implicit none + integer :: i = 1 + + enum, bind (c) + enumerator :: red, black = i ! { dg-error "is a variable" } + enumerator :: blue = 1 + end enum junk ! { dg-error "Syntax error" } + + blue = 10 ! { dg-error "Unexpected assignment" } + +end program main ! { dg-error "Expecting END ENUM" } + ! { dg-error "Unexpected end of file" "" { target "*-*-*" } 0 } diff --git a/Fortran/gfortran/regression/enum_6.f90 b/Fortran/gfortran/regression/enum_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/enum_6.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! Program to test ENUM parsing errors + +program main + implicit none + integer :: i = 1 + + enum, bind (c) + enumerator :: sun, mon = 2 + i = 2 ! { dg-error "Unexpected" } + enumerator :: wed = 1 + end enum + + i = 1 + + enum, bind (c) ! { dg-error "Unexpected" } + enumerator :: red, black = 2 ! { dg-error "ENUM definition statement expected" } + enumerator :: blue = 1 ! { dg-error "ENUM definition statement expected" } + end enum ! { dg-error "Expecting END PROGRAM" } + +end program main diff --git a/Fortran/gfortran/regression/enum_7.f90 b/Fortran/gfortran/regression/enum_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/enum_7.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! Program to test ENUM parsing errors + +program main + implicit none + + enum, bind (c) + enumerator :: sun, mon = 2 + enum, bind (c) ! { dg-error "Unexpected" } + enumerator :: apple, mango + end enum + enumerator :: wed = 1 ! { dg-error "ENUM definition statement expected" } + end enum ! { dg-error "Expecting END PROGRAM" } + +end program main diff --git a/Fortran/gfortran/regression/enum_8.f90 b/Fortran/gfortran/regression/enum_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/enum_8.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! Program to test the initialisation range of enumerators +! and kind values check + +program main + implicit none + enum, bind (c) + enumerator :: pp, qq = 4294967295, rr ! { dg-error "too big for its kind" } + end enum ! { dg-error "has no ENUMERATORS" } + + enum, bind (c) + enumerator :: p , q = 4294967299_8, r ! { dg-error "Arithmetic overflow" } + end enum ! { dg-error "has no ENUMERATORS" } + +end program main diff --git a/Fortran/gfortran/regression/enum_9.f90 b/Fortran/gfortran/regression/enum_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/enum_9.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-fshort-enums" } +! { dg-options "-fshort-enums -Wl,--no-enum-size-warning" { target arm_eabi } } +! Program to test enumerations when option -fshort-enums is given + +program main + implicit none + enum, bind (c) + enumerator :: red, black = 127 + enumerator blue + end enum + if (red /= 0) STOP 1 + if (black /= 127) STOP 2 + if (blue /= 128) STOP 3 +end program main diff --git a/Fortran/gfortran/regression/eof_1.f90 b/Fortran/gfortran/regression/eof_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/eof_1.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! Program to test for proper EOF errors when reading past the end of a file. +! We used to get this wrong when a formatted read followed a list formatted +! read. +program eof_1 + character(len=5) :: s + + open (unit=11, status="SCRATCH") + write (11, '(a)') "Hello" + rewind(11) + read(11, *) s + if (s .ne. "Hello") STOP 1 + read(11, '(a5)', end=10) s + STOP 2 +10 continue + close (11) +end + diff --git a/Fortran/gfortran/regression/eof_2.f90 b/Fortran/gfortran/regression/eof_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/eof_2.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! Check that end= and iostat= specifiers are honoured when both are used +program eof_2 + integer ierr, i + + open (11, status="SCRATCH") + ierr = 0 + read (11, *, end=10, iostat=ierr) i + STOP 1 +10 continue + if (ierr .ge. 0) STOP 2 +end program + diff --git a/Fortran/gfortran/regression/eof_3.f90 b/Fortran/gfortran/regression/eof_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/eof_3.f90 @@ -0,0 +1,9 @@ +! { dg-do run } +! PR40714 A read hitting EOF should leave the unit structure in a correct state +program test +open(unit=32,status="scratch",access="sequential",form="unformatted") +read(32,end=100) +100 continue +backspace(32) +write (32) +end program test diff --git a/Fortran/gfortran/regression/eof_4.f90 b/Fortran/gfortran/regression/eof_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/eof_4.f90 @@ -0,0 +1,130 @@ +! { dg-do run } +! PR55818 Reading a REAL from a file which doesn't end in a new line fails +! Test case from PR reporter. +implicit none +integer :: stat +!integer :: var ! << works +real :: var ! << fails +character(len=10) :: cvar ! << fails +complex :: cval +logical :: lvar + +open(99, file="test.dat", access="stream", form="unformatted", status="new") +write(99) "1", new_line("") +write(99) "2", new_line("") +write(99) "3" +close(99) + +! Test character kind +open(99, file="test.dat") +read (99,*, iostat=stat) cvar +if (stat /= 0 .or. cvar /= "1") STOP 1 +read (99,*, iostat=stat) cvar +if (stat /= 0 .or. cvar /= "2") STOP 2 +read (99,*, iostat=stat) cvar ! << FAILS: stat /= 0 +if (stat /= 0 .or. cvar /= "3") STOP 3 ! << aborts here + +! Test real kind +rewind(99) +read (99,*, iostat=stat) var +if (stat /= 0 .or. var /= 1.0) STOP 4 +read (99,*, iostat=stat) var +if (stat /= 0 .or. var /= 2.0) STOP 5 +read (99,*, iostat=stat) var ! << FAILS: stat /= 0 +if (stat /= 0 .or. var /= 3.0) STOP 6 +close(99, status="delete") + +! Test real kind with exponents +open(99, file="test.dat", access="stream", form="unformatted", status="new") +write(99) "1.0e3", new_line("") +write(99) "2.0e-03", new_line("") +write(99) "3.0e2" +close(99) + +open(99, file="test.dat") +read (99,*, iostat=stat) var +if (stat /= 0) STOP 7 +read (99,*, iostat=stat) var +if (stat /= 0) STOP 8 +read (99,*) var ! << FAILS: stat /= 0 +if (stat /= 0) STOP 9 +close(99, status="delete") + +! Test logical kind +open(99, file="test.dat", access="stream", form="unformatted", status="new") +write(99) "Tru", new_line("") +write(99) "fal", new_line("") +write(99) "t" +close(99) + +open(99, file="test.dat") +read (99,*, iostat=stat) lvar +if (stat /= 0 .or. (.not.lvar)) STOP 10 +read (99,*, iostat=stat) lvar +if (stat /= 0 .or. lvar) STOP 11 +read (99,*) lvar ! << FAILS: stat /= 0 +if (stat /= 0 .or. (.not.lvar)) STOP 12 +close(99, status="delete") + +! Test combinations of Inf and Nan +open(99, file="test.dat", access="stream", form="unformatted", status="new") +write(99) "infinity", new_line("") +write(99) "nan", new_line("") +write(99) "infinity" +close(99) + +open(99, file="test.dat") +read (99,*, iostat=stat) var +if (stat /= 0) STOP 13 +read (99,*, iostat=stat) var +if (stat /= 0) STOP 14 +read (99,*) var ! << FAILS: stat /= 0 +if (stat /= 0) STOP 1! << aborts here +close(99, status="delete") + +open(99, file="test.dat", access="stream", form="unformatted", status="new") +write(99) "infinity", new_line("") +write(99) "inf", new_line("") +write(99) "nan" +close(99) + +open(99, file="test.dat") +read (99,*, iostat=stat) var +if (stat /= 0) STOP 15 +read (99,*, iostat=stat) var +if (stat /= 0) STOP 16 +read (99,*) var ! << FAILS: stat /= 0 +if (stat /= 0) STOP 2! << aborts here +close(99, status="delete") + +open(99, file="test.dat", access="stream", form="unformatted", status="new") +write(99) "infinity", new_line("") +write(99) "nan", new_line("") +write(99) "inf" +close(99) + +open(99, file="test.dat") +read (99,*, iostat=stat) var +if (stat /= 0) STOP 17 +read (99,*, iostat=stat) var +if (stat /= 0) STOP 18 +read (99,*) var ! << FAILS: stat /= 0 +if (stat /= 0) STOP 3! << aborts here +close(99, status="delete") + +! Test complex kind +open(99, file="test.dat", access="stream", form="unformatted", status="new") +write(99) "(1,2)", new_line("") +write(99) "(2,3)", new_line("") +write(99) "(4,5)" +close(99) + +open(99, file="test.dat") +read (99,*, iostat=stat) cval +if (stat /= 0 .or. cval /= cmplx(1,2)) STOP 19 +read (99,*, iostat=stat) cval +if (stat /= 0 .or. cval /= cmplx(2,3)) STOP 20 +read (99,*, iostat=stat) cval ! << FAILS: stat /= 0, value is okay +if (stat /= 0 .or. cval /= cmplx(4,5)) STOP 21 +close(99, status="delete") +end diff --git a/Fortran/gfortran/regression/eof_5.f90 b/Fortran/gfortran/regression/eof_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/eof_5.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! +! PR fortran/56696 +! +! Contributed by Keith Refson +! + +program iotest + character(len=258) :: inp = ' 1.0 1.0 1.0' + character(len=7) :: inp2 = '1 2 3 4' + integer :: ios + real :: a1, a2, a3, a4 + + read(inp2,*,iostat=ios) a1, a2, a3, a4 + if (ios /= 0) STOP 1 + + read(inp,*,iostat=ios) a1, a2, a3, a4 + if (ios == 0) STOP 2 +! write(*,*) 'IOSTAT=',ios +end program iotest + diff --git a/Fortran/gfortran/regression/eof_6.f90 b/Fortran/gfortran/regression/eof_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/eof_6.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize" } +! PR 92569 - the EOF condition was not recognized with +! -ffrontend-optimize. Originjal test case by Bill Lipa. +program main + implicit none + real(kind=8) :: tdat(1000,10) + real(kind=8) :: res (10, 3) + integer :: i, j, k, np + + open (unit=20, status="scratch") + res = reshape([(real(i),i=1,30)], shape(res)) + write (20,'(10G12.5)') res + rewind 20 + do j = 1,1000 + read (20,*,end=1)(tdat(j,k),k=1,10) + end do + +1 continue + np = j-1 + if (np /= 3) stop 1 + if (any(transpose(res) /= tdat(1:np,:))) stop 2 +end program main diff --git a/Fortran/gfortran/regression/eor_1.f90 b/Fortran/gfortran/regression/eor_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/eor_1.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR 19451: The test for advance='NO' with eor used to be reversed. +program main + character*2 c + open(12, status='SCRATCH') + write(12, '(A)') '123', '456' + rewind(12) + read(12, '(A2)', advance='NO', eor=100) c +100 continue +end program main diff --git a/Fortran/gfortran/regression/eor_handling_1.f90 b/Fortran/gfortran/regression/eor_handling_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/eor_handling_1.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! PR 17992: Reading an empty file should yield zero with pad='YES' +! (which is the default). +! Test case supplied by milan@cmm.ki.si. +program main + open(77,status='scratch') + write(77,'(A)') '','' + rewind(77) + i = 42 + j = 42 + read(77,'(/2i2)') i,j + if (i /= 0 .or. j /= 0) STOP 1 + close(77) +end program main diff --git a/Fortran/gfortran/regression/eor_handling_2.f90 b/Fortran/gfortran/regression/eor_handling_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/eor_handling_2.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! PR 19568: Don't read across end of line when the format is longer +! than the line length and pad='yes' (default) +program main + character(len=1) c1(10),c2(10) + open(77,status='scratch') + write(77,'(A)'), 'Line 1','Line 2','Line 3' ! { dg-warning "Comma before i/o item list" } + rewind(77) + read(77,'(10A1)'), c1 ! { dg-warning "Comma before i/o item list" } + read(77,'(10A1)'), c2 ! { dg-warning "Comma before i/o item list" } + if (c1(1) /= 'L' .or. c2(1) /= 'L') STOP 1 + close(77) +end program main diff --git a/Fortran/gfortran/regression/eor_handling_3.f90 b/Fortran/gfortran/regression/eor_handling_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/eor_handling_3.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! PR 19595: Handle end-of-record condition with pad=yes (default) +program main + integer i1, i2 + open(77,status='scratch') + write (77,'(A)') '123','456' + rewind(77) + read(77,'(2I2)',advance='no',eor=100) i1,i2 + STOP 1 +100 continue + if (i1 /= 12 .or. i2 /= 3) STOP 2 + close(77) +end program main diff --git a/Fortran/gfortran/regression/eor_handling_4.f90 b/Fortran/gfortran/regression/eor_handling_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/eor_handling_4.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! PR 20092, 20131: Handle end-of-record condition with pad=yes (default) +! for standard input. This test case only really tests anything if, +! by changing unit 5, you get to manipulate the standard input. +program main + character(len=1) a(80) + close(5) + open(5,status="scratch") + write(5,'(A)') 'one', 'two', 's' + rewind(5) + do i=1,4 + read(5,'(80a1)') a + if (a(1) == 's') goto 100 + end do + STOP 1 +100 continue +end program main diff --git a/Fortran/gfortran/regression/eor_handling_5.f90 b/Fortran/gfortran/regression/eor_handling_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/eor_handling_5.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! PR 20661: Handle non-advancing I/O with iostat +! Test case by Walt Brainerd, The Fortran Company + +program fc002 + character(len=1) :: c + integer :: k,k2 + character(len=*), parameter :: f="(a)" + open(11,status="scratch", iostat=k) + if (k /= 0) STOP 1 + write(11,f) "x" + rewind (11) + read(11, f, advance="no", iostat=k) c + if (k /= 0) STOP 2 + read(11, f, advance="no", iostat=k) c + if (k >= 0) STOP 3 + read(11, f, advance="no", iostat=k2) c + if (k2 >= 0 .or. k == k2) STOP 4 +end program fc002 diff --git a/Fortran/gfortran/regression/eoshift.f90 b/Fortran/gfortran/regression/eoshift.f90 --- /dev/null +++ b/Fortran/gfortran/regression/eoshift.f90 @@ -0,0 +1,6 @@ +! { dg-do run } +! PR 18958: We used to segfault for eoshifting off the end of an array. +program main + character(len=20) line + write (line,'(2I4)') eoshift((/1, 3/), 3) +end program main diff --git a/Fortran/gfortran/regression/eoshift_2.f90 b/Fortran/gfortran/regression/eoshift_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/eoshift_2.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! pr35724 compile time segmentation fault for eoshift with negative third arg +subroutine ra0072(dda,lda,nf10,nf1,mf1,nf2) + real dda(10,10) + logical lda(10,10) + dda = eoshift(dda,(/mf1,nf1/),tws0r,nf3-nf1) + lda = cshift(lda,(/mf1,nf1/),nf3-nf1) + where (lda) dda = eoshift(dda,1,1.0,-mf1) +end subroutine diff --git a/Fortran/gfortran/regression/eoshift_3.f90 b/Fortran/gfortran/regression/eoshift_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/eoshift_3.f90 @@ -0,0 +1,178 @@ +! { dg-do run } +! Check that eoshift works for three-dimensional arrays. +module x + implicit none +contains + subroutine eoshift_0 (array, shift, boundary, dim, res) + real, dimension(:,:,:), intent(in) :: array + real, dimension(:,:,:), intent(out) :: res + integer, value :: shift + real, optional, intent(in) :: boundary + integer, optional, intent(in) :: dim + integer :: s1, s2, s3 + integer :: n1, n2, n3 + + real :: b + integer :: d + if (present(boundary)) then + b = boundary + else + b = 0.0 + end if + + if (present(dim)) then + d = dim + else + d = 1 + end if + + n1 = size(array,1) + n2 = size(array,2) + n3 = size(array,3) + + select case(dim) + case(1) + if (shift > 0) then + shift = min(shift, n1) + do s3=1,n3 + do s2=1,n2 + do s1= 1, n1 - shift + res(s1,s2,s3) = array(s1+shift,s2,s3) + end do + do s1 = n1 - shift + 1,n1 + res(s1,s2,s3) = b + end do + end do + end do + + else + shift = max(shift, -n1) + do s3=1,n3 + do s2=1,n2 + do s1=1,-shift + res(s1,s2,s3) = b + end do + do s1= 1-shift,n1 + res(s1,s2,s3) = array(s1+shift,s2,s3) + end do + end do + end do + end if + + case(2) + if (shift > 0) then + shift = min(shift, n2) + do s3=1,n3 + do s2=1, n2 - shift + do s1=1,n1 + res(s1,s2,s3) = array(s1,s2+shift,s3) + end do + end do + do s2=n2 - shift + 1, n2 + do s1=1,n1 + res(s1,s2,s3) = b + end do + end do + end do + else + shift = max(shift, -n2) + do s3=1,n3 + do s2=1,-shift + do s1=1,n1 + res(s1,s2,s3) = b + end do + end do + do s2=1-shift,n2 + do s1=1,n1 + res(s1,s2,s3) = array(s1,s2+shift,s3) + end do + end do + end do + end if + + case(3) + if (shift > 0) then + shift = min(shift, n3) + do s3=1,n3 - shift + do s2=1, n2 + do s1=1,n1 + res(s1,s2,s3) = array(s1,s2,s3+shift) + end do + end do + end do + do s3=n3 - shift + 1, n3 + do s2=1, n2 + do s1=1,n1 + res(s1,s2,s3) = b + end do + end do + end do + else + shift = max(shift, -n3) + do s3=1,-shift + do s2=1,n2 + do s1=1,n1 + res(s1,s2,s3) = b + end do + end do + end do + do s3=1-shift,n3 + do s2=1,n2 + do s1=1,n1 + res(s1,s2,s3) = array(s1,s2,s3+shift) + end do + end do + end do + end if + + case default + stop "Illegal dim" + end select + end subroutine eoshift_0 +end module x + +program main + use x + implicit none + integer, parameter :: n1=2,n2=4,n3=2 + real, dimension(n1,n2,n3) :: a,b,c + integer :: dim, shift, shift_lim + call random_number(a) + + do dim=1,3 + if (dim == 1) then + shift_lim = n1 + 1 + else if (dim == 2) then + shift_lim = n2 + 1 + else + shift_lim = n3 + 1 + end if + do shift=-shift_lim, shift_lim + b = eoshift(a,shift,dim=dim) + call eoshift_0 (a, shift=shift, dim=dim, res=c) + if (any (b /= c)) then + print *,"dim = ", dim, "shift = ", shift + STOP 1 + end if + end do + end do + call random_number(b) + c = b + + do dim=1,3 + if (dim == 1) then + shift_lim = n1/2 + 1 + else if (dim == 2) then + shift_lim = n2/2 + 1 + else + shift_lim = n3/2 + 1 + end if + + do shift=-shift_lim, shift_lim + b(1:n1:2,:,:) = eoshift(a(1:n1/2,:,:),shift,dim=dim) + call eoshift_0 (a(1:n1/2,:,:), shift=shift, dim=dim, res=c(1:n1:2,:,:)) + if (any (b /= c)) STOP 2 + end do + end do + +end program main diff --git a/Fortran/gfortran/regression/eoshift_4.f90 b/Fortran/gfortran/regression/eoshift_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/eoshift_4.f90 @@ -0,0 +1,187 @@ +! { dg-do run } +! Check that eoshift works for three-dimensional arrays. +module x + implicit none +contains + subroutine eoshift_2 (array, shift, boundary, dim, res) + real, dimension(:,:,:), intent(in) :: array + real, dimension(:,:,:), intent(out) :: res + integer, value :: shift + real, optional, dimension(:,:), intent(in) :: boundary + integer, optional, intent(in) :: dim + integer :: s1, s2, s3 + integer :: n1, n2, n3 + + real :: b + integer :: d + + if (present(dim)) then + d = dim + else + d = 1 + end if + + n1 = size(array,1) + n2 = size(array,2) + n3 = size(array,3) + + select case(dim) + case(1) + if (shift > 0) then + shift = min(shift, n1) + do s3=1,n3 + do s2=1,n2 + b = boundary(s2,s3) + do s1= 1, n1 - shift + res(s1,s2,s3) = array(s1+shift,s2,s3) + end do + do s1 = n1 - shift + 1,n1 + res(s1,s2,s3) = b + end do + end do + end do + + else + shift = max(shift, -n1) + do s3=1,n3 + do s2=1,n2 + b = boundary(s2,s3) + do s1=1,-shift + res(s1,s2,s3) = b + end do + do s1= 1-shift,n1 + res(s1,s2,s3) = array(s1+shift,s2,s3) + end do + end do + end do + end if + + case(2) + if (shift > 0) then + shift = min(shift, n2) + do s3=1,n3 + do s2=1, n2 - shift + do s1=1,n1 + res(s1,s2,s3) = array(s1,s2+shift,s3) + end do + end do + do s2=n2 - shift + 1, n2 + do s1=1,n1 + b = boundary(s1,s3) + res(s1,s2,s3) = b + end do + end do + end do + else + shift = max(shift, -n2) + do s3=1,n3 + do s2=1,-shift + do s1=1,n1 + b = boundary(s1,s3) + res(s1,s2,s3) = b + end do + end do + do s2=1-shift,n2 + do s1=1,n1 + res(s1,s2,s3) = array(s1,s2+shift,s3) + end do + end do + end do + end if + + case(3) + if (shift > 0) then + shift = min(shift, n3) + do s3=1,n3 - shift + do s2=1, n2 + do s1=1,n1 + res(s1,s2,s3) = array(s1,s2,s3+shift) + end do + end do + end do + do s3=n3 - shift + 1, n3 + do s2=1, n2 + do s1=1,n1 + b = boundary(s1,s2) + res(s1,s2,s3) = b + end do + end do + end do + else + shift = max(shift, -n3) + do s3=1,-shift + do s2=1,n2 + do s1=1,n1 + b = boundary(s1,s2) + res(s1,s2,s3) = b + end do + end do + end do + do s3=1-shift,n3 + do s2=1,n2 + do s1=1,n1 + res(s1,s2,s3) = array(s1,s2,s3+shift) + end do + end do + end do + end if + + case default + stop "Illegal dim" + end select + end subroutine eoshift_2 +end module x + +program main + use x + implicit none + integer, parameter :: n1=20,n2=30,n3=40 + real, dimension(n1,n2,n3) :: a,b,c + real, dimension(2*n1,n2,n3) :: a2,c2 + integer :: dim, shift, shift_lim + real, dimension(n2,n3), target :: b1 + real, dimension(n1,n3), target :: b2 + real, dimension(n1,n2), target :: b3 + real, dimension(:,:), pointer :: bp + + call random_number(a) + call random_number (b1) + call random_number (b2) + call random_number (b3) + do dim=1,3 + if (dim == 1) then + shift_lim = n1 + 1 + bp => b1 + else if (dim == 2) then + shift_lim = n2 + 1 + bp => b2 + else + shift_lim = n3 + 1 + bp => b3 + end if + do shift=-shift_lim, shift_lim + b = eoshift(a,shift,dim=dim, boundary=bp) + call eoshift_2 (a, shift=shift, dim=dim, boundary=bp, res=c) + if (any (b /= c)) then + print *,"dim = ", dim, "shift = ", shift + print *,b + print *,c + STOP 1 + end if + a2 = 42. + a2(1:2*n1:2,:,:) = a + b = eoshift(a2(1:2*n1:2,:,:), shift, dim=dim, boundary=bp) + if (any (b /= c)) then + STOP 2 + end if + c2 = 43. + c2(1:2*n1:2,:,:) = eoshift(a,shift,dim=dim, boundary=bp) + if (any(c2(1:2*n1:2,:,:) /= c)) then + STOP 3 + end if + if (any(c2(2:2*n1:2,:,:) /= 43)) then + STOP 4 + end if + end do + end do +end program main diff --git a/Fortran/gfortran/regression/eoshift_5.f90 b/Fortran/gfortran/regression/eoshift_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/eoshift_5.f90 @@ -0,0 +1,182 @@ +! { dg-do run } +! Check that eoshift works for three-dimensional arrays. +module x + implicit none +contains + subroutine eoshift_1 (array, shift, boundary, dim, res) + real, dimension(:,:,:), intent(in) :: array + real, dimension(:,:,:), intent(out) :: res + integer, dimension(:,:), intent(in) :: shift + real, optional, intent(in) :: boundary + integer, optional, intent(in) :: dim + integer :: s1, s2, s3 + integer :: n1, n2, n3 + integer :: sh + real :: b + integer :: d + + if (present(boundary)) then + b = boundary + else + b = 0.0 + end if + + if (present(dim)) then + d = dim + else + d = 1 + end if + + n1 = size(array,1) + n2 = size(array,2) + n3 = size(array,3) + + select case(dim) + case(1) + do s3=1,n3 + do s2=1,n2 + sh = shift(s2,s3) + if (sh > 0) then + sh = min(sh, n1) + do s1= 1, n1 - sh + res(s1,s2,s3) = array(s1+sh,s2,s3) + end do + do s1 = n1 - sh + 1,n1 + res(s1,s2,s3) = b + end do + else + sh = max(sh, -n1) + do s1=1,-sh + res(s1,s2,s3) = b + end do + do s1= 1-sh,n1 + res(s1,s2,s3) = array(s1+sh,s2,s3) + end do + end if + end do + end do + case(2) + do s3=1,n3 + do s1=1,n1 + sh = shift(s1,s3) + if (sh > 0) then + sh = min (sh, n2) + do s2=1, n2 - sh + res(s1,s2,s3) = array(s1,s2+sh,s3) + end do + do s2=n2 - sh + 1, n2 + res(s1,s2,s3) = b + end do + else + sh = max(sh, -n2) + do s2=1,-sh + res(s1,s2,s3) = b + end do + do s2=1-sh,n2 + res(s1,s2,s3) = array(s1,s2+sh,s3) + end do + end if + end do + end do + + case(3) + do s2=1, n2 + do s1=1,n1 + sh = shift(s1, s2) + if (sh > 0) then + sh = min(sh, n3) + do s3=1,n3 - sh + res(s1,s2,s3) = array(s1,s2,s3+sh) + end do + do s3=n3 - sh + 1, n3 + res(s1,s2,s3) = b + end do + else + sh = max(sh, -n3) + do s3=1,-sh + res(s1,s2,s3) = b + end do + do s3=1-sh,n3 + res(s1,s2,s3) = array(s1,s2,s3+sh) + end do + end if + end do + end do + + case default + stop "Illegal dim" + end select + end subroutine eoshift_1 + subroutine fill_shift(x, n) + integer, intent(out), dimension(:,:) :: x + integer, intent(in) :: n + integer :: n1, n2, s1, s2 + integer :: v + v = -n - 1 + n1 = size(x,1) + n2 = size(x,2) + do s2=1,n2 + do s1=1,n1 + x(s1,s2) = v + v = v + 1 + if (v > n + 1) v = -n - 1 + end do + end do + end subroutine fill_shift +end module x + +program main + use x + implicit none + integer, parameter :: n1=20,n2=30,n3=40 + real, dimension(n1,n2,n3) :: a,b,c + real, dimension(2*n1,n2,n3) :: a2, c2 + integer :: dim + integer, dimension(n2,n3), target :: sh1 + integer, dimension(n1,n3), target :: sh2 + integer, dimension(n1,n2), target :: sh3 + real, dimension(n2,n3), target :: b1 + real, dimension(n1,n3), target :: b2 + real, dimension(n1,n2), target :: b3 + + integer, dimension(:,:), pointer :: sp + real, dimension(:,:), pointer :: bp + + call random_number(a) + call fill_shift(sh1, n1) + call fill_shift(sh2, n2) + call fill_shift(sh3, n3) + + do dim=1,3 + if (dim == 1) then + sp => sh1 + else if (dim == 2) then + sp => sh2 + else + sp => sh3 + end if + b = eoshift(a,shift=sp,dim=dim,boundary=-0.5) + call eoshift_1 (a, shift=sp, dim=dim, boundary=-0.5,res=c) + if (any (b /= c)) then + print *,"dim = ", dim + print *,"sp = ", sp + print '(99F8.4)',b + print '(99F8.4)',c + STOP 1 + end if + a2 = 42. + a2(1:2*n1:2,:,:) = a + b = eoshift(a2(1:2*n1:2,:,:), shift=sp, dim=dim, boundary=-0.5) + if (any(b /= c)) then + STOP 2 + end if + c2 = 43. + c2(1:2*n1:2,:,:) = eoshift(a, shift=sp, dim=dim, boundary=-0.5) + if (any(c2(1:2*n1:2,:,:) /= c)) then + STOP 3 + end if + if (any(c2(2:2*n1:2,:,:) /= 43.)) then + STOP 4 + end if + end do +end program main diff --git a/Fortran/gfortran/regression/eoshift_6.f90 b/Fortran/gfortran/regression/eoshift_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/eoshift_6.f90 @@ -0,0 +1,181 @@ +! { dg-do run } +! Check that eoshift works for three-dimensional arrays. +module x + implicit none +contains + subroutine eoshift_3 (array, shift, boundary, dim, res) + real, dimension(:,:,:), intent(in) :: array + real, dimension(:,:,:), intent(out) :: res + integer, dimension(:,:), intent(in) :: shift + real, optional, dimension(:,:), intent(in) :: boundary + integer, optional, intent(in) :: dim + integer :: s1, s2, s3 + integer :: n1, n2, n3 + integer :: sh + real :: b + integer :: d + + if (present(dim)) then + d = dim + else + d = 1 + end if + + n1 = size(array,1) + n2 = size(array,2) + n3 = size(array,3) + + select case(dim) + case(1) + do s3=1,n3 + do s2=1,n2 + sh = shift(s2,s3) + b = boundary(s2,s3) + if (sh > 0) then + sh = min(sh, n1) + do s1= 1, n1 - sh + res(s1,s2,s3) = array(s1+sh,s2,s3) + end do + do s1 = n1 - sh + 1,n1 + res(s1,s2,s3) = b + end do + else + sh = max(sh, -n1) + do s1=1,-sh + res(s1,s2,s3) = b + end do + do s1= 1-sh,n1 + res(s1,s2,s3) = array(s1+sh,s2,s3) + end do + end if + end do + end do + case(2) + do s3=1,n3 + do s1=1,n1 + sh = shift(s1,s3) + b = boundary(s1,s3) + if (sh > 0) then + sh = min (sh, n2) + do s2=1, n2 - sh + res(s1,s2,s3) = array(s1,s2+sh,s3) + end do + do s2=n2 - sh + 1, n2 + res(s1,s2,s3) = b + end do + else + sh = max(sh, -n2) + do s2=1,-sh + res(s1,s2,s3) = b + end do + do s2=1-sh,n2 + res(s1,s2,s3) = array(s1,s2+sh,s3) + end do + end if + end do + end do + + case(3) + do s2=1, n2 + do s1=1,n1 + sh = shift(s1, s2) + b = boundary(s1, s2) + if (sh > 0) then + sh = min(sh, n3) + do s3=1,n3 - sh + res(s1,s2,s3) = array(s1,s2,s3+sh) + end do + do s3=n3 - sh + 1, n3 + res(s1,s2,s3) = b + end do + else + sh = max(sh, -n3) + do s3=1,-sh + res(s1,s2,s3) = b + end do + do s3=1-sh,n3 + res(s1,s2,s3) = array(s1,s2,s3+sh) + end do + end if + end do + end do + + case default + stop "Illegal dim" + end select + end subroutine eoshift_3 + subroutine fill_shift(x, n) + integer, intent(out), dimension(:,:) :: x + integer, intent(in) :: n + integer :: n1, n2, s1, s2 + integer :: v + v = -n - 1 + n1 = size(x,1) + n2 = size(x,2) + do s2=1,n2 + do s1=1,n1 + x(s1,s2) = v + v = v + 1 + if (v > n + 1) v = -n - 1 + end do + end do + end subroutine fill_shift +end module x + +program main + use x + implicit none + integer, parameter :: n1=10,n2=30,n3=40 + real, dimension(n1,n2,n3) :: a,b,c + real, dimension(2*n1,n2,n3) :: a2, c2 + integer :: dim + integer, dimension(n2,n3), target :: sh1 + integer, dimension(n1,n3), target :: sh2 + integer, dimension(n1,n2), target :: sh3 + real, dimension(n2,n3), target :: b1 + real, dimension(n1,n3), target :: b2 + real, dimension(n1,n2), target :: b3 + + integer, dimension(:,:), pointer :: sp + real, dimension(:,:), pointer :: bp + + call random_number(a) + call random_number(b1) + call random_number(b2) + call random_number(b3) + call fill_shift(sh1, n1) + call fill_shift(sh2, n2) + call fill_shift(sh3, n3) + + do dim=1,3 + if (dim == 1) then + sp => sh1 + bp => b1 + else if (dim == 2) then + sp => sh2 + bp => b2 + else + sp => sh3 + bp => b3 + end if + b = eoshift(a,shift=sp,dim=dim,boundary=bp) + call eoshift_3 (a, shift=sp, dim=dim, boundary=bp,res=c) + if (any (b /= c)) then + STOP 1 + end if + a2 = 42. + a2(1:2*n1:2,:,:) = a + b = eoshift(a2(1:2*n1:2,:,:), shift=sp, dim=dim, boundary=bp) + if (any(b /= c)) then + STOP 2 + end if + c2 = 43. + c2(1:2*n1:2,:,:) = eoshift(a, shift=sp, dim=dim, boundary=bp) + if (any(c2(1:2*n1:2,:,:) /= c)) then + STOP 3 + end if + if (any(c2(2:2*n1:2,:,:) /= 43.)) then + STOP 4 + end if + end do +end program main diff --git a/Fortran/gfortran/regression/eoshift_7.f90 b/Fortran/gfortran/regression/eoshift_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/eoshift_7.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +program main + type t + integer :: x + end type t + type(t), dimension(2) :: a, b + a(1)%x = 1 + a(2)%x = 2 + b = eoshift(a,1) ! { dg-error "Missing 'boundary' argument to 'eoshift' intrinsic" } + print *,b%x +end program main diff --git a/Fortran/gfortran/regression/eoshift_8.f90 b/Fortran/gfortran/regression/eoshift_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/eoshift_8.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! PR 83664 - invalid code that used to be accepted. +program main + implicit none + integer :: n + integer :: i,n1, n2, n3 + character(len=3), parameter :: e(2,3,4) = reshape([(repeat(achar(i),3),i=iachar('a'),iachar('a')+2*3*4-1)], & + shape(e)) + character(len=3), parameter :: bnd2(3,5) = reshape([(repeat(achar(i),3),i=iachar('A'),iachar('A')+3*5-1)], & + shape(bnd2)) + character(len=3) :: f2(2,3,4) + + n = -1 + f2 = eoshift(e,shift=n,boundary=bnd2) ! { dg-error "has invalid shape" } + f2 = eoshift(e,shift=1,boundary="x") ! { dg-error "must be of same type and kind" } + + print '(*(1H",A,1H",:","))',f2 +end program main diff --git a/Fortran/gfortran/regression/eoshift_9.f90 b/Fortran/gfortran/regression/eoshift_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/eoshift_9.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR fortran/104331 - ICE in gfc_simplify_eoshift +! Contributed by G.Steinmetz + +program p + character(3), parameter :: a(:) = ['123'] ! { dg-error "deferred shape" } + character(3), parameter :: b(*) = eoshift(a, 1) +end diff --git a/Fortran/gfortran/regression/eoshift_bounds_1.f90 b/Fortran/gfortran/regression/eoshift_bounds_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/eoshift_bounds_1.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! { dg-options "-fbounds-check" } +! { dg-shouldfail "Incorrect size in SHIFT argument of EOSHIFT intrinsic: should not be zero-sized" } +program main + real, dimension(1,0) :: a, b, c + integer :: sp(3), i + a = 4.0 + sp = 1 + i = 1 + b = eoshift (a,sp(1:i)) ! Invalid +end program main +! { dg-output "Fortran runtime error: Incorrect size in SHIFT argument of EOSHIFT intrinsic: should not be zero-sized" } diff --git a/Fortran/gfortran/regression/eoshift_large_1.f90 b/Fortran/gfortran/regression/eoshift_large_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/eoshift_large_1.f90 @@ -0,0 +1,106 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_int } +! Program to test the eoshift intrinsic for kind=16_k integers +! +program intrinsic_eoshift + integer, parameter :: k=16 + integer(kind=k), dimension(3_k, 3_k) :: a + integer(kind=k), dimension(3_k, 3_k, 2_k) :: b + integer(kind=k), dimension(3_k) :: bo, sh + + ! Scalar shift and scalar bound. + a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/)) + a = eoshift (a, 1_k, 99_k, 1_k) + if (any (a .ne. reshape ((/2_k, 3_k, 99_k, 5_k, 6_k, 99_k, 8_k, 9_k, 99_k/), (/3_k, 3_k/)))) & + STOP 1 + + a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/)) + a = eoshift (a, 9999_k, 99_k, 1_k) + if (any (a .ne. 99_k)) STOP 2 + + a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/)) + a = eoshift (a, -2_k, dim = 2_k) + if (any (a .ne. reshape ((/0_k, 0_k, 0_k, 0_k, 0_k, 0_k, 1_k, 2_k, 3_k/), (/3_k, 3_k/)))) & + STOP 3 + + a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/)) + a = eoshift (a, -9999_k, 99_k, 1_k) + if (any (a .ne. 99_k)) STOP 4 + + ! Array shift and scalar bound. + a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/)) + a = eoshift (a, (/1_k, 0_k, -1_k/), 99_k, 1_k) + if (any (a .ne. reshape ((/2_k, 3_k, 99_k, 4_k, 5_k, 6_k, 99_k, 7_k, 8_k/), (/3_k, 3_k/)))) & + STOP 5 + + a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/)) + a = eoshift (a, (/9999_k, 0_k, -9999_k/), 99_k, 1_k) + if (any (a .ne. reshape ((/99_k, 99_k, 99_k, 4_k, 5_k, 6_k, 99_k, 99_k, 99_k/), (/3_k, 3_k/)))) & + STOP 6 + + a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/)) + a = eoshift (a, (/2_k, -2_k, 0_k/), dim = 2_k) + if (any (a .ne. reshape ((/7_k, 0_k, 3_k, 0_k, 0_k, 6_k, 0_k, 2_k, 9_k/), (/3_k, 3_k/)))) & + STOP 7 + + ! Scalar shift and array bound. + a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/)) + a = eoshift (a, 1_k, (/99_k, -1_k, 42_k/), 1_k) + if (any (a .ne. reshape ((/2_k, 3_k, 99_k, 5_k, 6_k, -1_k, 8_k, 9_k, 42_k/), (/3_k, 3_k/)))) & + STOP 8 + + a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/)) + a = eoshift (a, 9999_k, (/99_k, -1_k, 42_k/), 1_k) + if (any (a .ne. reshape ((/99_k, 99_k, 99_k, -1_k, -1_k, -1_k, 42_k, 42_k, 42_k/), & + (/3_k, 3_k/)))) STOP 9 + + a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/)) + a = eoshift (a, -9999_k, (/99_k, -1_k, 42_k/), 1_k) + if (any (a .ne. reshape ((/99_k, 99_k, 99_k, -1_k, -1_k, -1_k, 42_k, 42_k, 42_k/), & + (/3_k, 3_k/)))) STOP 10 + + a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/)) + a = eoshift (a, -2_k, (/99_k, -1_k, 42_k/), 2_k) + if (any (a .ne. reshape ((/99_k, -1_k, 42_k, 99_k, -1_k, 42_k, 1_k, 2_k, 3_k/), (/3_k, 3_k/)))) & + STOP 11 + + a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/)) + bo = (/99_k, -1_k, 42_k/) + a = eoshift (a, -2_k, bo, 2_k) + if (any (a .ne. reshape ((/99_k, -1_k, 42_k, 99_k, -1_k, 42_k, 1_k, 2_k, 3_k/), (/3_k, 3_k/)))) & + STOP 12 + + ! Array shift and array bound. + a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/)) + a = eoshift (a, (/1_k, 0_k, -1_k/), (/99_k, -1_k, 42_k/), 1_k) + if (any (a .ne. reshape ((/2_k, 3_k, 99_k, 4_k, 5_k, 6_k, 42_k, 7_k, 8_k/), (/3_k, 3_k/)))) & + STOP 13 + + a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/)) + a = eoshift (a, (/2_k, -2_k, 0_k/), (/99_k, -1_k, 42_k/), 2_k) + if (any (a .ne. reshape ((/7_k, -1_k, 3_k, 99_k, -1_k, 6_k, 99_k, 2_k, 9_k/), (/3_k, 3_k/)))) & + STOP 14 + + a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/)) + sh = (/ 3_k, -1_k, -3_k /) + bo = (/-999_k, -99_k, -9_k /) + a = eoshift(a, shift=sh, boundary=bo) + if (any (a .ne. reshape ((/ -999_k, -999_k, -999_k, -99_k, 4_k, 5_k, -9_k, -9_k, -9_k /), & + shape(a)))) STOP 15 + + a = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/)) + a = eoshift (a, (/9999_k, -9999_k, 0_k/), (/99_k, -1_k, 42_k/), 2_k) + if (any (a .ne. reshape ((/99_k, -1_k, 3_k, 99_k, -1_k, 6_k, 99_k, -1_k, 9_k/), (/3_k, 3_k/)))) & + STOP 16 + + ! Test arrays > rank 2 + b(:, :, 1_k) = reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/)) + b(:, :, 2_k) = 10_k + reshape ((/1_k, 2_k, 3_k, 4_k, 5_k, 6_k, 7_k, 8_k, 9_k/), (/3_k, 3_k/)) + b = eoshift (b, 1_k, 99_k, 1_k) + if (any (b(:, :, 1_k) .ne. reshape ((/2_k, 3_k, 99_k, 5_k, 6_k, 99_k, 8_k, 9_k, 99_k/), (/3_k, 3_k/)))) & + STOP 17 + if (any (b(:, :, 2_k) .ne. reshape ((/12_k, 13_k, 99_k, 15_k, 16_k, 99_k, 18_k, 19_k, 99_k/), (/3_k, 3_k/)))) & + STOP 18 + + ! TODO: Test array sections +end program diff --git a/Fortran/gfortran/regression/equiv_1.f90 b/Fortran/gfortran/regression/equiv_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/equiv_1.f90 @@ -0,0 +1,9 @@ + program broken_equiv + real d (2) ! { dg-error "Inconsistent equivalence rules" "d" } + real e ! { dg-error "Inconsistent equivalence rules" "e" } + equivalence (d (1), e), (d (2), e) + + real f (2) ! { dg-error "Inconsistent equivalence rules" "f" } + double precision g (2) ! { dg-error "Inconsistent equivalence rules" "g" } + equivalence (f (1), g (1)), (f (2), g (2)) ! Not standard conforming + end diff --git a/Fortran/gfortran/regression/equiv_10.f90 b/Fortran/gfortran/regression/equiv_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/equiv_10.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! PR fortran/90986 +module mymod + type :: mytyp + integer :: i + end type mytyp +contains + subroutine mysub + implicit none + type(mytyp) :: a + integer :: equivalencei,equivalencej + equivalencei = a%i + equivalencej = a%j ! { dg-error "is not a member of the" } + end subroutine mysub +end module mymod diff --git a/Fortran/gfortran/regression/equiv_11.f90 b/Fortran/gfortran/regression/equiv_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/equiv_11.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-fsecond-underscore" } +! PR fortran/95106 + +module m2345678901234567890123456789012345678901234567890123456789_123 + implicit none + real :: a(4), u(3,2) + real :: b(4), v(4,2) + equivalence (a(1),u(1,1)), (b(1),v(1,1)) +end +! { dg-final { scan-assembler {m2345678901234567890123456789012345678901234567890123456789_123.eq.0__} } } +! { dg-final { scan-assembler {m2345678901234567890123456789012345678901234567890123456789_123.eq.1__} } } diff --git a/Fortran/gfortran/regression/equiv_2.f90 b/Fortran/gfortran/regression/equiv_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/equiv_2.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! + subroutine broken_equiv1 + character*4 h + character*3 i + equivalence (h(1:3), i(2:1)) ! { dg-error "has length zero" } + end subroutine + + subroutine broken_equiv2 + character*4 j + character*2 k + equivalence (j(2:3), k(1:5)) ! { dg-error "exceeds the string length" } + end subroutine + + subroutine broken_equiv3 + character*4 l + character*2 m + equivalence (l(2:3:4), m(1:2)) ! { dg-error "\[Ss\]yntax error" } + end subroutine diff --git a/Fortran/gfortran/regression/equiv_5.f90 b/Fortran/gfortran/regression/equiv_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/equiv_5.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/25078 +! An equivalence statement requires two or more objcets. +program a + real x + equivalence(x) ! { dg-error "two or more objects" } +end program a diff --git a/Fortran/gfortran/regression/equiv_6.f90 b/Fortran/gfortran/regression/equiv_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/equiv_6.f90 @@ -0,0 +1,77 @@ +! { dg-do run } +! This checks the patch for PR25395, in which equivalences within one +! segment were broken by indirect equivalences, depending on the +! offset of the variable that bridges the indirect equivalence. +! +! This is a fortran95 version of the original testcase, which was +! contributed by Harald Vogt +program check_6 + common /abc/ mwkx(80) + common /cde/ lischk(20) + dimension listpr(20),lisbit(10),lispat(8) +! This was badly compiled in the PR: + equivalence (listpr(10),lisbit(1),mwkx(10)), & + (lispat(1),listpr(10)) + lischk = (/0, 0, 0, 0, 0, 0, 0, 0, 0, 1, & + 2, 0, 0, 5, 6, 7, 8, 9,10, 0/) + +! These two calls replace the previously made call to subroutine +! set_arrays which was erroneous because of parameter-induced +! aliasing. + call set_array_listpr (listpr) + call set_array_lisbit (lisbit) + + if (any (listpr.ne.lischk)) STOP 1 + call sub1 + call sub2 + call sub3 +end +subroutine sub1 + common /abc/ mwkx(80) + common /cde/ lischk(20) + dimension listpr(20),lisbit(10),lispat(8) +! This workaround was OK + equivalence (listpr(10),lisbit(1)), & + (listpr(10),mwkx(10)), & + (listpr(10),lispat(1)) + call set_array_listpr (listpr) + call set_array_lisbit (lisbit) + if (any (listpr .ne. lischk)) STOP 2 +end +! +! Equivalences not in COMMON +!___________________________ +! This gave incorrect results for the same reason as in MAIN. +subroutine sub2 + dimension mwkx(80) + common /cde/ lischk(20) + dimension listpr(20),lisbit(10),lispat(8) + equivalence (lispat(1),listpr(10)), & + (mwkx(10),lisbit(1),listpr(10)) + call set_array_listpr (listpr) + call set_array_lisbit (lisbit) + if (any (listpr .ne. lischk)) STOP 3 +end +! This gave correct results because the order in which the +! equivalences are taken is different and was given in the PR. +subroutine sub3 + dimension mwkx(80) + common /cde/ lischk(20) + dimension listpr(20),lisbit(10),lispat(8) + equivalence (listpr(10),lisbit(1),mwkx(10)), & + (lispat(1),listpr(10)) + call set_array_listpr (listpr) + call set_array_lisbit (lisbit) + if (any (listpr .ne. lischk)) STOP 4 +end + +subroutine set_array_listpr (listpr) + dimension listpr(20) + listpr = 0 +end + +subroutine set_array_lisbit (lisbit) + dimension lisbit(10) + lisbit = (/(i, i = 1, 10)/) + lisbit((/3,4/)) = 0 +end diff --git a/Fortran/gfortran/regression/equiv_7.f90 b/Fortran/gfortran/regression/equiv_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/equiv_7.f90 @@ -0,0 +1,114 @@ +! { dg-do run } +! { dg-options "-std=gnu" } +! Tests the fix for PR29786, in which initialization of overlapping +! equivalence elements caused a compile error. +! +! Contributed by Bernhard Fischer +! +block data + common /global/ ca (4) + integer(4) ca, cb + equivalence (cb, ca(3)) + data (ca(i), i = 1, 2) /42,43/, ca(4) /44/ + data cb /99/ +end block data + + integer(4), parameter :: abcd = ichar ("a") + 256_4 * (ichar("b") + 256_4 * & + (ichar ("c") + 256_4 * ichar ("d"))) + logical(4), parameter :: bigendian = transfer (abcd, "wxyz") .eq. "abcd" + + call int4_int4 + call real4_real4 + call complex_real + call check_block_data + call derived_types ! Thanks to Tobias Burnus for this:) +! +! This came up in PR29786 comment #9 - Note the need to treat endianess +! Thanks Dominique d'Humieres:) +! + if (bigendian) then + if (d1mach_little (1) .ne. transfer ((/0_4, 1048576_4/), 1d0)) STOP 1 + if (d1mach_little (2) .ne. transfer ((/-1_4,2146435071_4/), 1d0)) STOP 2 + else + if (d1mach_big (1) .ne. transfer ((/1048576_4, 0_4/), 1d0)) STOP 3 + if (d1mach_big (2) .ne. transfer ((/2146435071_4,-1_4/), 1d0)) STOP 4 + end if +! +contains + subroutine int4_int4 + integer(4) a(4) + integer(4) b + equivalence (b,a(3)) + data b/3/ + data (a(i), i=1,2) /1,2/, a(4) /4/ + if (any (a .ne. (/1, 2, 3, 4/))) STOP 5 + end subroutine int4_int4 + subroutine real4_real4 + real(4) a(4) + real(4) b + equivalence (b,a(3)) + data b/3.0_4/ + data (a(i), i=1,2) /1.0_4, 2.0_4/, & + a(4) /4.0_4/ + if (sum (abs (a - & + (/1.0_4, 2.0_4, 3.0_4, 4.0_4/))) > 1.0e-6) STOP 6 + end subroutine real4_real4 + subroutine complex_real + complex(4) a(4) + real(4) b(2) + equivalence (b,a(3)) + data b(1)/3.0_4/, b(2)/4.0_4/ + data (a(i), i=1,2) /(0.0_4, 1.0_4),(2.0_4,0.0_4)/, & + a(4) /(0.0_4,5.0_4)/ + if (sum (abs (a - (/(0.0_4, 1.0_4),(2.0_4, 0.0_4), & + (3.0_4, 4.0_4),(0.0_4, 5.0_4)/))) > 1.0e-6) STOP 7 + end subroutine complex_real + subroutine check_block_data + common /global/ ca (4) + equivalence (ca(3), cb) + integer(4) ca + if (any (ca .ne. (/42, 43, 99, 44/))) STOP 8 + end subroutine check_block_data + function d1mach_little(i) result(d1mach) + implicit none + double precision d1mach,dmach(5) + integer i + integer*4 large(4),small(4) + equivalence ( dmach(1), small(1) ) + equivalence ( dmach(2), large(1) ) + data small(1),small(2) / 0, 1048576/ + data large(1),large(2) /-1,2146435071/ + d1mach = dmach(i) + end function d1mach_little + function d1mach_big(i) result(d1mach) + implicit none + double precision d1mach,dmach(5) + integer i + integer*4 large(4),small(4) + equivalence ( dmach(1), small(1) ) + equivalence ( dmach(2), large(1) ) + data small(1),small(2) /1048576, 0/ + data large(1),large(2) /2146435071,-1/ + d1mach = dmach(i) + end function d1mach_big + subroutine derived_types + TYPE T1 + sequence + character (3) :: chr + integer :: i = 1 + integer :: j + END TYPE T1 + TYPE T2 + sequence + character (3) :: chr = "wxy" + integer :: i = 1 + integer :: j = 4 + END TYPE T2 + TYPE(T1) :: a1 + TYPE(T2) :: a2 + EQUIVALENCE(a1,a2) ! { dg-warning="mixed|components" } + if (a1%chr .ne. "wxy") STOP 9 + if (a1%i .ne. 1) STOP 10 + if (a1%j .ne. 4) STOP 11 + end subroutine derived_types +end diff --git a/Fortran/gfortran/regression/equiv_8.f90 b/Fortran/gfortran/regression/equiv_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/equiv_8.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! +! PR fortran/41755 +! + common /uno/ aa + equivalence (aa,aaaaa) (bb,cc) ! { dg-error "Expecting a comma in EQUIVALENCE" } + end diff --git a/Fortran/gfortran/regression/equiv_9.f90 b/Fortran/gfortran/regression/equiv_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/equiv_9.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +! PR fortran/66377 +! +module constant + integer x1, x2, x3 + integer x(3) + equivalence (x(1),x1), (x2,x(2)), (x3,x(3)) +end module + +program test + use constant + implicit none + x = (/1, 2, 3/) + call another() +end program + +subroutine another() + use constant, only : x2 + implicit none + if (x2 /= 2) STOP 1 +end subroutine diff --git a/Fortran/gfortran/regression/equiv_constraint_1.f90 b/Fortran/gfortran/regression/equiv_constraint_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/equiv_constraint_1.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! PR20901 - F95 constrains mixing of types in equivalence. +! Contributed by Joost VandeVondele + character(len=4) :: a + integer :: i + equivalence(a,i) ! { dg-error "in default CHARACTER EQUIVALENCE statement at" } + END + + diff --git a/Fortran/gfortran/regression/equiv_constraint_2.f90 b/Fortran/gfortran/regression/equiv_constraint_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/equiv_constraint_2.f90 @@ -0,0 +1,74 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! PR20901 - Checks resolution of types in EQUIVALENCE statement when +! f95 standard is imposed. +! +! Contributed by Paul Thomas +! + type :: numeric_type + sequence + integer :: i + real :: x + real(kind=8) :: d + complex :: z + logical :: l + end type numeric_type + + type (numeric_type) :: my_num, thy_num + + type :: numeric_type2 + sequence + integer :: i + real :: x + real(kind=8) :: d + complex :: z + logical :: l + end type numeric_type2 + + type (numeric_type2) :: his_num + + type :: char_type + sequence + character(4) :: ch + character(4) :: cha (6) + end type char_type + + type (char_type) :: my_char + + type :: mixed_type + sequence + integer :: i(4) + character(4) :: cha (6) + end type mixed_type + + type (mixed_type) :: my_mixed, thy_mixed + + character(len=4) :: ch + integer :: num + integer(kind=8) :: non_def + complex(kind=8) :: my_z, thy_z + +! Permitted: character with character sequence +! numeric with numeric sequence +! numeric sequence with numeric sequence +! non-default of same type +! mixed sequences of same type + equivalence (ch, my_char) + equivalence (num, my_num) + equivalence (my_num, his_num, thy_num) + equivalence (my_z, thy_z) + equivalence (my_mixed, thy_mixed) + +! Not permitted by the standard - OK with -std=gnu + equivalence (my_mixed, my_num) ! { dg-error "with mixed components in EQUIVALENCE" } + equivalence (my_z, num) ! { dg-error "Non-default type object or sequence" } + equivalence (my_char, my_num) ! { dg-error "in default CHARACTER EQUIVALENCE" } + equivalence (ch, my_num) ! { dg-error "in default CHARACTER EQUIVALENCE" } + equivalence (my_num, ch) ! { dg-error "in default NUMERIC EQUIVALENCE" } + equivalence (num, my_char) ! { dg-error "in default NUMERIC EQUIVALENCE" } + equivalence (my_char, num) ! { dg-error "in default CHARACTER EQUIVALENCE" } + equivalence (non_def, ch) ! { dg-error "Non-default type object or sequence" } + equivalence (my_z, ch) ! { dg-error "Non-default type object or sequence" } + equivalence (my_z, num) ! { dg-error "Non-default type object or sequence" } + END diff --git a/Fortran/gfortran/regression/equiv_constraint_3.f90 b/Fortran/gfortran/regression/equiv_constraint_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/equiv_constraint_3.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR20900 - USE associated variables cannot be equivalenced. +! Contributed by Joost VandeVondele +MODULE TEST + INTEGER :: I +END MODULE +! note 11.7 +USE TEST, ONLY : K=>I +INTEGER :: L +EQUIVALENCE(K,L) ! { dg-error "conflicts with USE ASSOCIATED attribute" } +END diff --git a/Fortran/gfortran/regression/equiv_constraint_4.f90 b/Fortran/gfortran/regression/equiv_constraint_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/equiv_constraint_4.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-O0" } +! PR20901 - check that derived/numeric equivalence works with std!=f95. +! Contributed by Joost VandeVondele +TYPE data_type + SEQUENCE + INTEGER :: I +END TYPE data_type +INTEGER :: J = 7 +TYPE(data_type) :: dd +EQUIVALENCE(dd,J) +if (dd%i.ne.7) STOP 1 +END + + + diff --git a/Fortran/gfortran/regression/equiv_constraint_5.f90 b/Fortran/gfortran/regression/equiv_constraint_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/equiv_constraint_5.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O0" } +! PR20902 - Overlapping initializers in an equivalence block must +! have the same value. +! +! The code was replaced completely after the fix for PR30875, which +! is a repeat of the original and comes from the same contributor. +! The fix for 20902 was wrong. +! +! Contributed by Joost VandeVondele +! + TYPE T1 + sequence + integer :: i=1 + END TYPE T1 + TYPE T2 ! OK because initializers are equal + sequence + integer :: i=1 + END TYPE T2 + TYPE T3 + sequence + integer :: i=2 + END TYPE T3 + TYPE(T1) :: a1 + TYPE(T2) :: a2 + TYPE(T3) :: a3 + EQUIVALENCE (a1, a2) + EQUIVALENCE (a1, a3) ! { dg-error "Overlapping unequal initializers" } + write(6, *) a1, a2, a3 +END + diff --git a/Fortran/gfortran/regression/equiv_constraint_6.f90 b/Fortran/gfortran/regression/equiv_constraint_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/equiv_constraint_6.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR16404 test 3 and PR20835 - Target cannot be equivalence object. +! Contributed by Joost VandeVondele + REAL :: A + REAL, TARGET :: B + EQUIVALENCE(A,B) ! { dg-error "conflicts with TARGET attribute" } +END + diff --git a/Fortran/gfortran/regression/equiv_constraint_7.f90 b/Fortran/gfortran/regression/equiv_constraint_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/equiv_constraint_7.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-O0" } +! PR20890 - Equivalence cannot contain overlapping unequal initializers. +! Contributed by Joost VandeVondele +! Started out being in BLOCK DATA; however, blockdata variables must be in +! COMMON and therefore cannot have F95 style initializers.... + MODULE DATA + INTEGER :: I=1,J=2 + EQUIVALENCE(I,J) ! { dg-error "Overlapping unequal initializers" } + END MODULE DATA + END diff --git a/Fortran/gfortran/regression/equiv_constraint_8.f90 b/Fortran/gfortran/regression/equiv_constraint_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/equiv_constraint_8.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-O0" } +! PR20899 - Common block variables cannot be equivalenced in a pure procedure. +! Contributed by Joost VandeVondele +common /z/ i +contains +pure integer function test(j) + integer, intent(in) :: j + common /z/ i + integer :: k + equivalence(i,k) ! { dg-error "EQUIVALENCE object in the pure" } + k=1 ! { dg-error "variable definition context" } + test=i*j +end function test +end + diff --git a/Fortran/gfortran/regression/equiv_constraint_9.f90 b/Fortran/gfortran/regression/equiv_constraint_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/equiv_constraint_9.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR fortran/34655 +! +! Check for F2003's 5.5.2.5 Restrictions on common and equivalence +! Test case contributed by Joost VandeVondele. +! +implicit none +type data_type + sequence + integer :: I = 7 +end type data_type + + +type data_type2 + sequence + integer :: I +end type data_type2 + +type(data_type) :: dd, ff +type(data_type2) :: gg +integer :: j, k, m +EQUIVALENCE(dd,J) ! { dg-error "with default initialization cannot be in EQUIVALENCE with a variable in COMMON" } +EQUIVALENCE(ff,k) +EQUIVALENCE(gg,m) +COMMON /COM/ j +COMMON /COM/ m +END diff --git a/Fortran/gfortran/regression/equiv_constraint_bind_c.f90 b/Fortran/gfortran/regression/equiv_constraint_bind_c.f90 --- /dev/null +++ b/Fortran/gfortran/regression/equiv_constraint_bind_c.f90 @@ -0,0 +1,11 @@ +! Testcase for using EQUIVALENCE with BIND(C) +! See PR fortran/39239 +! { dg-do compile } +module m + use iso_c_binding + implicit none + integer(c_int) :: i1, i2 + bind(C) :: i2 + equivalence(i1,i2) ! { dg-error "EQUIVALENCE attribute conflicts with BIND" } +end module m + diff --git a/Fortran/gfortran/regression/equiv_pure.f90 b/Fortran/gfortran/regression/equiv_pure.f90 --- /dev/null +++ b/Fortran/gfortran/regression/equiv_pure.f90 @@ -0,0 +1,52 @@ +! { dg-do compile } +! PR fortran/82796 +! Code contributed by ripero84 at gmail dot com +module eq + implicit none + integer :: n1, n2 + integer, dimension(2) :: a + equivalence (a(1), n1) + equivalence (a(2), n2) + common /a/ a +end module eq + +module m + use eq + implicit none + type, public :: t + integer :: i + end type t +end module m + +module p + implicit none + contains + pure integer function d(h) + use m + implicit none + integer, intent(in) :: h + d = h + end function +end module p + +module q + implicit none + contains + pure integer function d(h) + use m, only : t + implicit none + integer, intent(in) :: h + d = h + end function +end module q + +module r + implicit none + contains + pure integer function d(h) + use m, only : a ! { dg-error "cannot be an EQUIVALENCE object" } + implicit none + integer, intent(in) :: h + d = h + end function +end module r diff --git a/Fortran/gfortran/regression/equiv_substr.f90 b/Fortran/gfortran/regression/equiv_substr.f90 --- /dev/null +++ b/Fortran/gfortran/regression/equiv_substr.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +! PR fortran/34557 +! +! Substrings with space before '(' were not properly parsed. +! +implicit none +character :: A(2,2)*2, B(2)*3, C*5 +equivalence (A (2,1) (1:1), B (1) (2:3), C (3:5)) +end diff --git a/Fortran/gfortran/regression/erf.f90 b/Fortran/gfortran/regression/erf.f90 --- /dev/null +++ b/Fortran/gfortran/regression/erf.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! +! Check whether ERF/ERFC take scalars and arrays as arguments (PR31760). +! +PROGRAM test_erf + REAL :: r = 0.0, ra(2) = (/ 0.0, 1.0 /) + + r = erf(r) + r = erfc(r) + + ra = erf(ra) + ra = erfc(ra) +END PROGRAM \ No newline at end of file diff --git a/Fortran/gfortran/regression/erf_2.F90 b/Fortran/gfortran/regression/erf_2.F90 --- /dev/null +++ b/Fortran/gfortran/regression/erf_2.F90 @@ -0,0 +1,51 @@ +! { dg-options "-fno-range-check -ffree-line-length-none -O0" } +! { dg-add-options ieee } +! +! Check that simplification functions and runtime library agree on ERF, +! ERFC and ERFC_SCALED. + +program test + implicit none + + interface check + procedure check_r4 + procedure check_r8 + end interface check + + real(kind=4) :: x4 + real(kind=8) :: x8 + +#define CHECK(a) \ + x8 = a ; x4 = a ; \ + call check(erf(real(a,kind=8)), erf(x8)) ; \ + call check(erf(real(a,kind=4)), erf(x4)) ; \ + call check(erfc(real(a,kind=8)), erfc(x8)) ; \ + call check(erfc(real(a,kind=4)), erfc(x4)) ; \ + call check(erfc_scaled(real(a,kind=8)), erfc_scaled(x8)) ; \ + call check(erfc_scaled(real(a,kind=4)), erfc_scaled(x4)) ; + + CHECK(0.0) + CHECK(0.9) + CHECK(1.9) + CHECK(19.) + CHECK(190.) + + CHECK(-0.0) + CHECK(-0.9) + CHECK(-1.9) + CHECK(-19.) + CHECK(-190.) + +contains + + subroutine check_r4 (a, b) + real(kind=4), intent(in) :: a, b + if (abs(a - b) > 10 * spacing(a)) STOP 1 + end subroutine + + subroutine check_r8 (a, b) + real(kind=8), intent(in) :: a, b + if (abs(a - b) > 10 * spacing(a)) STOP 2 + end subroutine + +end program test diff --git a/Fortran/gfortran/regression/erf_3.F90 b/Fortran/gfortran/regression/erf_3.F90 --- /dev/null +++ b/Fortran/gfortran/regression/erf_3.F90 @@ -0,0 +1,48 @@ +! { dg-options "-fno-range-check -ffree-line-length-none -O0" } +! { dg-add-options ieee } +! { dg-skip-if "PR libfortran/59313" { hppa*-*-hpux* } } +! +! Check that simplification functions and runtime library agree on ERF, +! ERFC and ERFC_SCALED, for quadruple-precision. +! + +program test + use, intrinsic :: iso_fortran_env + implicit none + + ! QP will be the largest supported real kind, possibly real(kind=16) + integer, parameter :: qp = real_kinds(ubound(real_kinds,dim=1)) + real(kind=qp) :: x + +#define CHECK(a) \ + x = a ; \ + call check(erf(real(a,kind=qp)), erf(x)) ; \ + call check(erfc(real(a,kind=qp)), erfc(x)) ; \ + call check(erfc_scaled(real(a,kind=qp)), erfc_scaled(x)) + + CHECK(0.0) + CHECK(0.9) + CHECK(1.9) + CHECK(10.) + CHECK(11.) + CHECK(12.) + CHECK(13.) + CHECK(14.) + CHECK(49.) + CHECK(190.) + + CHECK(-0.0) + CHECK(-0.9) + CHECK(-1.9) + CHECK(-19.) + CHECK(-190.) + +contains + + subroutine check (a, b) + real(kind=qp), intent(in) :: a, b + print *, abs(a-b) / spacing(a) + if (abs(a - b) > 10 * spacing(a)) STOP 1 + end subroutine + +end program test diff --git a/Fortran/gfortran/regression/erfc_scaled_1.f90 b/Fortran/gfortran/regression/erfc_scaled_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/erfc_scaled_1.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! +! { dg-options "" } +! Do not run with -pedantic checks enabled as "check" +! contains internal procedures which is a vendor extension + +program test + implicit none + + interface check + procedure check_r4 + procedure check_r8 + end interface check + + real(kind=4) :: x4 + real(kind=8) :: x8 + + x8 = 1.9_8 ; x4 = 1.9_4 + + call check(erfc_scaled(x8), erfc_scaled(1.9_8)) + call check(erfc_scaled(x4), erfc_scaled(1.9_4)) + +contains + subroutine check_r4 (a, b) + real(kind=4), intent(in) :: a, b + if (abs(a - b) > 1.e-5 * abs(b)) STOP 1 + end subroutine + subroutine check_r8 (a, b) + real(kind=8), intent(in) :: a, b + if (abs(a - b) > 1.e-7 * abs(b)) STOP 2 + end subroutine +end program test diff --git a/Fortran/gfortran/regression/erfc_scaled_2.f90 b/Fortran/gfortran/regression/erfc_scaled_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/erfc_scaled_2.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! Check that ERFC_SCALED can be used in initialization expressions + real, parameter :: r = 100*erfc_scaled(12.7) + integer(kind=int(r)) :: i + + real(kind=8), parameter :: r8 = 100*erfc_scaled(6.77) + integer(kind=int(r8)) :: j + + i = 12 + j = 8 + print *, i, j + + end diff --git a/Fortran/gfortran/regression/errnocheck_1.f90 b/Fortran/gfortran/regression/errnocheck_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/errnocheck_1.f90 @@ -0,0 +1,8 @@ +! { dg-do compile { target i?86-*-* x86_64-*-* } } +! Fortran should default to -fno-math-errno +! and thus no call to sqrt in asm +subroutine mysqrt(a) + real(KIND=KIND(0.0D0)) :: a + a=sqrt(a) +end subroutine +! { dg-final { scan-assembler-times "call" 0 } } diff --git a/Fortran/gfortran/regression/error_format.f90 b/Fortran/gfortran/regression/error_format.f90 --- /dev/null +++ b/Fortran/gfortran/regression/error_format.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! { dg-shouldfail "Runtime error format check" } +! PR32456 IO error message should show Unit/Filename +program test + implicit none + integer :: i + open(99, status="scratch") + read(99,*) i +end program +! { dg-output ".*(unit = 99, file = .*)" } +! { dg-output "Fortran runtime error: End of file" } diff --git a/Fortran/gfortran/regression/error_format_2.f90 b/Fortran/gfortran/regression/error_format_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/error_format_2.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! PR68987, this test case failed on a memory double free +program foo + call s('(foo)') +end program +subroutine s(fmt) + character (*) :: fmt + character (1) :: c + integer :: i + write (c, fmt, iostat=i) 42 + ! print *, i + if (i==0) STOP 1 + write (c, fmt, err=100) 42 + STOP 2 +100 continue +end subroutine diff --git a/Fortran/gfortran/regression/error_recovery_1.f90 b/Fortran/gfortran/regression/error_recovery_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/error_recovery_1.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! PR fortran/24549 (and duplicate PR fortran/27487) +module gfcbug29_import + interface + subroutine foo (x) ! { dg-warning "wrong number of arguments" } + something :: dp ! { dg-error "Unclassifiable statement" } + real (kind=dp) :: x ! { dg-error "has not been declared or is a variable, which does not reduce to a constant expression" } + end subroutine foo + end interface +end module gfcbug29_import + +subroutine FOO ! { dg-warning "wrong number of arguments" } + X :: I + equivalence (I,I) +end diff --git a/Fortran/gfortran/regression/error_recovery_2.f90 b/Fortran/gfortran/regression/error_recovery_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/error_recovery_2.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! PR27954 Internal compiler error on bad statements +! Derived from test case submitted in PR. +subroutine bad1 + character*20 :: y, x 00 ! { dg-error "Syntax error" } + data y /'abcdef'/, x /'jbnhjk'/ pp ! { dg-error "Syntax error" } +end subroutine bad1 + +subroutine bad2 + character*20 :: y, x 00 ! { dg-error "Syntax error" } + data y /'abcdef'/, x /'jbnhjk'/ pp ! { dg-error "Syntax error" } + print *, "basket case." +end subroutine bad2 + +subroutine bad3 + implicit none + character*20 :: y, x 00 ! { dg-error "Syntax error" } + data y /'abcdef'/, x /'jbnhjk'/ pp ! { dg-error "Syntax error" } + print *, "basket case that segfaults without patch." +end subroutine bad3 + diff --git a/Fortran/gfortran/regression/error_recovery_3.f90 b/Fortran/gfortran/regression/error_recovery_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/error_recovery_3.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR30779 incomplete file triggers ICE. +! Note: This file is deliberately cut short to verify a graceful exit. Before +! the patch this gave ICE. +MODULE M1 + INTEGER :: I +END MODULE M1 + +USE M1, ONLY: I,&! { dg-error "Missing" } diff --git a/Fortran/gfortran/regression/error_recovery_4.f90 b/Fortran/gfortran/regression/error_recovery_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/error_recovery_4.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +! PR33609 ICE on arithmetic overflow +! Before patch, this segfaulted. +print *, real(huge(1.0_8),4) ! { dg-error "Arithmetic overflow" } +end diff --git a/Fortran/gfortran/regression/error_recovery_5.f90 b/Fortran/gfortran/regression/error_recovery_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/error_recovery_5.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! PR34411 hang-up during read of non-expected input +! Test case derived from that given in PR +! Prior to patch, the do loop was infinite, limits set in this one +program pr34411 + real :: x,y + ii = 0 + iostat = 0 + x = 0.0; y= 0.0 + open (10, status="scratch") + write (10, '(a)')" 289 329.142 214.107 12.313 12.050 11.913 11.868" + write (10, '(a)')" 2038.497 99.99 0.00 0.019 0.021 0.025 0.034" + write (10, '(a)')"" + write (10, '(a)')" 413 360.334 245.261 12.375 11.910 11.469 11.086" + write (10, '(a)')" 2596.395 99.99 0.00 0.019 0.017 0.016 0.015" + write (10, '(a)')"" + write (10, '(a)')" 655 332.704 317.964 12.523 12.212 11.998 11.892" + write (10, '(a)')" 1627.586 99.99 0.00 0.005 0.005 0.006 0.007" + write (10, '(a)')"" + write (10, '(a)')" 360 379.769 231.226 12.709 12.422 12.195 11.941" + write (10, '(a)')" 2561.539 99.99 0.00 0.042 0.043 0.050 0.055" + rewind 10 + do i = 1,100 + read(10,'(T7,2F9.3)', iostat=ii, end=666) x,y + end do +666 continue + if (i /= 12) STOP 1 + if (x /= 379.76901 .and. y /= 231.22600) STOP 2 + close(10) +end program pr34411 diff --git a/Fortran/gfortran/regression/error_stop_1.f08 b/Fortran/gfortran/regression/error_stop_1.f08 --- /dev/null +++ b/Fortran/gfortran/regression/error_stop_1.f08 @@ -0,0 +1,5 @@ +! { dg-do run } +program stopper + real, dimension(5,5,5) :: i + error stop size(i) ! { dg-shouldfail "ERROR STOP 125" } +end program stopper diff --git a/Fortran/gfortran/regression/error_stop_2.f08 b/Fortran/gfortran/regression/error_stop_2.f08 --- /dev/null +++ b/Fortran/gfortran/regression/error_stop_2.f08 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR44371 STOP parsing rejects valid code. + real, dimension(5,5,5) :: i + character(1) c, y + y = 'y' + read(y,*) c + if (c=='x') stop; if (c=='X') stop + if (c=='x') stop size(i); if (c=='X') stop + + if (c=='y') stop size(i) if (c=='Y') stop ! { dg-error "Syntax error in STOP" } + end diff --git a/Fortran/gfortran/regression/error_stop_3.f90 b/Fortran/gfortran/regression/error_stop_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/error_stop_3.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "-std=f2018" } +! +! F2018 permits ERROR STOP in PURE procedures +! +pure subroutine foo() + error stop "failed" +end diff --git a/Fortran/gfortran/regression/error_stop_4.f90 b/Fortran/gfortran/regression/error_stop_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/error_stop_4.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +! F2018 permits ERROR STOP in PURE procedures +! +pure subroutine foo() + error stop "failed" ! { dg-error "Fortran 2018: ERROR STOP statement at .1. in PURE procedure" } +end diff --git a/Fortran/gfortran/regression/execute_command_line_1.f90 b/Fortran/gfortran/regression/execute_command_line_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/execute_command_line_1.f90 @@ -0,0 +1,60 @@ +! { dg-do compile } +! +! Check that we accept all variants of the EXECUTE_COMMAND_LINE intrinsic. +! + integer :: i, j + character(len=100) :: s + + s = "" + + call execute_command_line ("ls *.f90") + + print *, "-----------------------------" + + call execute_command_line ("sleep 1 ; ls *.f90", .false.) + print *, "I'm not waiting" + call sleep(2) + + print *, "-----------------------------" + + call execute_command_line ("sleep 1 ; ls *.f90", .true.) + print *, "I did wait" + call sleep(2) + + print *, "-----------------------------" + + call execute_command_line ("ls *.f90", .true., i) + print *, "Exist status was: ", i + + print *, "-----------------------------" + + call execute_command_line ("ls *.doesnotexist", .true., i) + print *, "Exist status was: ", i + + print *, "-----------------------------" + + call execute_command_line ("echo foo", .true., i, j) + print *, "Exist status was: ", i + print *, "Command status was: ", j + + print *, "-----------------------------" + + call execute_command_line ("echo foo", .true., i, j, s) + print *, "Exist status was: ", i + print *, "Command status was: ", j + print *, "Error message is: ", trim(s) + + print *, "-----------------------------" + + call execute_command_line ("ls *.doesnotexist", .true., i, j, s) + print *, "Exist status was: ", i + print *, "Command status was: ", j + print *, "Error message is: ", trim(s) + + print *, "-----------------------------" + + call execute_command_line ("sleep 20", .false.) + print *, "Please kill me with ^C" + call sleep (10) + + end diff --git a/Fortran/gfortran/regression/execute_command_line_2.f90 b/Fortran/gfortran/regression/execute_command_line_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/execute_command_line_2.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! +! Check that EXECUTE_COMMAND_LINE handles invalid command lines appropriately +! + integer :: s = 0, c = 0 + character(len=255) :: msg = "" + + ! This should fail, set CMDSTAT to nonzero value, and an error message + ! in CMDMSG. + call execute_command_line ("/nosuchfile", exitstat=s, cmdstat=c, cmdmsg=msg) + if (c == 0) STOP 1 + if (len_trim(msg) == 0) STOP 2 + +end diff --git a/Fortran/gfortran/regression/execute_command_line_3.f90 b/Fortran/gfortran/regression/execute_command_line_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/execute_command_line_3.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! PR 82233 - there were program aborts for some of these commands. +! Original test case by Urban Jost. +program boom +implicit none +integer :: i,j +character(len=256) :: msg +character(len=:), allocatable :: command + command='notthere' + msg='' ! seems to only be defined if exitstatus.ne.0 + ! ok -- these work + call execute_command_line(command , wait=.false., exitstat=i, cmdstat=j, cmdmsg=msg) + if (j /= 0 .or. msg /= '') STOP 1 + call execute_command_line(command , exitstat=i, cmdstat=j, cmdmsg=msg ) + if (j /= 3 .or. msg /= "Invalid command line" ) STOP 2 + msg = '' + call execute_command_line(command , wait=.false., exitstat=i, cmdmsg=msg ) + if (j /= 3) STOP 3 + call execute_command_line(command , wait=.false., exitstat=i ) + if (msg /= '') STOP 4 + call execute_command_line(command , exitstat=i, cmdstat=j ) + +end program boom diff --git a/Fortran/gfortran/regression/exit_1.f08 b/Fortran/gfortran/regression/exit_1.f08 --- /dev/null +++ b/Fortran/gfortran/regression/exit_1.f08 @@ -0,0 +1,50 @@ +! { dg-do run } +! { dg-options "-std=f2008 " } + +! PR fortran/44709 +! Check that exit and cycle from within a BLOCK works for loops as expected. + +! Contributed by Daniel Kraft, d@domob.eu. + +PROGRAM main + IMPLICIT NONE + INTEGER :: i + + ! Simple exit without loop name. + DO + BLOCK + EXIT + END BLOCK + STOP 1 + END DO + + ! Cycle without loop name. + DO i = 1, 1 + BLOCK + CYCLE + END BLOCK + STOP 2 + END DO + + ! Exit loop by name from within a BLOCK. + loop1: DO + DO + BLOCK + EXIT loop1 + END BLOCK + STOP 3 + END DO + STOP 4 + END DO loop1 + + ! Cycle loop by name from within a BLOCK. + loop2: DO i = 1, 1 + loop3: DO + BLOCK + CYCLE loop2 + END BLOCK + STOP 5 + END DO loop3 + STOP 6 + END DO loop2 +END PROGRAM main diff --git a/Fortran/gfortran/regression/exit_2.f08 b/Fortran/gfortran/regression/exit_2.f08 --- /dev/null +++ b/Fortran/gfortran/regression/exit_2.f08 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } + +! PR fortran/44709 +! Check that the resolving of loop names in parent namespaces introduced to +! handle intermediate BLOCK's does not go too far and other sanity checks. + +! Contributed by Daniel Kraft, d@domob.eu. + +PROGRAM main + IMPLICIT NONE + + EXIT ! { dg-error "is not within a construct" } + EXIT foobar ! { dg-error "is unknown" } + EXIT main ! { dg-error "is not a construct name" } + + mainLoop: DO + CALL test () + END DO mainLoop + + otherLoop: DO + EXIT mainLoop ! { dg-error "is not within construct 'mainloop'" } + END DO otherLoop + +CONTAINS + + SUBROUTINE test () + EXIT mainLoop ! { dg-error "is unknown" } + END SUBROUTINE test + +END PROGRAM main diff --git a/Fortran/gfortran/regression/exit_3.f08 b/Fortran/gfortran/regression/exit_3.f08 --- /dev/null +++ b/Fortran/gfortran/regression/exit_3.f08 @@ -0,0 +1,88 @@ +! { dg-do run } +! { dg-options "-std=f2008 " } + +! PR fortran/44602 +! Check for correct behavior of EXIT / CYCLE combined with non-loop +! constructs at run-time. + +! Contributed by Daniel Kraft, d@domob.eu. + +PROGRAM main + IMPLICIT NONE + + TYPE :: t + END TYPE t + + INTEGER :: i + CLASS(t), ALLOCATABLE :: var + + ! EXIT and CYCLE without names always refer to innermost *loop*. This + ! however is checked at run-time already in exit_1.f08. + + ! Basic EXITs from different non-loop constructs. + + i = 2 + myif: IF (i == 1) THEN + STOP 1 + EXIT myif + ELSE IF (i == 2) THEN + EXIT myif + STOP 2 + ELSE + STOP 3 + EXIT myif + END IF myif + + mysel: SELECT CASE (i) + CASE (1) + STOP 4 + EXIT mysel + CASE (2) + EXIT mysel + STOP 5 + CASE DEFAULT + STOP 6 + EXIT mysel + END SELECT mysel + + mycharsel: SELECT CASE ("foobar") + CASE ("abc") + STOP 7 + EXIT mycharsel + CASE ("xyz") + STOP 8 + EXIT mycharsel + CASE DEFAULT + EXIT mycharsel + STOP 9 + END SELECT mycharsel + + myblock: BLOCK + EXIT myblock + STOP 10 + END BLOCK myblock + + myassoc: ASSOCIATE (x => 5 + 2) + EXIT myassoc + STOP 11 + END ASSOCIATE myassoc + + ALLOCATE (t :: var) + mytypesel: SELECT TYPE (var) + TYPE IS (t) + EXIT mytypesel + STOP 12 + CLASS DEFAULT + STOP 13 + EXIT mytypesel + END SELECT mytypesel + + ! Check EXIT with nested constructs. + outer: BLOCK + inner: IF (.TRUE.) THEN + EXIT outer + STOP 14 + END IF inner + STOP 15 + END BLOCK outer +END PROGRAM main diff --git a/Fortran/gfortran/regression/exit_4.f08 b/Fortran/gfortran/regression/exit_4.f08 --- /dev/null +++ b/Fortran/gfortran/regression/exit_4.f08 @@ -0,0 +1,29 @@ +! { dg-do compile } +! { dg-options "-std=f2008 -fcoarray=single" } + +! PR fortran/44602 +! Check for compile-time errors with non-loop EXITs. + +! Contributed by Daniel Kraft, d@domob.eu. + +PROGRAM main + IMPLICIT NONE + INTEGER :: bar(2) + + ! Must not exit CRITICAL. + mycrit: CRITICAL + EXIT mycrit ! { dg-error "leaves CRITICAL" } + END CRITICAL mycrit + + ! CYCLE is only allowed for loops! + myblock: BLOCK + CYCLE myblock ! { dg-error "is not applicable to non-loop construct 'myblock'" } + END BLOCK myblock + + ! Invalid construct. + ! Thanks to Mikael Morin, mikael.morin@sfr.fr. + baz: WHERE ([ .true., .true. ]) + bar = 0 + EXIT baz ! { dg-error "is not applicable to construct 'baz'" } + END WHERE baz +END PROGRAM main diff --git a/Fortran/gfortran/regression/exit_5.f03 b/Fortran/gfortran/regression/exit_5.f03 --- /dev/null +++ b/Fortran/gfortran/regression/exit_5.f03 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } + +! PR fortran/44602 +! Check for F2008 rejection of non-loop EXIT. + +! Contributed by Daniel Kraft, d@domob.eu. + +PROGRAM main + IMPLICIT NONE + + myname: IF (.TRUE.) THEN + EXIT myname ! { dg-error "Fortran 2008" } + END IF myname +END PROGRAM main diff --git a/Fortran/gfortran/regression/explicit_shape_1.f90 b/Fortran/gfortran/regression/explicit_shape_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/explicit_shape_1.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/83633 +! Original testcase by Nathan T. Weeks +! +integer :: A(command_argument_count()) = 1 ! { dg-error "nonconstant bounds" } +write (*,*) A +end diff --git a/Fortran/gfortran/regression/exponent_1.f90 b/Fortran/gfortran/regression/exponent_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/exponent_1.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! PR fortran/28276 +! Original code submitted by Harald Anlauf +! Converted to Dejagnu for the testsuite by Steven G. Kargl +! +program gfcbug36 + implicit none + real, parameter :: one = 1.0 + real :: a = one + + if (fraction(a) /= 0.5) STOP 1 + if (fraction(one) /= 0.5) STOP 2 + if (fraction(1.0) /= 0.5) STOP 3 + + if (exponent(a) /= 1.0) STOP 4 + if (exponent(one) /= 1.0) STOP 5 + if (exponent (1.0) /= 1.0) STOP 6 + + if (scale(fraction(a), exponent(a)) / a /= 1.) STOP 7 + if (scale(fraction(one), exponent(one)) / one /= 1.) STOP 8 + if (scale(fraction(1.0), exponent(1.0)) / 1.0 /= 1.) STOP 9 + +end program gfcbug36 diff --git a/Fortran/gfortran/regression/exponent_2.f90 b/Fortran/gfortran/regression/exponent_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/exponent_2.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! { dg-options "-fdefault-integer-8" } +! PR fortran/32942 +! Testcase contributed by Dominique d'Humieres . +integer i +real x +x = 3.0 +if (2 /= exponent(x)) STOP 1 +i = exponent (x) +if (i /= 2) STOP 2 +end diff --git a/Fortran/gfortran/regression/extended_char_comparison_1.f b/Fortran/gfortran/regression/extended_char_comparison_1.f --- /dev/null +++ b/Fortran/gfortran/regression/extended_char_comparison_1.f @@ -0,0 +1,22 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR 27715 - the front end and the library used to have different ideas +! about ordering for characters whose encoding is above 127. + + program main + character*1 c1, c2 + logical a1, a2 + c1 = '�'; + c2 = 'c'; + a1 = c1 > c2; + call setval(c1, c2) + a2 = c1 > c2 + if (a1 .neqv. a2) STOP 1 + end + + subroutine setval(c1, c2) + character*1 c1, c2 + c1 = '�'; + c2 = 'c'; + end diff --git a/Fortran/gfortran/regression/extends_1.f03 b/Fortran/gfortran/regression/extends_1.f03 --- /dev/null +++ b/Fortran/gfortran/regression/extends_1.f03 @@ -0,0 +1,71 @@ +! { dg-do run } +! A basic functional test of derived type extension. +! +! Contributed by Paul Thomas +! +module persons + type :: person + character(24) :: name = "" + integer :: ss = 1 + end type person +end module persons + +module person_education + use persons + type, extends(person) :: education + integer :: attainment = 0 + character(24) :: institution = "" + end type education +end module person_education + + use person_education + type, extends(education) :: service + integer :: personnel_number = 0 + character(24) :: department = "" + end type service + + type, extends(service) :: person_record + type (person_record), pointer :: supervisor => NULL () + end type person_record + + type(person_record), pointer :: recruit, supervisor + +! Check that references by ultimate component work + + allocate (supervisor) + supervisor%name = "Joe Honcho" + supervisor%ss = 123455 + supervisor%attainment = 100 + supervisor%institution = "Celestial University" + supervisor%personnel_number = 1 + supervisor%department = "Directorate" + + recruit => entry ("John Smith", 123456, 1, "Bog Hill High School", & + 99, "Records", supervisor) + + if (trim (recruit%name) /= "John Smith") STOP 1 + if (recruit%name /= recruit%service%name) STOP 2 + if (recruit%supervisor%ss /= 123455) STOP 3 + if (recruit%supervisor%ss /= supervisor%person%ss) STOP 4 + + deallocate (supervisor) + deallocate (recruit) +contains + function entry (name, ss, attainment, institution, & + personnel_number, department, supervisor) result (new_person) + integer :: ss, attainment, personnel_number + character (*) :: name, institution, department + type (person_record), pointer :: supervisor, new_person + + allocate (new_person) + +! Check mixtures of references + new_person%person%name = name + new_person%service%education%person%ss = ss + new_person%service%attainment = attainment + new_person%education%institution = institution + new_person%personnel_number = personnel_number + new_person%service%department = department + new_person%supervisor => supervisor + end function +end diff --git a/Fortran/gfortran/regression/extends_10.f03 b/Fortran/gfortran/regression/extends_10.f03 --- /dev/null +++ b/Fortran/gfortran/regression/extends_10.f03 @@ -0,0 +1,32 @@ +! { dg-do compile } +! +! PR 42545: type extension: parent component has wrong accessibility +! +! Reported by Reinhold Bader + +module mo + implicit none + type :: t1 + integer :: i = 1 + end type + type, extends(t1) :: t2 + private + real :: x = 2.0 + end type + type :: u1 + integer :: j = 1 + end type + type, extends(u1) :: u2 + real :: y = 2.0 + end type + private :: u1 +end module + +program pr + use mo + implicit none + type(t2) :: a + type(u2) :: b + print *,a%t1%i + print *,b%u1%j ! { dg-error "is a PRIVATE component of" } +end program diff --git a/Fortran/gfortran/regression/extends_11.f03 b/Fortran/gfortran/regression/extends_11.f03 --- /dev/null +++ b/Fortran/gfortran/regression/extends_11.f03 @@ -0,0 +1,40 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/45586 +! Test that access to inherited components are properly generated +! +! Stripped down from extends_1.f03 +! + type :: person + integer :: ss = 1 + end type person + + type, extends(person) :: education + integer :: attainment = 0 + end type education + + type, extends(education) :: service + integer :: personnel_number = 0 + end type service + + type, extends(service) :: person_record + type (person_record), pointer :: supervisor => NULL () + end type person_record + + type(person_record) :: recruit + + + ! Check that references by ultimate component and by parent type work + ! All the following component access are equivalent + recruit%ss = 2 + recruit%person%ss = 3 + recruit%education%ss = 4 + recruit%education%person%ss = 5 + recruit%service%ss = 6 + recruit%service%person%ss = 7 + recruit%service%education%ss = 8 + recruit%service%education%person%ss = 9 +end + +! { dg-final { scan-tree-dump-times " +recruit\\.service\\.education\\.person\\.ss =" 8 "original" } } diff --git a/Fortran/gfortran/regression/extends_12.f03 b/Fortran/gfortran/regression/extends_12.f03 --- /dev/null +++ b/Fortran/gfortran/regression/extends_12.f03 @@ -0,0 +1,22 @@ +! { dg-do compile } +! +! PR 48706: Type extension inside subroutine +! +! Contributed by Tobias Burnus + +module mod_diff_01 + implicit none + type :: foo + end type +contains + subroutine create_ext + type, extends(foo) :: foo_e + end type + end subroutine +end module + +program diff_01 + use mod_diff_01 + implicit none + call create_ext() +end program diff --git a/Fortran/gfortran/regression/extends_13.f03 b/Fortran/gfortran/regression/extends_13.f03 --- /dev/null +++ b/Fortran/gfortran/regression/extends_13.f03 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR 47601: [OOP] Internal Error: mio_component_ref(): Component not found +! +! Contributed by Rich Townsend + +module type_definitions + implicit none + type :: matching + integer :: n = -999 + end type + type, extends(matching) :: ellipse + end type +end module type_definitions + +module elliptical_elements + implicit none +contains + function line(e) result(a2n) + use type_definitions + type(ellipse), intent(in) :: e + complex, dimension(e%N) :: a2n ! <- change "e%N" to "10" + end function line +end module + + use type_definitions + use elliptical_elements +end diff --git a/Fortran/gfortran/regression/extends_14.f03 b/Fortran/gfortran/regression/extends_14.f03 --- /dev/null +++ b/Fortran/gfortran/regression/extends_14.f03 @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR 49466: [4.6/4.7 Regression] Memory leak with assignment of extended derived types +! +! Contributed by Rich Townsend + +program evolve_aflow + + implicit none + + type :: state_t + real, allocatable :: U(:) + end type + + type, extends(state_t) :: astate_t + end type + + block ! New scoping unit as "a"/"b" are otherwise implicitly SAVEd + type(astate_t) :: a,b + + allocate(a%U(1000)) + + a = b + end block +end program + +! { dg-final { scan-tree-dump-times "__builtin_free" 3 "original" } } diff --git a/Fortran/gfortran/regression/extends_15.f90 b/Fortran/gfortran/regression/extends_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/extends_15.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! PR 58355: [4.7/4.8/4.9 Regression] [F03] ICE with TYPE, EXTENDS before parent TYPE defined +! +! Contributed by Andrew Benson + +module ct + public :: t1 + + type, extends(t1) :: t2 ! { dg-error "has not been previously defined" } + + type :: t1 + end type +end diff --git a/Fortran/gfortran/regression/extends_16.f90 b/Fortran/gfortran/regression/extends_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/extends_16.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! +! PR 57562: [OOP] ICE due to extended derived type with PARAMETER attribute +! +! Contributed by + + type :: Parent + integer :: member1 = 0 + end type + + type, extends(Parent) :: Child + integer :: member2 = 0 + end type + + type, extends(Child) :: Grandchild + integer :: member3 = 0 + end type + + type(Grandchild), parameter :: object = Grandchild(23, 42, -99) + + if (object%member1 /= 23) STOP 1 + if (object%member2 /= 42) STOP 1 + if (object%member3 /= -99) STOP 1 + +end diff --git a/Fortran/gfortran/regression/extends_2.f03 b/Fortran/gfortran/regression/extends_2.f03 --- /dev/null +++ b/Fortran/gfortran/regression/extends_2.f03 @@ -0,0 +1,64 @@ +! { dg-do run } +! A test of f95 style constructors with derived type extension. +! +! Contributed by Paul Thomas +! +module persons + type :: person + character(24) :: name = "" + integer :: ss = 1 + end type person +end module persons + +module person_education + use persons + type, extends(person) :: education + integer :: attainment = 0 + character(24) :: institution = "" + end type education +end module person_education + + use person_education + type, extends(education) :: service + integer :: personnel_number = 0 + character(24) :: department = "" + end type service + + type, extends(service) :: person_record + type (person_record), pointer :: supervisor => NULL () + end type person_record + + type(person_record), pointer :: recruit, supervisor + +! Check that simple constructor works + allocate (supervisor) + supervisor%service = service ("Joe Honcho", 123455, 100, & + "Celestial University", 1, & + "Directorate") + + recruit => entry ("John Smith", 123456, 1, "Bog Hill High School", & + 99, "Records", supervisor) + + if (trim (recruit%name) /= "John Smith") STOP 1 + if (recruit%name /= recruit%service%name) STOP 2 + if (recruit%supervisor%ss /= 123455) STOP 3 + if (recruit%supervisor%ss /= supervisor%person%ss) STOP 4 + + deallocate (supervisor) + deallocate (recruit) +contains + function entry (name, ss, attainment, institution, & + personnel_number, department, supervisor) result (new_person) + integer :: ss, attainment, personnel_number + character (*) :: name, institution, department + type (person_record), pointer :: supervisor, new_person + + allocate (new_person) + +! Check nested constructors + new_person = person_record (education (person (name, ss), & + attainment, institution), & + personnel_number, department, & + supervisor) + end function +end diff --git a/Fortran/gfortran/regression/extends_3.f03 b/Fortran/gfortran/regression/extends_3.f03 --- /dev/null +++ b/Fortran/gfortran/regression/extends_3.f03 @@ -0,0 +1,69 @@ +! { dg-do run } +! A test of f2k style constructors with derived type extension. +! +! Contributed by Paul Thomas +! +module persons + type :: person + character(24) :: name = "" + integer :: ss = 1 + end type person +end module persons + +module person_education + use persons + type, extends(person) :: education + integer :: attainment = 0 + character(24) :: institution = "" + end type education +end module person_education + + use person_education + type, extends(education) :: service + integer :: personnel_number = 0 + character(24) :: department = "" + end type service + + type, extends(service) :: person_record + type (person_record), pointer :: supervisor => NULL () + end type person_record + + type(person_record), pointer :: recruit, supervisor + +! Check that F2K constructor with missing entries works + allocate (supervisor) + supervisor%service = service (NAME = "Joe Honcho", SS= 123455) + + recruit => entry ("John Smith", 123456, 1, "Bog Hill High School", & + 99, "Records", supervisor) + + if (supervisor%ss /= 123455) STOP 1 + if (trim (supervisor%name) /= "Joe Honcho") STOP 2 + if (trim (supervisor%institution) /= "") STOP 3 + if (supervisor%attainment /= 0) STOP 4 + + if (trim (recruit%name) /= "John Smith") STOP 5 + if (recruit%name /= recruit%service%name) STOP 6 + if (recruit%supervisor%ss /= 123455) STOP 7 + if (recruit%supervisor%ss /= supervisor%person%ss) STOP 8 + + deallocate (supervisor) + deallocate (recruit) +contains + function entry (name, ss, attainment, institution, & + personnel_number, department, supervisor) result (new_person) + integer :: ss, attainment, personnel_number + character (*) :: name, institution, department + type (person_record), pointer :: supervisor, new_person + + allocate (new_person) + +! Check F2K constructor with order shuffled a bit + new_person = person_record (NAME = name, SS =ss, & + DEPARTMENT = department, & + INSTITUTION = institution, & + PERSONNEL_NUMBER = personnel_number, & + ATTAINMENT = attainment, & + SUPERVISOR = supervisor) + end function +end diff --git a/Fortran/gfortran/regression/extends_4.f03 b/Fortran/gfortran/regression/extends_4.f03 --- /dev/null +++ b/Fortran/gfortran/regression/extends_4.f03 @@ -0,0 +1,50 @@ +! { dg-do run } +! Check that derived type extension is compatible with renaming +! the parent type and that allocatable components are OK. At +! the same time, private type and components are checked. +! +! Contributed by Paul Thomas +! +module mymod + type :: a + real, allocatable :: x(:) + integer, private :: ia = 0 + end type a + type :: b + private + real, allocatable :: x(:) + integer :: i + end type b +contains + function set_b () result (res) + type(b) :: res + allocate (res%x(2)) + res%x = [10.0, 20.0] + res%i = 1 + end function + subroutine check_b (arg) + type(b) :: arg + if (any (arg%x /= [10.0, 20.0])) STOP 1 + if (arg%i /= 1) STOP 2 + end subroutine +end module mymod + + use mymod, e => a + type, extends(e) :: f + integer :: if + end type f + type, extends(b) :: d + integer :: id + end type d + + type(f) :: p + type(d) :: q + + p = f (x = [1.0, 2.0], if = 3) + if (any (p%e%x /= [1.0, 2.0])) STOP 3 + + q%b = set_b () + call check_b (q%b) + q = d (b = set_b (), id = 99) + call check_b (q%b) +end diff --git a/Fortran/gfortran/regression/extends_5.f03 b/Fortran/gfortran/regression/extends_5.f03 --- /dev/null +++ b/Fortran/gfortran/regression/extends_5.f03 @@ -0,0 +1,25 @@ +! { dg-do compile } +! Some errors for derived type extension. +! +! Contributed by Paul Thomas +! +module m + use iso_c_binding + type :: date + sequence + integer :: yr, mon + integer,public :: day + end type + type, bind(c) :: dt + integer(c_int) :: yr, mon + integer(c_int) :: day + end type +end module m + + use m + type, extends(date) :: datetime ! { dg-error "because it is a SEQUENCE type" } + end type ! { dg-error "Expecting END PROGRAM" } + + type, extends(dt) :: dt_type ! { dg-error "because it is BIND" } + end type ! { dg-error "Expecting END PROGRAM" } +end diff --git a/Fortran/gfortran/regression/extends_6.f03 b/Fortran/gfortran/regression/extends_6.f03 --- /dev/null +++ b/Fortran/gfortran/regression/extends_6.f03 @@ -0,0 +1,47 @@ +! { dg-do compile } +! Some errors pointed out in the development of the patch. +! +! Contributed by Tobias Burnus +! +module m + type :: date + private + integer :: yr, mon + integer,public :: day + end type + type :: dt + integer :: yr, mon + integer :: day + end type +end module m + + use m + type, extends(date) :: datetime + integer :: hr, min, sec + end type + type(datetime) :: o_dt + + type :: one + integer :: i + end type one + + type, extends(one) :: two + real :: r + end type two + + o_dt%day = 5 ! VALID but failed in first version of EXTENDS patch + o_dt%yr = 5 ! { dg-error "is a PRIVATE component of" } + + t = two(one = one(4), i = 5, r=4.4) ! { dg-error "has already been set" } + + call foo +contains + subroutine foo + use m, date_type => dt + type, extends(date_type) :: dt_type + end type + type (dt_type) :: foo_dt + foo_dt%date_type%day = 1 + foo_dt%dt%day = 1 ! { dg-error "not a member" } + end subroutine +end diff --git a/Fortran/gfortran/regression/extends_7.f03 b/Fortran/gfortran/regression/extends_7.f03 --- /dev/null +++ b/Fortran/gfortran/regression/extends_7.f03 @@ -0,0 +1,23 @@ +! { dg-do compile } +! Check for re-definition of inherited components in the sub-type. + +MODULE m1 + IMPLICIT NONE + + TYPE supert + INTEGER :: c1 + INTEGER, PRIVATE :: c2 + END TYPE supert + +END MODULE m1 + +MODULE m2 + USE m1 ! { dg-error "already in the parent type" } + IMPLICIT NONE + + TYPE, EXTENDS(supert) :: subt + INTEGER :: c1 ! { dg-error "already in the parent type" } + INTEGER :: c2 ! { dg-error "already in the parent type" } + END TYPE subt + +END MODULE m2 diff --git a/Fortran/gfortran/regression/extends_8.f03 b/Fortran/gfortran/regression/extends_8.f03 --- /dev/null +++ b/Fortran/gfortran/regression/extends_8.f03 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR 41784: [OOP] ICE in load_derived_extensions +! +! Contributed by Salvatore Filippone + +module m + type :: A + end type + type, extends(A) :: B + end type +end module + +use m, only: A +end + diff --git a/Fortran/gfortran/regression/extends_9.f03 b/Fortran/gfortran/regression/extends_9.f03 --- /dev/null +++ b/Fortran/gfortran/regression/extends_9.f03 @@ -0,0 +1,35 @@ +! { dg-do compile } +! +! PR42257: [OOP] Compiler segmentation fault due missing public statement +! +! Contributed by Oystein Olsen + +MODULE run_example_fortran03 + IMPLICIT NONE + PRIVATE + PUBLIC :: epoch + + INTEGER, PARAMETER :: I4B = SELECTED_INT_KIND(9) + INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(15,307) + + TYPE epoch + INTEGER(I4B) :: i = 2451545 + REAL(DP) :: f = 0.5_DP + END TYPE + + TYPE, EXTENDS(epoch) :: time + REAL(DP) :: t = 0.0_DP + END TYPE +END MODULE + + + USE run_example_fortran03 + IMPLICIT NONE + + CLASS(epoch), ALLOCATABLE :: e4 + + ALLOCATE(epoch::e4) + WRITE(*,*) e4%i, e4%f + +END + diff --git a/Fortran/gfortran/regression/extends_type_of_1.f03 b/Fortran/gfortran/regression/extends_type_of_1.f03 --- /dev/null +++ b/Fortran/gfortran/regression/extends_type_of_1.f03 @@ -0,0 +1,48 @@ +! { dg-do run } +! +! Verifying the runtime behavior of the intrinsic function EXTENDS_TYPE_OF. +! +! Contributed by Janus Weil + + implicit none + + intrinsic :: extends_type_of + + type :: t1 + integer :: i = 42 + end type + + type, extends(t1) :: t2 + integer :: j = 43 + end type + + type, extends(t2) :: t3 + class(t1),pointer :: cc + end type + + class(t1), pointer :: c1,c2 + type(t1), target :: x + type(t2), target :: y + type(t3), target :: z + + c1 => x + c2 => y + z%cc => y + + if (.not. extends_type_of (c1, c1)) STOP 1 + if ( extends_type_of (c1, c2)) STOP 2 + if (.not. extends_type_of (c2, c1)) STOP 3 + + if (.not. extends_type_of (x, x)) STOP 4 + if ( extends_type_of (x, y)) STOP 5 + if (.not. extends_type_of (y, x)) STOP 6 + + if (.not. extends_type_of (c1, x)) STOP 7 + if ( extends_type_of (c1, y)) STOP 8 + if (.not. extends_type_of (x, c1)) STOP 9 + if (.not. extends_type_of (y, c1)) STOP 10 + + if (.not. extends_type_of (z, c1)) STOP 11 + if ( extends_type_of (z%cc, z)) STOP 12 + +end diff --git a/Fortran/gfortran/regression/extends_type_of_2.f03 b/Fortran/gfortran/regression/extends_type_of_2.f03 --- /dev/null +++ b/Fortran/gfortran/regression/extends_type_of_2.f03 @@ -0,0 +1,36 @@ +! { dg-do run } +! +! PR 47180: [OOP] EXTENDS_TYPE_OF returns the wrong result for disassociated polymorphic pointers +! +! Contributed by Tobias Burnus + +implicit none + +type t1 + integer :: a +end type t1 + +type, extends(t1):: t11 + integer :: b +end type t11 + +type(t1) , target :: a1 +type(t11) , target :: a11 +class(t1) , pointer :: b1 +class(t11), pointer :: b11 + +b1 => NULL() +b11 => NULL() + +if (.not. extends_type_of(b1 , a1)) STOP 1 +if (.not. extends_type_of(b11, a1)) STOP 2 +if (.not. extends_type_of(b11,a11)) STOP 3 + +b1 => a1 +b11 => a11 + +if (.not. extends_type_of(b1 , a1)) STOP 4 +if (.not. extends_type_of(b11, a1)) STOP 5 +if (.not. extends_type_of(b11,a11)) STOP 6 + +end diff --git a/Fortran/gfortran/regression/extends_type_of_3.f90 b/Fortran/gfortran/regression/extends_type_of_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/extends_type_of_3.f90 @@ -0,0 +1,125 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/41580 +! +! Compile-time simplification of SAME_TYPE_AS and EXTENDS_TYPE_OF. + +implicit none +type t1 + integer :: a +end type t1 +type, extends(t1):: t11 + integer :: b +end type t11 +type, extends(t11):: t111 + integer :: c +end type t111 +type t2 + integer :: a +end type t2 + +type(t1) a1 +type(t11) a11 +type(t2) a2 +class(t1), allocatable :: b1 +class(t11), allocatable :: b11 +class(t2), allocatable :: b2 + +logical, parameter :: p1 = same_type_as(a1,a2) ! F +logical, parameter :: p2 = same_type_as(a2,a1) ! F +logical, parameter :: p3 = same_type_as(a1,a11) ! F +logical, parameter :: p4 = same_type_as(a11,a1) ! F +logical, parameter :: p5 = same_type_as(a11,a11)! T +logical, parameter :: p6 = same_type_as(a1,a1) ! T + +if (p1 .or. p2 .or. p3 .or. p4 .or. .not. p5 .or. .not. p6) call should_not_exist() + +if (same_type_as(b1,b1) .neqv. .true.) call should_not_exist() + +! Not (trivially) compile-time simplifiable: +if (same_type_as(b1,a1) .neqv. .true.) STOP 1 +if (same_type_as(b1,a11) .neqv. .false.) STOP 2 +allocate(t1 :: b1) +if (same_type_as(b1,a1) .neqv. .true.) STOP 3 +if (same_type_as(b1,a11) .neqv. .false.) STOP 4 +deallocate(b1) +allocate(t11 :: b1) +if (same_type_as(b1,a1) .neqv. .false.) STOP 5 +if (same_type_as(b1,a11) .neqv. .true.) STOP 6 +deallocate(b1) + + +! .true. -> same type +if (extends_type_of(a1,a1) .neqv. .true.) call should_not_exist() +if (extends_type_of(a11,a11) .neqv. .true.) call should_not_exist() +if (extends_type_of(a2,a2) .neqv. .true.) call should_not_exist() + +! .false. -> type compatibility possible +if (extends_type_of(a1,a2) .neqv. .false.) call should_not_exist() +if (extends_type_of(a2,a1) .neqv. .false.) call should_not_exist() +if (extends_type_of(a11,a2) .neqv. .false.) call should_not_exist() +if (extends_type_of(a2,a11) .neqv. .false.) call should_not_exist() + +if (extends_type_of(b1,b2) .neqv. .false.) call should_not_exist() +if (extends_type_of(b2,b1) .neqv. .false.) call should_not_exist() +if (extends_type_of(b11,b2) .neqv. .false.) call should_not_exist() +if (extends_type_of(b2,b11) .neqv. .false.) call should_not_exist() + +if (extends_type_of(b1,a2) .neqv. .false.) call should_not_exist() +if (extends_type_of(b2,a1) .neqv. .false.) call should_not_exist() +if (extends_type_of(b11,a2) .neqv. .false.) call should_not_exist() +if (extends_type_of(b2,a11) .neqv. .false.) call should_not_exist() + +if (extends_type_of(a1,b2) .neqv. .false.) call should_not_exist() +if (extends_type_of(a2,b1) .neqv. .false.) call should_not_exist() +if (extends_type_of(a11,b2) .neqv. .false.) call should_not_exist() +if (extends_type_of(a2,b11) .neqv. .false.) call should_not_exist() + +! type extension possible, compile-time checkable +if (extends_type_of(a1,a11) .neqv. .false.) call should_not_exist() +if (extends_type_of(a11,a1) .neqv. .true.) call should_not_exist() + +if (extends_type_of(b1,a1) .neqv. .true.) call should_not_exist() +if (extends_type_of(b11,a1) .neqv. .true.) call should_not_exist() +if (extends_type_of(b11,a11) .neqv. .true.) call should_not_exist() + +if (extends_type_of(a1,b11) .neqv. .false.) call should_not_exist() + + +! Special case, simplified at tree folding: +if (extends_type_of(b1,b1) .neqv. .true.) STOP 7 + +! All other possibilities are not compile-time checkable +if (extends_type_of(b11,b1) .neqv. .true.) STOP 8 +if (extends_type_of(b1,b11) .neqv. .false.) STOP 9 +if (extends_type_of(a11,b11) .neqv. .true.) STOP 10 + +allocate(t11 :: b11) +if (extends_type_of(a11,b11) .neqv. .true.) STOP 11 +deallocate(b11) + +allocate(t111 :: b11) +if (extends_type_of(a11,b11) .neqv. .false.) STOP 12 +deallocate(b11) + +allocate(t11 :: b1) +if (extends_type_of(a11,b1) .neqv. .true.) STOP 13 +deallocate(b1) + +allocate(t11::b1) +if (extends_type_of(b1,a11) .neqv. .true.) STOP 14 +deallocate(b1) + +allocate(b1,source=a11) +if (extends_type_of(b1,a11) .neqv. .true.) STOP 15 +deallocate(b1) + +allocate( b1,source=a1) +if (extends_type_of(b1,a11) .neqv. .false.) STOP 16 +deallocate(b1) + +end + +! { dg-final { scan-tree-dump-times "stop_numeric" 16 "original" } } +! { dg-final { scan-tree-dump-times "should_not_exist" 0 "original" } } diff --git a/Fortran/gfortran/regression/extends_type_of_4.f90 b/Fortran/gfortran/regression/extends_type_of_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/extends_type_of_4.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! PR fortran/106121 - ICE in gfc_simplify_extends_type_of +! Contributed by G.Steinmetz + +program p + type t + end type + type(t) :: x + class(t) :: y ! { dg-error "dummy, allocatable or pointer" } + print *, extends_type_of (x, y) +end + +subroutine s + type t + integer :: i + end type + type(t) :: x + class(t) :: y ! { dg-error "dummy, allocatable or pointer" } + stop extends_type_of (x, y) ! { dg-error "STOP code" } +end diff --git a/Fortran/gfortran/regression/external_implicit_none.f90 b/Fortran/gfortran/regression/external_implicit_none.f90 --- /dev/null +++ b/Fortran/gfortran/regression/external_implicit_none.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! Tests fix for PR18737 - ICE on external symbol of unknown type. +program test + implicit none + real(8) :: x + external bug ! { dg-error "has no IMPLICIT type" } + + x = 2 + print *, bug(x) + +end program test \ No newline at end of file diff --git a/Fortran/gfortran/regression/external_implicit_none_2.f90 b/Fortran/gfortran/regression/external_implicit_none_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/external_implicit_none_2.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR fortran/93309 +! +module m + implicit none(external) +contains + subroutine s + implicit none(external) ! OK + end subroutine +end module + +module m2 + implicit none(external) +contains + subroutine s + call foo(1) ! { dg-error "not explicitly declared" } + end subroutine +end module + +module m3 + implicit none(external) +contains + subroutine s + implicit none(external) ! OK + implicit none(external) ! { dg-error "Duplicate IMPLICIT NONE statement" } + end subroutine +end module diff --git a/Fortran/gfortran/regression/external_implicit_none_3.f08 b/Fortran/gfortran/regression/external_implicit_none_3.f08 --- /dev/null +++ b/Fortran/gfortran/regression/external_implicit_none_3.f08 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-std=f2018" } +! Tests fix for PR100972 - Fails to warn about missing EXTERNAL attribute +! Contributed by Gerhard Steinmetz + +program p + implicit none (external) + real, external :: f + real :: a + real :: b + integer :: i + character :: c + a = f() ! OK + b = g() ! { dg-error "Missing explicit declaration with EXTERNAL attribute" } + i = h() ! { dg-error "Missing explicit declaration with EXTERNAL attribute" } + c = j() ! { dg-error "Missing explicit declaration with EXTERNAL attribute" } +end diff --git a/Fortran/gfortran/regression/external_initializer.f90 b/Fortran/gfortran/regression/external_initializer.f90 --- /dev/null +++ b/Fortran/gfortran/regression/external_initializer.f90 @@ -0,0 +1,5 @@ +! { dg-do compile } +! PR20849 - An external symbol may not have a initializer. +! Contributed by Joost VandeVondele +REAL, EXTERNAL :: X=0 ! { dg-error "not have an initializer" } +END diff --git a/Fortran/gfortran/regression/external_procedure_4.f90 b/Fortran/gfortran/regression/external_procedure_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/external_procedure_4.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! PR fortran/90937 - this used to cause an ICE. +! Original test case by Toon Moene. +subroutine lfidiff + + implicit none + + contains + + subroutine grlfi(cdnom) + + character(len=*) cdnom(:) + character(len=len(cdnom)) clnoma + + call lficas(clnoma) + + end subroutine grlfi + +end subroutine lfidiff diff --git a/Fortran/gfortran/regression/external_procedures_1.f90 b/Fortran/gfortran/regression/external_procedures_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/external_procedures_1.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! +! This tests the patch for PR25024. + +! PR25024 - The external attribute for subroutine a would cause an ICE. + subroutine A () + EXTERNAL A ! { dg-error "EXTERNAL attribute conflicts with SUBROUTINE" } + END + +function ext (y) ! { dg-error "EXTERNAL attribute conflicts with FUNCTION" } + real ext, y + external ext + !ext = y * y +end function ext + +function ext1 (y) + real ext1, y + external z ! OK no conflict + ext1 = y * y +end function ext1 + +program main + real ext, inval + external ext ! OK, valid external reference. + external main ! { dg-error "PROGRAM attribute conflicts with EXTERNAL" } + interface + function ext1 (y) + real ext1, y + external ext1 + end function ext1 ! { dg-error "Duplicate EXTERNAL attribute" } + end interface + inval = 1.0 + print *, ext(inval) + print *, ext1(inval) + print *, inv(inval) +contains + function inv (y) ! { dg-error "EXTERNAL attribute conflicts with FUNCTION" } + real inv, y + external inv + !inv = y * y * y + end function inv +end program main + diff --git a/Fortran/gfortran/regression/external_procedures_2.f90 b/Fortran/gfortran/regression/external_procedures_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/external_procedures_2.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! Tests the for PR30410, in which the reference to extfunc would +! be incorrectly made to the module namespace. +! +! Contributed by Harald Anlauf +! +module mod1 +contains + function eval (func, x1) + real :: eval, func, x1 + external :: func + eval = func (x1) + end function eval +end module mod1 +!------------------------------- +module mod2 + use mod1, only : eval + real, external :: extfunc ! This was referenced as __mod2__extfunc__ +contains + + subroutine foo (x0) + real :: x0, x1 + x1 = 42 + x0 = eval (extfunc, x1) + end subroutine foo + +end module mod2 +!------------------------------- +function extfunc (x) + real, intent(in) :: x + real :: extfunc + extfunc = x +end function extfunc +!------------------------------- +program gfcbug53 + use mod2, only : foo + real :: x0 = 0 + call foo (x0) + print *, x0 +end program gfcbug53 diff --git a/Fortran/gfortran/regression/external_procedures_3.f90 b/Fortran/gfortran/regression/external_procedures_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/external_procedures_3.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! Tests the fix for PR32926, in which the call to fcn +! in bar would cause an ICE because it had not been referenced +! in the namespace where it was declared. +! +! Contributed by Ralph Baker Kearfott +! +subroutine foobar1 + common // chr + character(8) :: chr + chr = "foobar1" +end subroutine +subroutine foobar2 + common // chr + character(8) :: chr + chr = "foobar2" +end subroutine + +subroutine foo (fcn) + external fcn + call bar +contains + subroutine bar + call fcn + end subroutine bar +end subroutine foo + + external foo, foobar1, foobar2 + common // chr + character(8) :: chr + call foo (foobar1) + if (chr .ne. "foobar1") STOP 1 + call foo (foobar2) + if (chr .ne. "foobar2") STOP 2 +end diff --git a/Fortran/gfortran/regression/extract_recip_1.f b/Fortran/gfortran/regression/extract_recip_1.f --- /dev/null +++ b/Fortran/gfortran/regression/extract_recip_1.f @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-Ofast -fno-tree-vectorize -fdump-tree-optimized-raw" } + + SUBROUTINE F(N,X,Y,Z,A,B) + DIMENSION X(4,4), Y(4), Z(4) + REAL, INTENT(INOUT) :: A, B + + A = 1 / (Y(N)*Y(N)) + + DO I = 1, NV + X(I, I) = 1 + X(I, I) + ENDDO + + Z(1) = B / Y(N) + Z(2) = N / Y(N) + RETURN + END + +! { dg-final { scan-tree-dump-times "rdiv_expr" 1 "optimized" } } diff --git a/Fortran/gfortran/regression/f2003_inquire_1.f03 b/Fortran/gfortran/regression/f2003_inquire_1.f03 --- /dev/null +++ b/Fortran/gfortran/regression/f2003_inquire_1.f03 @@ -0,0 +1,23 @@ +! { dg-do run } +! { dg-options "-std=gnu" } +character(25) :: sround, ssign, sasynchronous, sdecimal, sencoding +integer :: vsize, vid +logical :: vpending + +open(10, file='mydata_f2003_inquire_1', asynchronous="yes", blank="null", & +& decimal="comma", encoding="utf-8", sign="plus") + +write (10,*, asynchronous="yes", id=vid) 'asdf' +wait (10) + +inquire(unit=10, round=sround, sign=ssign, size=vsize, id=vid, & +& pending=vpending, asynchronous=sasynchronous, decimal=sdecimal, & +& encoding=sencoding) +if (ssign.ne."PLUS") STOP 1 +if (sasynchronous.ne."YES") STOP 2 +if (sdecimal.ne."COMMA") STOP 3 +if (sencoding.ne."UTF-8") STOP 4 +if (vpending) STOP 5 + +close(10, status="delete") +end diff --git a/Fortran/gfortran/regression/f2003_io_1.f03 b/Fortran/gfortran/regression/f2003_io_1.f03 --- /dev/null +++ b/Fortran/gfortran/regression/f2003_io_1.f03 @@ -0,0 +1,39 @@ +! { dg-do run { target fd_truncate } } +! { dg-options "-std=gnu" } +! Test case prepared by Jerry DeLisle +real :: a(4), b(4) +real :: c +integer :: istat, j +character(25) :: msg + +a = 23.45 +b = 0.0 +open(10, file='mydata_f2003_io_1', asynchronous="yes", blank="null") + +write(10,'(10f8.3)', asynchronous="yes", decimal="comma", id=j) a +rewind(10) +read(10,'(10f8.3)', asynchronous="yes", decimal="comma", blank="zero") b +wait(10) +if (any(b.ne.23.45)) STOP 1 + +c = 3.14 +write(msg, *, decimal="comma") c +if (msg(1:7).ne." 3,14") STOP 2 + +b = 0.0 +rewind(10) +write(10,'(10f8.3)', asynchronous="yes", decimal="point") a +rewind(10) +read(10,'(10f8.3)', asynchronous="yes", decimal="point") b +wait (10) +if (any(b.ne.23.45)) STOP 3 + +wait(unit=10, err=25, iostat=istat, iomsg=msg, end=35, id=j) + +! do some stuff with a +25 continue + +35 continue + +close(10, status="delete") +end diff --git a/Fortran/gfortran/regression/f2003_io_2.f03 b/Fortran/gfortran/regression/f2003_io_2.f03 --- /dev/null +++ b/Fortran/gfortran/regression/f2003_io_2.f03 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! Test case prepared by Jerry DeLisle + +integer :: istat, idvar +character(25) :: msg +real, dimension(10) :: a, b + +a = 43.21 +open(10, file='mydata_f2003_io_2', asynchronous="yes") +write(10,'(10f8.3)', asynchronous="yes", decimal="comma") a +rewind(10) +read(10,'(10f8.3)', asynchronous="yes", decimal="comma", id=idvar) b +istat = 123456 +wait(unit=10, err=25, iostat=istat, iomsg=msg, end=35, id=idvar) + +print *, istat + +25 continue + +35 continue +end diff --git a/Fortran/gfortran/regression/f2003_io_3.f03 b/Fortran/gfortran/regression/f2003_io_3.f03 --- /dev/null +++ b/Fortran/gfortran/regression/f2003_io_3.f03 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! Test case prepared by Jerry DeLisle + +integer :: istat +character(25) :: msg +real, dimension(10) :: a, b +namelist /mynml/ a, b +msg = "null" +a = 43.21 +WRITE(99,'(10f8.3)',decimal="comma") a +rewind(99) +read(99,'(dc,10f8.3)',blank=msg) b +write(99,'(dp,10f8.3)',round="up") +rewind(99) +read(99,'(10f8.3)',pad="yes") +msg="suppress" +write(99,'(10f8.3)',sign=msg) +write(99,delim="apostrophe", fmt=*) +write(99,nml=mynml,delim="none") +end diff --git a/Fortran/gfortran/regression/f2003_io_4.f03 b/Fortran/gfortran/regression/f2003_io_4.f03 --- /dev/null +++ b/Fortran/gfortran/regression/f2003_io_4.f03 @@ -0,0 +1,33 @@ +! { dg-do run } +! Test case prepared by Jerry DeLisle +! Test of decimal= feature + +integer :: istat +character(80) :: msg +real, dimension(4) :: a, b, c +namelist /mynml/ a, b +msg = "yes" +a = 43.21 +b = 3.131 +c = 5.432 +open(99, decimal="comma", status="scratch") +write(99,'(10f8.3)') a +a = 0.0 +rewind(99) +read(99,'(10f8.3)') a +if (any(a.ne.43.21)) STOP 1 + +write(msg,'(dp,f8.3,dc,f8.2,dp,f8.3)', decimal="comma") a(1), b(1), c(1) +if (trim(msg).ne." 43.210 3,13 5.432") STOP 2 + +close(99) +open(99, decimal="comma", status="scratch") +write(99,nml=mynml) +a = 0.0 +b = 0.0 +rewind(99) +read(99,nml=mynml) +if (any(a.ne.43.21)) STOP 3 +if (any(b.ne.3.131)) STOP 4 +close(99) +end diff --git a/Fortran/gfortran/regression/f2003_io_5.f03 b/Fortran/gfortran/regression/f2003_io_5.f03 --- /dev/null +++ b/Fortran/gfortran/regression/f2003_io_5.f03 @@ -0,0 +1,26 @@ +! { dg-do run } +! Test case prepared by Jerry DeLisle +! Test of decimal="comma" in namelist and complex +integer :: i +real :: a(10) = [ (i*1.3, i=1,10) ] +real :: b(10) +complex :: c +character(36) :: complex +namelist /nm/ a + +open(99,file="mynml",form="formatted",decimal="point",status="replace") +write(99,nml=nm,decimal="comma") +a = 5.55 +rewind(99) +read(99,nml=nm,decimal="comma") +if (any (a /= [ (i*1.3, i=1,10) ])) STOP 1 +close(99, status="delete") + +c = (3.123,4.456) +write(complex,*,decimal="comma") c +if (complex.ne." (3,12299991;4,45599985)") STOP 2 +c = (0.0, 0.0) +read(complex,*,decimal="comma") c +if (complex.ne." (3,12299991;4,45599985)") STOP 3 + +end diff --git a/Fortran/gfortran/regression/f2003_io_6.f03 b/Fortran/gfortran/regression/f2003_io_6.f03 --- /dev/null +++ b/Fortran/gfortran/regression/f2003_io_6.f03 @@ -0,0 +1,11 @@ +! { dg-do run } +! Test case prepared by Jerry DeLisle +! Test of decimal="comma" in namelist, checks separators +implicit none +integer :: i +real :: a(6) = 0.0 +character(len=30) :: str = '&nm a = 1,3; 4, 5; 5; 7; /' +namelist /nm/ a +read(str,nml=nm,decimal='comma') +if (any(a.ne.[ 1.3, 4.0, 5.0, 5.0, 7.0, 0.0 ])) STOP 1 +end diff --git a/Fortran/gfortran/regression/f2003_io_7.f03 b/Fortran/gfortran/regression/f2003_io_7.f03 --- /dev/null +++ b/Fortran/gfortran/regression/f2003_io_7.f03 @@ -0,0 +1,27 @@ +! { dg-do run } +! Test case prepared by Jerry DeLisle +! Test of sign=, decimal=, and blank= . +program iotests + implicit none + character(len=45) :: a + character(len=4) :: mode = "what" + real, parameter :: pi = 3.14159265358979323846 + real(kind=8), dimension(3) :: b + ! + write(a,'(f10.3,s,f10.3,sp,f10.3,ss,f10.3)',SIGN='PLUS') pi, pi, pi, pi + if (a /= " +3.142 3.142 +3.142 3.142") STOP 1 + ! + open(8,sign="plus") + write(8,'(f10.3,dc,f10.3,dp,f10.3)',DECIMAL='COMMA',& + & sign="suppress") pi, pi, pi + rewind(8) + read(8,'(a)') a + if (a /= " 3,142 3,142 3.142") STOP 2 + close(8,status="delete") + ! + ! "123456789 123456789 12345678901 + write(a,'(a)') "53 256.84, 2 2 2. ; 33.3 3 1 " + read(a, '(f9.2,1x,f8.2,2x,f11.7)', blank="zero") b(1),b(2),b(3) + if (any(abs(b - [530256.84, 20202.00, 33.3030001]) > .03)) STOP 3 +end program iotests + diff --git a/Fortran/gfortran/regression/f2003_io_8.f03 b/Fortran/gfortran/regression/f2003_io_8.f03 --- /dev/null +++ b/Fortran/gfortran/regression/f2003_io_8.f03 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-std=gnu" } +! +real :: a(4), b(4) +real :: c +integer :: istat, j +character(25) :: msg + +open(10, file='mydata_f2003_io_8', asynchronous="yes", blank="null") +write(10,'(10f8.3)', asynchronous='no', decimal="comma", id=j) a ! { dg-error "must be with ASYNCHRONOUS=" } +read(10,'(10f8.3)', id=j, decimal="comma", blank="zero") b ! { dg-error "must be with ASYNCHRONOUS=" } +read(10,'(10f8.3)', asynchronous=msg, decimal="comma", blank="zero") b ! { dg-error "does not reduce to a constant expression" } +end diff --git a/Fortran/gfortran/regression/f2018_obs.f90 b/Fortran/gfortran/regression/f2018_obs.f90 --- /dev/null +++ b/Fortran/gfortran/regression/f2018_obs.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! { dg-options "-std=f2018" } +! +! PR 85839: [F2018] warn for obsolescent features +! +! Contributed by Janus Weil + +block data ! { dg-warning "obsolescent feature" } + common /a/ y(3) ! { dg-warning "obsolescent feature" } + data y /3*1./ +end + +program f2018_obs + + implicit none + integer :: a(10),b(10),j(8),i + real :: x(3) + common /c/ x ! { dg-warning "obsolescent feature" } + + equivalence (a(10),b(1)) ! { dg-warning "obsolescent feature" } + + do 99 i=1,10 ! { dg-warning "obsolescent feature" } +99 continue + + j = (/ 0, 1, 2, 3, 4, 0, 6, 7 /) + forall (i=1:8, j(i) /= 0) ! { dg-warning "obsolescent feature" } + j(i) = 0 + end forall +end diff --git a/Fortran/gfortran/regression/f2c_1.f90 b/Fortran/gfortran/regression/f2c_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/f2c_1.f90 @@ -0,0 +1,73 @@ +! Make sure the f2c calling conventions work +! { dg-do run } +! { dg-options "-ff2c" } + +function f(x) + f = x +end function f + +complex function c(a,b) + c = cmplx (a,b) +end function c + +double complex function d(e,f) + double precision e, f + d = cmplx (e, f, kind(d)) +end function d + +subroutine test_with_interface() + interface + real function f(x) + real::x + end function f + end interface + + interface + complex function c(a,b) + real::a,b + end function c + end interface + + interface + double complex function d(e,f) + double precision::e,f + end function d + end interface + + double precision z, w + + x = 8.625 + if (x /= f(x)) STOP 1 + y = f(x) + if (x /= y) STOP 2 + + a = 1. + b = -1. + if (c(a,b) /= cmplx(a,b)) STOP 3 + + z = 1. + w = -1. + if (d(z,w) /= cmplx(z,w, kind(z))) STOP 4 +end subroutine test_with_interface + +external f, c, d +real f +complex c +double complex d +double precision z, w + +x = 8.625 +if (x /= f(x)) STOP 5 +y = f(x) +if (x /= y) STOP 6 + +a = 1. +b = -1. +if (c(a,b) /= cmplx(a,b)) STOP 7 + +z = 1. +w = -1. +if (d(z,w) /= cmplx(z,w, kind(z))) STOP 8 + +call test_with_interface () +end diff --git a/Fortran/gfortran/regression/f2c_2.f90 b/Fortran/gfortran/regression/f2c_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/f2c_2.f90 @@ -0,0 +1,23 @@ +! Some basic testing that calls to the library still work correctly with +! -ff2c +! +! Once the library has support for f2c calling conventions (i.e. passing +! a REAL(kind=4) or COMPLEX-valued intrinsic as procedure argument works), we +! can simply add -ff2c to the list of options to cycle through, and get +! complete coverage. As of 2005-03-05 this doesn't work. +! { dg-do run } +! { dg-options "-ff2c" } + +complex c +double complex d + +x = 2. +if ((sqrt(x) - 1.41)**2 > 1.e-4) STOP 1 +x = 1. +if ((atan(x) - 3.14/4) ** 2 > 1.e-4) STOP 2 +c = (-1.,0.) +if (sqrt(c) /= (0., 1.)) STOP 3 +d = c +if (sqrt(d) /= (0._8, 1._8)) STOP 4 +end + diff --git a/Fortran/gfortran/regression/f2c_3.f90 b/Fortran/gfortran/regression/f2c_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/f2c_3.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-options "-ff2c" } +! Verifies that internal functions are not broken by f2c calling conventions +program test + real, target :: f + real, pointer :: q + real :: g + f = 1.0 + q=>f + g = foo(q) + if (g .ne. 1.0) STOP 1 +contains +function foo (p) + real, pointer :: foo + real, pointer :: p + foo => p +end function +end program diff --git a/Fortran/gfortran/regression/f2c_4.c b/Fortran/gfortran/regression/f2c_4.c --- /dev/null +++ b/Fortran/gfortran/regression/f2c_4.c @@ -0,0 +1,74 @@ +/* Check -ff2c calling conventions + Return value of COMPLEX function is via an extra argument in the + calling sequence that points to where to store the return value + Additional underscore appended to function name + + Simplified from f2c output and tested with g77 */ + +/* We used to #include , but this fails for some platforms + (like cygwin) who don't have it yet. */ +#define complex __complex__ +#define _Complex_I (1.0iF) + +typedef float real; +typedef double doublereal; + +extern double f2c_4b__(double *); +extern void f2c_4d__( complex float *, complex float *); +extern void f2c_4f__( complex float *, int *,complex float *); +extern void f2c_4h__( complex double *, complex double *); +extern void f2c_4j__( complex double *, int *, complex double *); +extern void abort (void); + +void f2c_4a__(void) { + double a,b; + a = 1023.0; + b=f2c_4b__(&a); + if ( a != b ) abort(); +} + +void f2c_4c__(void) { + complex float x,ret_val; + x = 1234 + 5678 * _Complex_I; + f2c_4d__(&ret_val,&x); + if ( x != ret_val ) abort(); +} + +void f2c_4e__(void) { + complex float x,ret_val; + int i=0; + x = 1234 + 5678 * _Complex_I; + f2c_4f__(&ret_val,&i,&x); + if ( x != ret_val ) abort(); +} + +void f2c_4g__(void) { + complex double x,ret_val; + x = 1234 + 5678.0f * _Complex_I; + f2c_4h__(&ret_val,&x); + if ( x != ret_val ) abort(); +} + +void f2c_4i__(void) { + complex double x,ret_val; + int i=0; + x = 1234.0f + 5678.0f * _Complex_I; + f2c_4j__(&ret_val,&i,&x); + if ( x != ret_val ) abort(); +} + +void f2c_4k__(complex float *ret_val, complex float *x) { + *ret_val = *x; +} + +void f2c_4l__(complex float *ret_val, int *i, complex float *x) { + *ret_val = *x; +} + +void f2c_4m__(complex double *ret_val, complex double *x) { + *ret_val = *x; +} + +void f2c_4n__(complex double *ret_val, int *i, complex double *x) { + *ret_val = *x; +} diff --git a/Fortran/gfortran/regression/f2c_4.f90 b/Fortran/gfortran/regression/f2c_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/f2c_4.f90 @@ -0,0 +1,58 @@ +! { dg-do run } +! { dg-additional-sources f2c_4.c } +! { dg-options "-ff2c -w" } + +! Check -ff2c calling conventions +! Return value of REAL function is promoted to C type double +! Return value of COMPLEX function is via an extra argument in the +! calling sequence that points to where to store the return value +! Addional underscore appended to function name +program f2c_4 + complex c, f2c_4k, f2c_4l + double complex z, f2c_4m, f2c_4n + integer i + + ! Promotion of REAL function + call f2c_4a() + + ! Return COMPLEX arg - call Fortran routines from C + call f2c_4c() + call f2c_4e() + call f2c_4g() + call f2c_4i() + + ! Return COMPLEX arg - call C routines from Fortran + c = cmplx(1234.0,5678.0) + z = dcmplx(1234.0d0,5678.0d0) + if ( c .ne. f2c_4k(c) ) STOP 1 + if ( c .ne. f2c_4l(i,c) ) STOP 2 + if ( z .ne. f2c_4m(z) ) STOP 3 + if ( z .ne. f2c_4n(i,z) ) STOP 4 + +end + +real function f2c_4b(x) + double precision x + f2c_4b = x +end + +complex function f2c_4d(x) + complex x + f2c_4d = x +end + +complex function f2c_4f(i,x) + complex x + integer i + f2c_4f = x +end + +double complex function f2c_4h(x) + double complex x + f2c_4h = x +end + +double complex function f2c_4j(i,x) + double complex x + f2c_4j = x +end diff --git a/Fortran/gfortran/regression/f2c_5.c b/Fortran/gfortran/regression/f2c_5.c --- /dev/null +++ b/Fortran/gfortran/regression/f2c_5.c @@ -0,0 +1,9 @@ +extern float f2c_5b_(double *); +extern void abort (void); + +void f2c_5a_(void) { + double a,b; + a = 1023.0; + b=f2c_5b_(&a); + if ( a != b ) abort(); +} diff --git a/Fortran/gfortran/regression/f2c_5.f90 b/Fortran/gfortran/regression/f2c_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/f2c_5.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! { dg-additional-sources f2c_5.c } +! { dg-options "-fno-f2c -w" } +! Check calling conventions without -ff2c +program f2c_5 + call f2c_5a() +end + +real function f2c_5b(x) + double precision x + f2c_5b = x +end diff --git a/Fortran/gfortran/regression/f2c_6.f90 b/Fortran/gfortran/regression/f2c_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/f2c_6.f90 @@ -0,0 +1,84 @@ +! { dg-do run } +! { dg-options "-ff2c" } +! Verifies that complex pointer results work with -ff2c +! try all permutations of result clause in function yes/no +! and result clause in interface yes/no +! this is not possible in Fortran 77, but this exercises a previously +! buggy codepath +function c() result (r) + common // z + complex, pointer :: r + complex, target :: z + + r=>z +end function c + +function d() + common // z + complex, pointer :: d + complex, target :: z + + d=>z +end function d + +function e() + common // z + complex, pointer :: e + complex, target :: z + + e=>z +end function e + +function f() result(r) + common // z + complex, pointer :: r + complex, target :: z + + r=>z +end function f + +interface + function c () + complex, pointer :: c + end function c +end interface +interface + function d() + complex, pointer :: d + end function d +end interface +interface + function e () result(r) + complex, pointer :: r + end function e +end interface +interface + function f () result(r) + complex, pointer :: r + end function f +end interface + +common // z +complex, target :: z +complex, pointer :: p + +z = (1.,0.) +p => c() +z = (2.,0.) +if (p /= z) STOP 1 + +NULLIFY(p) +p => d() +z = (3.,0.) +if (p /= z) STOP 2 + +NULLIFY(p) +p => e() +z = (4.,0.) +if (p /= z) STOP 3 + +NULLIFY(p) +p => f() +z = (5.,0.) +if (p /= z) STOP 4 +end diff --git a/Fortran/gfortran/regression/f2c_7.f90 b/Fortran/gfortran/regression/f2c_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/f2c_7.f90 @@ -0,0 +1,57 @@ +! { dg-do run } +! { dg-options "-ff2c" } +! Verifies that array results work with -ff2c +! try all permutations of result clause in function yes/no +! and result clause in interface yes/no +! this is not possible in Fortran 77, but this exercises a previously +! buggy codepath +function c() result (r) + complex :: r(5) + r = 0. +end function c + +function d() + complex :: d(5) + d = 1. +end function d + +subroutine test_without_result +interface + function c () + complex :: c(5) + end function c +end interface +interface + function d () + complex :: d(5) + end function d +end interface +complex z(5) +z = c() +if (any(z /= 0.)) STOP 1 +z = d() +if (any(z /= 1.)) STOP 2 +end subroutine test_without_result + +subroutine test_with_result +interface + function c () result(r) + complex :: r(5) + end function c +end interface +interface + function d () result(r) + complex :: r(5) + end function d +end interface +complex z(5) +z = c() +if (any(z /= 0.)) STOP 3 +z = d() +if (any(z /= 1.)) STOP 4 +end subroutine test_with_result + +call test_without_result +call test_with_result +end + diff --git a/Fortran/gfortran/regression/f2c_8.f90 b/Fortran/gfortran/regression/f2c_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/f2c_8.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-options "-ff2c" } +! PR 25392 +! Verify that the type of the result variable matches the declared +! type of the function. The actual type of the function may be +! different for f2c calling conventions. +real function goo () result (foo) + real x + foo = sign(foo, x) +end + +real function foo () + real x + foo = sign(foo, x) +end + diff --git a/Fortran/gfortran/regression/f2c_9.f90 b/Fortran/gfortran/regression/f2c_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/f2c_9.f90 @@ -0,0 +1,52 @@ +! { dg-do run } +! { dg-options "-ff2c" } +! PR 34868 + +function f(a) result(res) + implicit none + real(8), intent(in) :: a(:) + complex(8) :: res + + res = cmplx(sum(a),product(a),8) +end function f + +function g(a) + implicit none + real(8), intent(in) :: a(:) + complex(8) :: g + + g = cmplx(sum(a),product(a),8) +end function g + +program test + real(8) :: a(1,5) + complex(8) :: c + integer :: i + + interface + complex(8) function f(a) + real(8), intent(in) :: a(:) + end function f + function g(a) result(res) + real(8), intent(in) :: a(:) + complex(8) :: res + end function g + end interface + + do i = 1, 5 + a(1,i) = sqrt(real(i,kind(a))) + end do + + c = f(a(1,:)) + call check (real(c), sum(a)) + call check (imag(c), product(a)) + + c = g(a(1,:)) + call check (real(c), sum(a)) + call check (imag(c), product(a)) +contains + subroutine check (a, b) + real(8), intent(in) :: a, b + if (abs(a - b) > 1.e-10_8) STOP 1 + end subroutine check +end program test diff --git a/Fortran/gfortran/regression/feed_1.f90 b/Fortran/gfortran/regression/feed_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/feed_1.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-options "-ffree-form" } +! Test acceptance of form feed character in free source. + +implicit none +integer, volatile :: x + + + +x = 5 + +end diff --git a/Fortran/gfortran/regression/feed_2.f90 b/Fortran/gfortran/regression/feed_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/feed_2.f90 @@ -0,0 +1,12 @@ + ! { dg-do compile } + ! { dg-options "-ffixed-form" } + ! Test acceptance of form feed character in fixed source. + + implicit none + integer, volatile :: x + + + + x = 5 + + end diff --git a/Fortran/gfortran/regression/fgetc_1.f90 b/Fortran/gfortran/regression/fgetc_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fgetc_1.f90 @@ -0,0 +1,39 @@ +! Testcase for the FGETC and FPUTC intrinsics +! { dg-do run } + character(len=5) s + integer st + + s = "12345" + open(10,status="scratch") + write(10,"(A)") "abcde" + rewind(10) + call fgetc(10,s,st) + if ((st /= 0) .or. (s /= "a ")) STOP 1 + call fgetc(10,s,st) + close(10) + + open(10,status="scratch") + s = "12345" + call fputc(10,s,st) + if (st /= 0) STOP 2 + call fputc(10,"2",st) + if (st /= 0) STOP 3 + call fputc(10,"3 ",st) + if (st /= 0) STOP 4 + rewind(10) + call fgetc(10,s) + if (s(1:1) /= "1") STOP 5 + call fgetc(10,s) + if (s(1:1) /= "2") STOP 6 + call fgetc(10,s,st) + if ((s(1:1) /= "3") .or. (st /= 0)) STOP 7 + call fgetc(10,s,st) + if (st /= -1) STOP 8 + close (10) + +! FGETC and FPUTC on units not opened should not work + call fgetc(12,s,st) + if (st /= -1) STOP 9 + call fputc(12,s,st) + if (st /= -1) STOP 10 + end diff --git a/Fortran/gfortran/regression/fgetc_2.f90 b/Fortran/gfortran/regression/fgetc_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fgetc_2.f90 @@ -0,0 +1,39 @@ +! Testcase for the FGETC and FPUTC intrinsics +! { dg-do run } + character(len=5) s + integer st + + s = "12345" + open(10,status="scratch") + write(10,"(A)") "abcde" + rewind(10) + st = fgetc(10,s) + if ((st /= 0) .or. (s /= "a ")) STOP 1 + st = fgetc(10,s) + close(10) + + open(10,status="scratch") + s = "12345" + st = fputc(10,s) + if (st /= 0) STOP 2 + st = fputc(10,"2") + if (st /= 0) STOP 3 + st = fputc(10,"3 ") + if (st /= 0) STOP 4 + rewind(10) + st = fgetc(10,s) + if (s(1:1) /= "1") STOP 5 + st = fgetc(10,s) + if (s(1:1) /= "2") STOP 6 + st = fgetc(10,s) + if ((s(1:1) /= "3") .or. (st /= 0)) STOP 7 + st = fgetc(10,s) + if (st /= -1) STOP 8 + close (10) + +! FGETC and FPUTC on units not opened should not work + st = fgetc(12,s) + if (st /= -1) STOP 9 + st = fputc(12,s) + if (st /= -1) STOP 10 + end diff --git a/Fortran/gfortran/regression/filename_null.f90 b/Fortran/gfortran/regression/filename_null.f90 --- /dev/null +++ b/Fortran/gfortran/regression/filename_null.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! PR 62768 +! Filenames with embedded NULL characters are truncated, make sure +! inquire reports the correct truncated name. +program filename_null + implicit none + character(len=15), parameter :: s = "hello" // achar(0) // "world", & + s2 = "hello" + character(len=15) :: r + logical :: l + open(10, file=s) + inquire(unit=10, name=r) + if (r /= s2) STOP 1 + inquire(file=s2, exist=l) + if (.not. l) STOP 2 + close(10, status="delete") +end program filename_null diff --git a/Fortran/gfortran/regression/filepos1.f90 b/Fortran/gfortran/regression/filepos1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/filepos1.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! PR fortran/66039 +! +! Original code from Gerhard Steinmetz +! +subroutine p1 + rewind (( ! { dg-error "Syntax error in REWIND" } + rewind (- ! { dg-error "Syntax error in REWIND" } +end subroutine p1 + +subroutine p2 + flush (( ! { dg-error "Syntax error in FLUSH" } + flush (- ! { dg-error "Syntax error in FLUSH" } +end subroutine p2 + +subroutine p4 + backspace (( ! { dg-error "Syntax error in BACKSPACE" } + backspace (- ! { dg-error "Syntax error in BACKSPACE" } +end subroutine p4 + +subroutine p3 + endfile (( ! { dg-error "Expecting END SUBROUTINE" } + endfile (- ! { dg-error "Expecting END SUBROUTINE" } +end subroutine p3 + diff --git a/Fortran/gfortran/regression/fimplicit_none_1.f90 b/Fortran/gfortran/regression/fimplicit_none_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fimplicit_none_1.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! { dg-options "-fimplicit-none" } +subroutine s(n) ! { dg-error "has no IMPLICIT type" } + character(n) :: c ! { dg-error "Scalar INTEGER expression expected" } + c = 'c' ! { dg-error "has no IMPLICIT type" } +end diff --git a/Fortran/gfortran/regression/fimplicit_none_2.f90 b/Fortran/gfortran/regression/fimplicit_none_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fimplicit_none_2.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! { dg-options "-fimplicit-none" } +! PR fortran/78239 - used to ICE +program p + character(*), parameter :: z(2) = [character(n) :: 'x', 'y'] ! { dg-error "Scalar INTEGER expression expected" } +end diff --git a/Fortran/gfortran/regression/finalize_1.f08 b/Fortran/gfortran/regression/finalize_1.f08 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_1.f08 @@ -0,0 +1,29 @@ +! { dg-do compile } + +! Parsing of finalizer procedure definitions. +! Check that CONTAINS is allowed in TYPE definition; but empty only for F2008 + +MODULE final_type + IMPLICIT NONE + + TYPE :: mytype + INTEGER, ALLOCATABLE :: fooarr(:) + REAL :: foobar + CONTAINS + END TYPE mytype + +CONTAINS + + SUBROUTINE bar + TYPE :: t + CONTAINS ! This is ok + END TYPE t + ! Nothing + END SUBROUTINE bar + +END MODULE final_type + +PROGRAM finalizer + IMPLICIT NONE + ! Do nothing here +END PROGRAM finalizer diff --git a/Fortran/gfortran/regression/finalize_10.f90 b/Fortran/gfortran/regression/finalize_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_10.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/37336 +! +! Finalize nonallocatable INTENT(OUT) +! +module m + type t + end type t + type t2 + contains + final :: fini + end type t2 +contains + elemental subroutine fini(var) + type(t2), intent(inout) :: var + end subroutine fini +end module m + +subroutine foo(x,y,aa,bb) + use m + class(t), intent(out) :: x(:),y + type(t2), intent(out) :: aa(:),bb +end subroutine foo + +! Finalize CLASS + set default init +! { dg-final { scan-tree-dump-times "y->_vptr->_final \\(&desc.\[0-9\]+, y->_vptr->_size, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump "__builtin_memcpy \\(\\(void .\\) y->_data, \\(void .\\) y->_vptr->_def_init, \\((unsigned long|unsigned int|character\\(kind=4\\))\\) y->_vptr->_size\\);" "original" } } +! { dg-final { scan-tree-dump-times "x->_vptr->_final \\(&parm.\[0-9\]+, x->_vptr->_size, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "x->_vptr->_copy \\(" 1 "original" } } + +! FINALIZE TYPE: +! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void \\*\\) aa.\[0-9\]+;" 1 "original" } } +! { dg-final { scan-tree-dump-times "__final_m_T2 \\(&parm.\[0-9\]+, 0, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "desc.\[0-9\]+.data = \\(void \\* restrict\\) bb;" 1 "original" } } +! { dg-final { scan-tree-dump-times "__final_m_T2 \\(&desc.\[0-9\]+, 0, 0\\);" 1 "original" } } + diff --git a/Fortran/gfortran/regression/finalize_11.f90 b/Fortran/gfortran/regression/finalize_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_11.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! Copied from finalize_6.f90 - was before rejected as the finalization +! wrapper uses TS29913 (-std=f2008ts) features. +! + +MODULE final_type + IMPLICIT NONE + + TYPE :: mytype + INTEGER :: fooarr(42) + REAL :: foobar + CONTAINS + FINAL :: finalize_single + END TYPE mytype + +CONTAINS + + SUBROUTINE finalize_single (el) + IMPLICIT NONE + TYPE(mytype) :: el + ! Do nothing in this test + END SUBROUTINE finalize_single + +END MODULE final_type + +PROGRAM finalizer + IMPLICIT NONE + ! Do nothing +END PROGRAM finalizer diff --git a/Fortran/gfortran/regression/finalize_12.f90 b/Fortran/gfortran/regression/finalize_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_12.f90 @@ -0,0 +1,175 @@ +! { dg-do run } +! { dg-options "-fcoarray=single" } +! +! PR fortran/37336 +! +module m + implicit none + type t + integer :: i + contains + final :: fini, fini2 + end type t + integer :: global_count1, global_count2 +contains + subroutine fini(x) + type(t) :: x + !print *, 'fini:',x%i + if (global_count1 == -1) STOP 1 + if (x%i /= 42) STOP 2 + x%i = 33 + global_count1 = global_count1 + 1 + end subroutine fini + subroutine fini2(x) + type(t) :: x(:) + !print *, 'fini2', x%i + if (global_count2 == -1) STOP 3 + if (size(x) /= 5) STOP 4 + if (any (x%i /= [1,2,3,4,5]) .and. any (x%i /= [6,7,8,9,10])) STOP 5 + x%i = 33 + global_count2 = global_count2 + 10 + end subroutine fini2 +end module m + +program pp + use m + implicit none + type(t), allocatable :: ya + class(t), allocatable :: yc + type(t), allocatable :: yaa(:) + class(t), allocatable :: yca(:) + + type(t), allocatable :: ca[:] + class(t), allocatable :: cc[:] + type(t), allocatable :: caa(:)[:] + class(t), allocatable :: cca(:)[:] + + global_count1 = -1 + global_count2 = -1 + allocate (ya, yc, yaa(5), yca(5)) + global_count1 = 0 + global_count2 = 0 + ya%i = 42 + yc%i = 42 + yaa%i = [1,2,3,4,5] + yca%i = [1,2,3,4,5] + + call foo(ya, yc, yaa, yca) + if (global_count1 /= 2) STOP 6 + if (global_count2 /= 20) STOP 7 + + ! Coarray finalization + allocate (ca[*], cc[*], caa(5)[*], cca(5)[*]) + global_count1 = 0 + global_count2 = 0 + ca%i = 42 + cc%i = 42 + caa%i = [1,2,3,4,5] + cca%i = [1,2,3,4,5] + deallocate (ca, cc, caa, cca) + if (global_count1 /= 2) STOP 8 + if (global_count2 /= 20) STOP 9 + global_count1 = -1 + global_count2 = -1 + + block + type(t), allocatable :: za + class(t), allocatable :: zc + type(t), allocatable :: zaa(:) + class(t), allocatable :: zca(:) + + ! Test intent(out) finalization + allocate (za, zc, zaa(5), zca(5)) + global_count1 = 0 + global_count2 = 0 + za%i = 42 + zc%i = 42 + zaa%i = [1,2,3,4,5] + zca%i = [1,2,3,4,5] + + call foo(za, zc, zaa, zca) + if (global_count1 /= 2) STOP 10 + if (global_count2 /= 20) STOP 11 + + ! Test intent(out) finalization with optional + call foo_opt() + call opt() + + ! Test intent(out) finalization with optional + allocate (za, zc, zaa(5), zca(5)) + global_count1 = 0 + global_count2 = 0 + za%i = 42 + zc%i = 42 + zaa%i = [1,2,3,4,5] + zca%i = [1,2,3,4,5] + + call foo_opt(za, zc, zaa, zca) + if (global_count1 /= 2) STOP 12 + if (global_count2 /= 20) STOP 13 + + ! Test DEALLOCATE finalization + allocate (za, zc, zaa(5), zca(5)) + global_count1 = 0 + global_count2 = 0 + za%i = 42 + zc%i = 42 + zaa%i = [1,2,3,4,5] + zca%i = [6,7,8,9,10] + deallocate (za, zc, zaa, zca) + if (global_count1 /= 2) STOP 14 + if (global_count2 /= 20) STOP 15 + + ! Test end-of-scope finalization + allocate (za, zc, zaa(5), zca(5)) + global_count1 = 0 + global_count2 = 0 + za%i = 42 + zc%i = 42 + zaa%i = [1,2,3,4,5] + zca%i = [6,7,8,9,10] + end block + + if (global_count1 /= 2) STOP 16 + if (global_count2 /= 20) STOP 17 + + ! Test that no end-of-scope finalization occurs + ! for SAVED variable in main + allocate (ya, yc, yaa(5), yca(5)) + global_count1 = -1 + global_count2 = -1 + +contains + + subroutine opt(xa, xc, xaa, xca) + type(t), allocatable, optional :: xa + class(t), allocatable, optional :: xc + type(t), allocatable, optional :: xaa(:) + class(t), allocatable, optional :: xca(:) + call foo_opt(xc, xc, xaa) + !call foo_opt(xa, xc, xaa, xca) ! FIXME: Fails (ICE) due to PR 57445 + end subroutine opt + subroutine foo_opt(xa, xc, xaa, xca) + type(t), allocatable, intent(out), optional :: xa + class(t), allocatable, intent(out), optional :: xc + type(t), allocatable, intent(out), optional :: xaa(:) + class(t), allocatable, intent(out), optional :: xca(:) + + if (.not. present(xa)) & + return + if (allocated (xa)) STOP 18 + if (allocated (xc)) STOP 19 + if (allocated (xaa)) STOP 20 + if (allocated (xca)) STOP 21 + end subroutine foo_opt + subroutine foo(xa, xc, xaa, xca) + type(t), allocatable, intent(out) :: xa + class(t), allocatable, intent(out) :: xc + type(t), allocatable, intent(out) :: xaa(:) + class(t), allocatable, intent(out) :: xca(:) + if (allocated (xa)) STOP 22 + if (allocated (xc)) STOP 23 + if (allocated (xaa)) STOP 24 + if (allocated (xca)) STOP 25 + end subroutine foo +end program diff --git a/Fortran/gfortran/regression/finalize_13.f90 b/Fortran/gfortran/regression/finalize_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_13.f90 @@ -0,0 +1,161 @@ +! { dg-do run } +! +! PR fortran/37336 +! +module m + implicit none + type t + integer :: i + contains + final :: fini3, fini2, fini_elm + end type t + + type, extends(t) :: t2 + integer :: j + contains + final :: f2ini2, f2ini_elm + end type t2 + + logical :: elem_call + logical :: rank2_call + logical :: rank3_call + integer :: cnt, cnt2 + integer :: fini_call + +contains + subroutine fini2 (x) + type(t), intent(in), contiguous :: x(:,:) + if (.not. rank2_call) STOP 1 + if (size(x,1) /= 2 .or. size(x,2) /= 3) STOP 2 + !print *, 'fini2:', x%i + if (any (x%i /= reshape([11, 12, 21, 22, 31, 32], [2,3]))) STOP 3 + fini_call = fini_call + 1 + end subroutine + + subroutine fini3 (x) + type(t), intent(in) :: x(2,2,*) + integer :: i,j,k + if (.not. elem_call) STOP 4 + if (.not. rank3_call) STOP 5 + if (cnt2 /= 9) STOP 6 + if (cnt /= 1) STOP 7 + do i = 1, 2 + do j = 1, 2 + do k = 1, 2 + !print *, k,j,i,x(k,j,i)%i + if (x(k,j,i)%i /= k+10*j+100*i) STOP 8 + end do + end do + end do + fini_call = fini_call + 1 + end subroutine + + impure elemental subroutine fini_elm (x) + type(t), intent(in) :: x + if (.not. elem_call) STOP 9 + if (rank3_call) STOP 10 + if (cnt2 /= 6) STOP 11 + if (cnt /= x%i) STOP 12 + !print *, 'fini_elm:', cnt, x%i + fini_call = fini_call + 1 + cnt = cnt + 1 + end subroutine + + subroutine f2ini2 (x) + type(t2), intent(in), target :: x(:,:) + if (.not. rank2_call) STOP 13 + if (size(x,1) /= 2 .or. size(x,2) /= 3) STOP 14 + !print *, 'f2ini2:', x%i + !print *, 'f2ini2:', x%j + if (any (x%i /= reshape([11, 12, 21, 22, 31, 32], [2,3]))) STOP 15 + if (any (x%j /= 100*reshape([11, 12, 21, 22, 31, 32], [2,3]))) STOP 16 + fini_call = fini_call + 1 + end subroutine + + impure elemental subroutine f2ini_elm (x) + type(t2), intent(in) :: x + integer, parameter :: exprected(*) & + = [111, 112, 121, 122, 211, 212, 221, 222] + + if (.not. elem_call) STOP 17 + !print *, 'f2ini_elm:', cnt2, x%i, x%j + if (rank3_call) then + if (x%i /= exprected(cnt2)) STOP 18 + if (x%j /= 1000*exprected(cnt2)) STOP 19 + else + if (cnt2 /= x%i .or. cnt2*10 /= x%j) STOP 20 + end if + cnt2 = cnt2 + 1 + fini_call = fini_call + 1 + end subroutine +end module m + + +program test + use m + implicit none + class(t), save, allocatable :: y(:), z(:,:), zz(:,:,:) + target :: z, zz + integer :: i,j,k + + elem_call = .false. + rank2_call = .false. + rank3_call = .false. + allocate (t2 :: y(5)) + select type (y) + type is (t2) + do i = 1, 5 + y(i)%i = i + y(i)%j = i*10 + end do + end select + cnt = 1 + cnt2 = 1 + fini_call = 0 + elem_call = .true. + deallocate (y) + if (fini_call /= 10) STOP 21 + + elem_call = .false. + rank2_call = .false. + rank3_call = .false. + allocate (t2 :: z(2,3)) + select type (z) + type is (t2) + do i = 1, 3 + do j = 1, 2 + z(j,i)%i = j+10*i + z(j,i)%j = (j+10*i)*100 + end do + end do + end select + cnt = 1 + cnt2 = 1 + fini_call = 0 + rank2_call = .true. + deallocate (z) + if (fini_call /= 2) STOP 22 + + elem_call = .false. + rank2_call = .false. + rank3_call = .false. + allocate (t2 :: zz(2,2,2)) + select type (zz) + type is (t2) + do i = 1, 2 + do j = 1, 2 + do k = 1, 2 + zz(k,j,i)%i = k+10*j+100*i + zz(k,j,i)%j = (k+10*j+100*i)*1000 + end do + end do + end do + end select + cnt = 1 + cnt2 = 1 + fini_call = 0 + rank3_call = .true. + elem_call = .true. + deallocate (zz) + if (fini_call /= 2*2*2+1) STOP 23 +end program test diff --git a/Fortran/gfortran/regression/finalize_14.f90 b/Fortran/gfortran/regression/finalize_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_14.f90 @@ -0,0 +1,220 @@ +! { dg-do compile } +! +! PR fortran/37336 +! +! Started to fail when finalization was added. +! +! Contributed by Ian Chivers in PR fortran/44465 +! +module shape_module + + type shape_type + integer :: x_=0 + integer :: y_=0 + contains + procedure , pass(this) :: getx + procedure , pass(this) :: gety + procedure , pass(this) :: setx + procedure , pass(this) :: sety + procedure , pass(this) :: moveto + procedure , pass(this) :: draw + end type shape_type + +interface assignment(=) + module procedure generic_shape_assign +end interface + +contains + + integer function getx(this) + implicit none + class (shape_type) , intent(in) :: this + getx=this%x_ + end function getx + + integer function gety(this) + implicit none + class (shape_type) , intent(in) :: this + gety=this%y_ + end function gety + + subroutine setx(this,x) + implicit none + class (shape_type), intent(inout) :: this + integer , intent(in) :: x + this%x_=x + end subroutine setx + + subroutine sety(this,y) + implicit none + class (shape_type), intent(inout) :: this + integer , intent(in) :: y + this%y_=y + end subroutine sety + + subroutine moveto(this,newx,newy) + implicit none + class (shape_type), intent(inout) :: this + integer , intent(in) :: newx + integer , intent(in) :: newy + this%x_=newx + this%y_=newy + end subroutine moveto + + subroutine draw(this) + implicit none + class (shape_type), intent(in) :: this + print *,' x = ' , this%x_ + print *,' y = ' , this%y_ + end subroutine draw + + subroutine generic_shape_assign(lhs,rhs) + implicit none + class (shape_type) , intent(out) , allocatable :: lhs + class (shape_type) , intent(in) :: rhs + print *,' In generic_shape_assign' + if ( allocated(lhs) ) then + deallocate(lhs) + end if + allocate(lhs,source=rhs) + end subroutine generic_shape_assign + +end module shape_module + +! Circle_p.f90 + +module circle_module + +use shape_module + +type , extends(shape_type) :: circle_type + + integer :: radius_ + + contains + + procedure , pass(this) :: getradius + procedure , pass(this) :: setradius + procedure , pass(this) :: draw => draw_circle + +end type circle_type + + contains + + integer function getradius(this) + implicit none + class (circle_type) , intent(in) :: this + getradius=this%radius_ + end function getradius + + subroutine setradius(this,radius) + implicit none + class (circle_type) , intent(inout) :: this + integer , intent(in) :: radius + this%radius_=radius + end subroutine setradius + + subroutine draw_circle(this) + implicit none + class (circle_type), intent(in) :: this + print *,' x = ' , this%x_ + print *,' y = ' , this%y_ + print *,' radius = ' , this%radius_ + end subroutine draw_circle + +end module circle_module + + +! Rectangle_p.f90 + +module rectangle_module + +use shape_module + +type , extends(shape_type) :: rectangle_type + + integer :: width_ + integer :: height_ + + contains + + procedure , pass(this) :: getwidth + procedure , pass(this) :: setwidth + procedure , pass(this) :: getheight + procedure , pass(this) :: setheight + procedure , pass(this) :: draw => draw_rectangle + +end type rectangle_type + + contains + + integer function getwidth(this) + implicit none + class (rectangle_type) , intent(in) :: this + getwidth=this%width_ + end function getwidth + + subroutine setwidth(this,width) + implicit none + class (rectangle_type) , intent(inout) :: this + integer , intent(in) :: width + this%width_=width + end subroutine setwidth + + integer function getheight(this) + implicit none + class (rectangle_type) , intent(in) :: this + getheight=this%height_ + end function getheight + + subroutine setheight(this,height) + implicit none + class (rectangle_type) , intent(inout) :: this + integer , intent(in) :: height + this%height_=height + end subroutine setheight + + subroutine draw_rectangle(this) + implicit none + class (rectangle_type), intent(in) :: this + print *,' x = ' , this%x_ + print *,' y = ' , this%y_ + print *,' width = ' , this%width_ + print *,' height = ' , this%height_ + + end subroutine draw_rectangle + +end module rectangle_module + + + +program polymorphic + +use shape_module +use circle_module +use rectangle_module + +implicit none + +type shape_w + class (shape_type) , allocatable :: shape_v +end type shape_w + +type (shape_w) , dimension(3) :: p + + print *,' shape ' + + p(1)%shape_v=shape_type(10,20) + call p(1)%shape_v%draw() + + print *,' circle ' + + p(2)%shape_v=circle_type(100,200,300) + call p(2)%shape_v%draw() + + print *,' rectangle ' + + p(3)%shape_v=rectangle_type(1000,2000,3000,4000) + call p(3)%shape_v%draw() + +end program polymorphic diff --git a/Fortran/gfortran/regression/finalize_15.f90 b/Fortran/gfortran/regression/finalize_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_15.f90 @@ -0,0 +1,238 @@ +! { dg-do run } +! +! PR fortran/37336 +! +! Check the scalarizer/array packing with strides +! in the finalization wrapper +! +module m + implicit none + + type t1 + integer :: i = 1 + contains + final :: fini_elem + end type t1 + + type, extends(t1) :: t1e + integer :: j = 11 + contains + final :: fini_elem2 + end type t1e + + type t2 + integer :: i = 2 + contains + final :: fini_shape + end type t2 + + type, extends(t2) :: t2e + integer :: j = 22 + contains + final :: fini_shape2 + end type t2e + + type t3 + integer :: i = 3 + contains + final :: fini_explicit + end type t3 + + type, extends(t3) :: t3e + integer :: j = 33 + contains + final :: fini_explicit2 + end type t3e + + integer :: cnt1, cnt1e, cnt2, cnt2e, cnt3, cnt3e + +contains + + impure elemental subroutine fini_elem(x) + type(t1), intent(inout) :: x + integer :: i, j, i2, j2 + + if (cnt1e /= 5*4) STOP 1 + j = mod (cnt1,5)+1 + i = cnt1/5 + 1 + i2 = (i-1)*3 + 1 + j2 = (j-1)*2 + 1 + if (x%i /= j2 + 100*i2) STOP 2 + x%i = x%i * (-13) + cnt1 = cnt1 + 1 + end subroutine fini_elem + + impure elemental subroutine fini_elem2(x) + type(t1e), intent(inout) :: x + integer :: i, j, i2, j2 + + j = mod (cnt1e,5)+1 + i = cnt1e/5 + 1 + i2 = (i-1)*3 + 1 + j2 = (j-1)*2 + 1 + if (x%i /= j2 + 100*i2) STOP 3 + if (x%j /= (j2 + 100*i2)*100) STOP 4 + x%j = x%j * (-13) + cnt1e = cnt1e + 1 + end subroutine fini_elem2 + + subroutine fini_shape(x) + type(t2) :: x(:,:) + if (cnt2e /= 1 .or. cnt2 /= 0) STOP 5 + call check_var_sec(x%i, 1) + x%i = x%i * (-13) + cnt2 = cnt2 + 1 + end subroutine fini_shape + + subroutine fini_shape2(x) + type(t2e) :: x(:,:) + call check_var_sec(x%i, 1) + call check_var_sec(x%j, 100) + x%j = x%j * (-13) + cnt2e = cnt2e + 1 + end subroutine fini_shape2 + + subroutine fini_explicit(x) + type(t3) :: x(5,4) + if (cnt3e /= 1 .or. cnt3 /= 0) STOP 6 + call check_var_sec(x%i, 1) + x%i = x%i * (-13) + cnt3 = cnt3 + 1 + end subroutine fini_explicit + + subroutine fini_explicit2(x) + type(t3e) :: x(5,4) + call check_var_sec(x%i, 1) + call check_var_sec(x%j, 100) + x%j = x%j * (-13) + cnt3e = cnt3e + 1 + end subroutine fini_explicit2 + + subroutine fin_test_1(x) + class(t1), intent(out) :: x(5,4) + end subroutine fin_test_1 + + subroutine fin_test_2(x) + class(t2), intent(out) :: x(:,:) + end subroutine fin_test_2 + + subroutine fin_test_3(x) + class(t3), intent(out) :: x(:,:) + if (any (shape(x) /= [5,4])) STOP 7 + end subroutine fin_test_3 + + subroutine check_var_sec(x, factor) + integer :: x(:,:) + integer, value :: factor + integer :: i, j, i2, j2 + + do i = 1, 4 + i2 = (i-1)*3 + 1 + do j = 1, 5 + j2 = (j-1)*2 + 1 + if (x(j,i) /= (j2 + 100*i2)*factor) STOP 8 + end do + end do + end subroutine check_var_sec +end module m + + +program test + use m + implicit none + + class(t1), allocatable :: x(:,:) + class(t2), allocatable :: y(:,:) + class(t3), allocatable :: z(:,:) + integer :: i, j + + cnt1 = 0; cnt1e = 0; cnt2 = 0; cnt2e = 0; cnt3 = 0; cnt3e = 0 + + allocate (t1e :: x(10,10)) + allocate (t2e :: y(10,10)) + allocate (t3e :: z(10,10)) + + select type(x) + type is (t1e) + do i = 1, 10 + do j = 1, 10 + x(j,i)%i = j + 100*i + x(j,i)%j = (j + 100*i)*100 + end do + end do + end select + + select type(y) + type is (t2e) + do i = 1, 10 + do j = 1, 10 + y(j,i)%i = j + 100*i + y(j,i)%j = (j + 100*i)*100 + end do + end do + end select + + select type(z) + type is (t3e) + do i = 1, 10 + do j = 1, 10 + z(j,i)%i = j + 100*i + z(j,i)%j = (j + 100*i)*100 + end do + end do + end select + + if (cnt1 + cnt1e + cnt2 + cnt2e + cnt3 + cnt3e /= 0) STOP 9 + + call fin_test_1(x(::2,::3)) + if (cnt1 /= 5*4) STOP 10 + if (cnt1e /= 5*4) STOP 11 + cnt1 = 0; cnt1e = 0 + if (cnt2 + cnt2e + cnt3 + cnt3e /= 0) STOP 12 + + call fin_test_2(y(::2,::3)) + if (cnt2 /= 1) STOP 13 + if (cnt2e /= 1) STOP 14 + cnt2 = 0; cnt2e = 0 + if (cnt1 + cnt1e + cnt3 + cnt3e /= 0) STOP 15 + + call fin_test_3(z(::2,::3)) + if (cnt3 /= 1) STOP 16 + if (cnt3e /= 1) STOP 17 + cnt3 = 0; cnt3e = 0 + if (cnt1 + cnt1e + cnt2 + cnt2e /= 0) STOP 18 + + select type(x) + type is (t1e) + call check_val(x%i, 1, 1) + call check_val(x%j, 100, 11) + end select + + select type(y) + type is (t2e) + call check_val(y%i, 1, 2) + call check_val(y%j, 100, 22) + end select + + select type(z) + type is (t3e) + call check_val(z%i, 1, 3) + call check_val(z%j, 100, 33) + end select + +contains + subroutine check_val(x, factor, val) + integer :: x(:,:) + integer, value :: factor, val + integer :: i, j + do i = 1, 10 + do j = 1, 10 + if (mod (j-1, 2) == 0 .and. mod (i-1, 3) == 0) then + if (x(j,i) /= val) STOP 19 + else + if (x(j,i) /= (j + 100*i)*factor) STOP 20 + end if + end do + end do + end subroutine check_val +end program test diff --git a/Fortran/gfortran/regression/finalize_16.f90 b/Fortran/gfortran/regression/finalize_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_16.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! { dg-options "-fcheck=all" } +! +! PR fortran/57542 +! +! Contributed by Salvatore Filippone +! +module type_mod + type inner + end type inner + + type outer + class(inner), allocatable :: item + end type outer + + type container + class(outer), allocatable :: item + end type container + + type maintype + type(container), allocatable :: v(:) + end type maintype + +end module type_mod + +subroutine testfinal(var) + use type_mod + type(maintype), intent(inout) :: var + ! A real code would obviously check + ! this is really allocated + deallocate(var%v(1)%item%item) +end subroutine testfinal diff --git a/Fortran/gfortran/regression/finalize_17.f90 b/Fortran/gfortran/regression/finalize_17.f90 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_17.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! +! PR fortran/37336 +! +! Test for finalization of nonallocatable variables +! +module m + implicit none + type t + integer :: i + contains + final :: finit + end type t + integer, save :: called_final = -1 +contains + impure elemental subroutine finit(x) + type(t), intent(in) :: x + if (called_final == -1) STOP 1 + called_final = called_final + 1 + if (called_final /= x%i) STOP 2 + end subroutine finit +end module m + + use m + implicit none + type(t) :: x2, y2(2) + block + type(t) :: xx, yy(2) + type(t), save :: x3, y3(2) + yy%i = [1, 2] + xx%i = 3 + y3%i = [-4, -5] + x3%i = -6 + called_final = 0 + end block + if (called_final /= 3) STOP 1 + called_final = -1 + y2%i = [-7, -8] + x2%i = -9 +end diff --git a/Fortran/gfortran/regression/finalize_18.f90 b/Fortran/gfortran/regression/finalize_18.f90 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_18.f90 @@ -0,0 +1,46 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/37336 +! +module m + type t + contains + final :: fini + end type t + type t2 + integer :: ii + type(t), allocatable :: aa + type(t), allocatable :: bb(:) + class(t), allocatable :: cc + class(t), allocatable :: dd(:) + end type t2 + integer, save :: cnt = -1 +contains + subroutine fini(x) + type(t) :: x + if (cnt == -1) STOP 1 + cnt = cnt + 1 + end subroutine fini +end module m + +use m +block + type(t2) :: y + y%ii = 123 +end block +end + +! { dg-final { scan-tree-dump-times "if \\(y.aa != 0B\\)" 2 "original" } } +! { dg-final { scan-tree-dump-times "if \\(y.cc._data != 0B\\)" 2 "original" } } +! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.bb.data != 0B\\)" 2 "original" } } +! { dg-final { scan-tree-dump-times "if \\(\\(struct t\\\[0:\\\] . restrict\\) y.dd._data.data != 0B\\)" 2 "original" } } + +! { dg-final { scan-tree-dump-times "desc.\[0-9\]+.data = \\(void . restrict\\) y.aa;" 1 "original" } } +! { dg-final { scan-tree-dump-times "desc.\[0-9\]+.data = \\(void . restrict\\) y.cc._data;" 1 "original" } } + +! { dg-final { scan-tree-dump-times "__final_m_T \\(&desc.\[0-9\]+, 0, 1\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "__final_m_T \\(&y.bb, 0, 1\\);" 1 "original" } } +! { dg-final { scan-tree-dump "y.cc._vptr->_final \\(&desc.\[0-9\]+, (\\(integer\\(kind=8\\)\\) )?y.cc._vptr->_size, 1\\);" "original" } } +! { dg-final { scan-tree-dump "y.dd._vptr->_final \\(&y.dd._data, (\\(integer\\(kind=8\\)\\) )?y.dd._vptr->_size, 1\\);" "original" } } + diff --git a/Fortran/gfortran/regression/finalize_19.f90 b/Fortran/gfortran/regression/finalize_19.f90 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_19.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! +! PR fortran/58356 +! +! Contributed by Andrew Benson +! +module ct + type :: cfl + contains + final :: cfld + end type cfl + type, extends(cfl) :: cfde + contains + end type cfde +contains + subroutine cfld(self) + implicit none + type(cfl), intent(inout) :: self + return + end subroutine cfld +end module ct diff --git a/Fortran/gfortran/regression/finalize_2.f03 b/Fortran/gfortran/regression/finalize_2.f03 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_2.f03 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } + +! Parsing of finalizer procedure definitions. +! Check empty CONTAINS errors out for F2003. + +MODULE final_type + IMPLICIT NONE + + TYPE :: mytype + INTEGER, ALLOCATABLE :: fooarr(:) + REAL :: foobar + CONTAINS + END TYPE mytype ! { dg-error "Fortran 2008" } + +END MODULE final_type + +PROGRAM finalizer + IMPLICIT NONE + ! Do nothing here +END PROGRAM finalizer diff --git a/Fortran/gfortran/regression/finalize_21.f90 b/Fortran/gfortran/regression/finalize_21.f90 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_21.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/58436 +! +! The following was ICEing and lacking _final=0 +! +class(*), allocatable :: var +end + +! { dg-final { scan-tree-dump "static struct __vtype__STAR __vtab__STAR = {._hash=0, ._size=., ._extends=0B, ._def_init=0B, ._copy=0B, ._final=0B, ._deallocate=0B};" "original" } } diff --git a/Fortran/gfortran/regression/finalize_22.f90 b/Fortran/gfortran/regression/finalize_22.f90 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_22.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! +! PR 58470: [4.9 Regression] [OOP] ICE on invalid with FINAL procedure and type extension +! +! Contributed by Andrew Benson + +module cf + type :: cfml + contains + final :: mld + end type cfml + type, extends(cfml) :: cfmde + end type cfmde +contains + subroutine mld(s) ! { dg-error "must be of type" } + class(cfml), intent(inout) :: s + end subroutine mld +end module cf diff --git a/Fortran/gfortran/regression/finalize_23.f90 b/Fortran/gfortran/regression/finalize_23.f90 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_23.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! +! PR 60234: [4.9 Regression] [OOP] ICE in generate_finalization_wrapper at fortran/class.c:1883 +! +! Contribued by Antony Lewis + +module ObjectLists + implicit none + + Type TObjectList + contains + FINAL :: finalize + end Type + + Type, extends(TObjectList):: TRealCompareList + end Type + +contains + + subroutine finalize(L) + Type(TObjectList) :: L + end subroutine + + + integer function CompareReal(this) + Class(TRealCompareList) :: this + end function + +end module diff --git a/Fortran/gfortran/regression/finalize_24.f90 b/Fortran/gfortran/regression/finalize_24.f90 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_24.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR fortran/58880 +! +! Contributed by Andrew Benson +! + +module gn + type sl + integer, allocatable, dimension(:) :: lv + contains + final :: sld + end type sl + type :: nde + type(sl) :: r + end type nde +contains + subroutine ndm(s) + type(nde), intent(inout) :: s + type(nde) :: i + i=s + end subroutine ndm + subroutine sld(s) + implicit none + type(sl), intent(inout) :: s + return + end subroutine sld +end module gn diff --git a/Fortran/gfortran/regression/finalize_25.f90 b/Fortran/gfortran/regression/finalize_25.f90 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_25.f90 @@ -0,0 +1,55 @@ +! { dg-do run } +! +! PR fortran/58880 +! PR fortran/60495 +! +! Contributed by Andrew Benson and Janus Weil +! + +module gn + implicit none + type sl + integer, allocatable, dimension(:) :: lv + contains + final :: sld + end type + type :: nde + type(sl) :: r + end type nde + + integer :: cnt = 0 + +contains + + subroutine sld(s) + type(sl) :: s + cnt = cnt + 1 + ! print *,'Finalize sl' + end subroutine + subroutine ndm(s) + type(nde), intent(inout) :: s + type(nde) :: i + i=s + end subroutine ndm +end module + +program main + use gn + type :: nde2 + type(sl) :: r + end type nde2 + type(nde) :: x + + cnt = 0 + call ndm(x) + if (cnt /= 2) STOP 1 + + cnt = 0 + call ndm2() + if (cnt /= 3) STOP 2 +contains + subroutine ndm2 + type(nde2) :: s,i + i=s + end subroutine ndm2 +end program main diff --git a/Fortran/gfortran/regression/finalize_27.f90 b/Fortran/gfortran/regression/finalize_27.f90 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_27.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! +! Was ICEing before +! +! Contributed by Reinhold Bader +! + +module mod_fin_04 + implicit none + type :: p_vec + contains + final :: delete + end type p_vec + type, extends(p_vec) :: bar + contains + final :: del2 + end type bar +contains + subroutine delete(this) + type(p_vec) :: this + end subroutine delete + subroutine del2(this) + type(bar) :: this + end subroutine del2 +end module diff --git a/Fortran/gfortran/regression/finalize_28.f90 b/Fortran/gfortran/regression/finalize_28.f90 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_28.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Test the fix for PR64932. +! +! Reported by Daniel Shapiro +! +module coo_graphs + implicit none + type :: dynamic_array + integer :: length, capacity, min_capacity + integer, allocatable :: array(:) + end type + type :: coo_graph + type(dynamic_array) :: edges(2) + integer, private :: ne + end type coo_graph +contains + subroutine coo_dump_edges(g, edges) + class(coo_graph), intent(in) :: g + integer, intent(out) :: edges(:,:) + end subroutine coo_dump_edges +end module coo_graphs +! { dg-final { scan-tree-dump-times "__builtin_free" 6 "original" } } diff --git a/Fortran/gfortran/regression/finalize_29.f08 b/Fortran/gfortran/regression/finalize_29.f08 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_29.f08 @@ -0,0 +1,289 @@ +! { dg-do run } +! +! Testcase contributed by Andre Vehreschild + +module module_finalize_29 + implicit none + + ! The type name is encoding the state of its finalizer being + ! elemental (second letter 'e'), or non-element (second letter 'n') + ! or array shaped (second letter 'a'), or shape-specific routine + ! (generic; second letter 'g'), + ! and whether the init-routine is elemental or not (third letter + ! either 'e' or 'n'). + type ten + integer :: i = 40 + contains + final :: ten_fin + end type ten + + type tee + integer :: i = 41 + contains + final :: tee_fin + end type tee + + type tne + integer :: i = 42 + contains + final :: tne_fin + end type tne + + type tnn + integer :: i = 43 + contains + final :: tnn_fin + end type tnn + + type tae + integer :: i = 44 + contains + final :: tae_fin + end type tae + + type tan + integer :: i = 45 + contains + final :: tan_fin + end type tan + + type tge + integer :: i = 46 + contains + final :: tge_scalar_fin, tge_array_fin + end type tge + + type tgn + integer :: i = 47 + contains + final :: tgn_scalar_fin, tgn_array_fin + end type tgn + + integer :: ten_fin_counts, tee_fin_counts, tne_fin_counts, tnn_fin_counts + integer :: tae_fin_counts, tan_fin_counts + integer :: tge_scalar_fin_counts, tge_array_fin_counts + integer :: tgn_scalar_fin_counts, tgn_array_fin_counts +contains + impure elemental subroutine ten_fin(x) + type(ten), intent(inout) :: x + x%i = -10 * x%i + ten_fin_counts = ten_fin_counts + 1 + end subroutine ten_fin + + impure elemental subroutine tee_fin(x) + type(tee), intent(inout) :: x + x%i = -11 * x%i + tee_fin_counts = tee_fin_counts + 1 + end subroutine tee_fin + + subroutine tne_fin(x) + type(tne), intent(inout) :: x + x%i = -12 * x%i + tne_fin_counts = tne_fin_counts + 1 + end subroutine tne_fin + + subroutine tnn_fin(x) + type(tnn), intent(inout) :: x + x%i = -13 * x%i + tnn_fin_counts = tnn_fin_counts + 1 + end subroutine tnn_fin + + subroutine tae_fin(x) + type(tae), intent(inout) :: x(:,:) + x%i = -14 * x%i + tae_fin_counts = tae_fin_counts + 1 + end subroutine tae_fin + + subroutine tan_fin(x) + type(tan), intent(inout) :: x(:,:) + x%i = -15 * x%i + tan_fin_counts = tan_fin_counts + 1 + end subroutine tan_fin + + subroutine tge_scalar_fin(x) + type(tge), intent(inout) :: x + x%i = -16 * x%i + tge_scalar_fin_counts = tge_scalar_fin_counts + 1 + end subroutine tge_scalar_fin + + subroutine tge_array_fin(x) + type(tge), intent(inout) :: x(:,:) + x%i = -17 * x%i + tge_array_fin_counts = tge_array_fin_counts + 1 + end subroutine tge_array_fin + + subroutine tgn_scalar_fin(x) + type(tgn), intent(inout) :: x + x%i = -18 * x%i + tgn_scalar_fin_counts = tgn_scalar_fin_counts + 1 + end subroutine tgn_scalar_fin + + subroutine tgn_array_fin(x) + type(tgn), intent(inout) :: x(:,:) + x%i = -19 * x%i + tgn_array_fin_counts = tgn_array_fin_counts + 1 + end subroutine tgn_array_fin + + ! The finalizer/initializer call producer + subroutine ten_init(x) + class(ten), intent(out) :: x(:,:) + end subroutine ten_init + + impure elemental subroutine tee_init(x) + class(tee), intent(out) :: x + end subroutine tee_init + + impure elemental subroutine tne_init(x) + class(tne), intent(out) :: x + end subroutine tne_init + + subroutine tnn_init(x) + class(tnn), intent(out) :: x(:,:) + end subroutine tnn_init + + impure elemental subroutine tae_init(x) + class(tae), intent(out) :: x + end subroutine tae_init + + subroutine tan_init(x) + class(tan), intent(out) :: x(:,:) + end subroutine tan_init + + impure elemental subroutine tge_init(x) + class(tge), intent(out) :: x + end subroutine tge_init + + subroutine tgn_init(x) + class(tgn), intent(out) :: x(:,:) + end subroutine tgn_init +end module module_finalize_29 + +program finalize_29 + use module_finalize_29 + implicit none + + type(ten), allocatable :: x_ten(:,:) + type(tee), allocatable :: x_tee(:,:) + type(tne), allocatable :: x_tne(:,:) + type(tnn), allocatable :: x_tnn(:,:) + type(tae), allocatable :: x_tae(:,:) + type(tan), allocatable :: x_tan(:,:) + type(tge), allocatable :: x_tge(:,:) + type(tgn), allocatable :: x_tgn(:,:) + + ! Set the global counts to zero. + ten_fin_counts = 0 + tee_fin_counts = 0 + tne_fin_counts = 0 + tnn_fin_counts = 0 + tae_fin_counts = 0 + tan_fin_counts = 0 + tge_scalar_fin_counts = 0 + tge_array_fin_counts = 0 + tgn_scalar_fin_counts = 0 + tgn_array_fin_counts = 0 + + allocate(ten :: x_ten(5,5)) + allocate(tee :: x_tee(5,5)) + allocate(tne :: x_tne(5,5)) + allocate(tnn :: x_tnn(5,5)) + allocate(tae :: x_tae(5,5)) + allocate(tan :: x_tan(5,5)) + allocate(tge :: x_tge(5,5)) + allocate(tgn :: x_tgn(5,5)) + + x_ten%i = 1 + x_tee%i = 2 + x_tne%i = 3 + x_tnn%i = 4 + x_tae%i = 5 + x_tan%i = 6 + x_tge%i = 7 + x_tgn%i = 8 + + call ten_init(x_ten(::2, ::3)) + + if (ten_fin_counts /= 6) STOP 1 + if (tee_fin_counts + tne_fin_counts + tnn_fin_counts + tae_fin_counts + & + tan_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + & + tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) STOP 2 + ten_fin_counts = 0 + + call tee_init(x_tee(::2, ::3)) + + if (tee_fin_counts /= 6) STOP 3 + if (ten_fin_counts + tne_fin_counts + tnn_fin_counts + tae_fin_counts + & + tan_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + & + tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) STOP 4 + tee_fin_counts = 0 + + call tne_init(x_tne(::2, ::3)) + + if (tne_fin_counts /= 6) STOP 5 + if (ten_fin_counts + tee_fin_counts + tnn_fin_counts + tae_fin_counts + & + tan_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + & + tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) STOP 6 + tne_fin_counts = 0 + + call tnn_init(x_tnn(::2, ::3)) + + if (tnn_fin_counts /= 0) STOP 7 + if (ten_fin_counts + tee_fin_counts + tne_fin_counts + tae_fin_counts + & + tan_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + & + tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) STOP 8 + + call tae_init(x_tae(::2, ::3)) + + if (tae_fin_counts /= 0) STOP 9 + if (ten_fin_counts + tee_fin_counts + tne_fin_counts + tnn_fin_counts + & + tan_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + & + tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) STOP 10 + + call tan_init(x_tan(::2, ::3)) + + if (tan_fin_counts /= 1) STOP 11 + if (ten_fin_counts + tee_fin_counts + tne_fin_counts + tnn_fin_counts + & + tae_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + & + tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) STOP 12 + tan_fin_counts = 0 + + call tge_init(x_tge(::2, ::3)) + + if (tge_scalar_fin_counts /= 6) STOP 13 + if (ten_fin_counts + tee_fin_counts + tne_fin_counts + tnn_fin_counts + & + tae_fin_counts + tan_fin_counts + tgn_array_fin_counts + & + tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) STOP 14 + tge_scalar_fin_counts = 0 + + call tgn_init(x_tgn(::2, ::3)) + + if (tgn_array_fin_counts /= 1) STOP 15 + if (ten_fin_counts + tee_fin_counts + tne_fin_counts + tnn_fin_counts + & + tae_fin_counts + tan_fin_counts + tge_scalar_fin_counts + & + tge_array_fin_counts + tgn_scalar_fin_counts /= 0) STOP 16 + tgn_array_fin_counts = 0 + + if (any (reshape (x_ten%i, [25]) /= [[40, 1, 40, 1, 40], [1, 1, 1, 1, 1],& + [1, 1, 1, 1, 1], [40, 1, 40, 1, 40], [1, 1, 1, 1, 1]])) STOP 17 + + if (any (reshape (x_tee%i, [25]) /= [[41, 2, 41, 2, 41], [2, 2, 2, 2, 2],& + [2, 2, 2, 2, 2], [41, 2, 41, 2, 41], [2, 2, 2, 2, 2]])) STOP 18 + + if (any (reshape (x_tne%i, [25]) /= [[42, 3, 42, 3, 42], [3, 3, 3, 3, 3],& + [3, 3, 3, 3, 3], [42, 3, 42, 3, 42], [3, 3, 3, 3, 3]])) STOP 19 + + if (any (reshape (x_tnn%i, [25]) /= [[43, 4, 43, 4, 43], [4, 4, 4, 4, 4],& + [4, 4, 4, 4, 4], [43, 4, 43, 4, 43], [4, 4, 4, 4, 4]])) STOP 20 + + if (any (reshape (x_tae%i, [25]) /= [[44, 5, 44, 5, 44], [5, 5, 5, 5, 5],& + [5, 5, 5, 5, 5], [44, 5, 44, 5, 44], [5, 5, 5, 5, 5]])) STOP 21 + + if (any (reshape (x_tan%i, [25]) /= [[45, 6, 45, 6, 45], [6, 6, 6, 6, 6],& + [6, 6, 6, 6, 6], [45, 6, 45, 6, 45], [6, 6, 6, 6, 6]])) STOP 22 + + if (any (reshape (x_tge%i, [25]) /= [[46, 7, 46, 7, 46], [7, 7, 7, 7, 7],& + [7, 7, 7, 7, 7], [46, 7, 46, 7, 46], [7, 7, 7, 7, 7]])) STOP 23 + + if (any (reshape (x_tgn%i, [25]) /= [[47, 8, 47, 8, 47], [8, 8, 8, 8, 8],& + [8, 8, 8, 8, 8], [47, 8, 47, 8, 47], [8, 8, 8, 8, 8]])) STOP 24 +end program finalize_29 diff --git a/Fortran/gfortran/regression/finalize_3.f03 b/Fortran/gfortran/regression/finalize_3.f03 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_3.f03 @@ -0,0 +1,23 @@ +! { dg-do compile } + +! Parsing of finalizer procedure definitions. +! Check that CONTAINS disallows further components and no double CONTAINS +! is allowed. + +MODULE final_type + IMPLICIT NONE + + TYPE :: mytype + INTEGER, ALLOCATABLE :: fooarr(:) + REAL :: foobar + CONTAINS + CONTAINS ! { dg-error "Already inside a CONTAINS block" } + INTEGER :: x ! { dg-error "must precede CONTAINS" } + END TYPE mytype + +END MODULE final_type + +PROGRAM finalizer + IMPLICIT NONE + ! Do nothing here +END PROGRAM finalizer diff --git a/Fortran/gfortran/regression/finalize_30.f90 b/Fortran/gfortran/regression/finalize_30.f90 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_30.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-Wsurprising" } +! +! PR 58175: [OOP] Incorrect warning message on scalar finalizer +! +! Contributed by Andrew Benson + +module ct + type :: a + contains + final :: aD + end type + type, extends(a) :: a1 + end type +contains + subroutine aD(self) + type(a), intent(inout) :: self + end subroutine +end module + +program test + use ct +end diff --git a/Fortran/gfortran/regression/finalize_31.f90 b/Fortran/gfortran/regression/finalize_31.f90 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_31.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! +! PR 61767: [OOP] ICE in generate_finalization_wrapper at fortran/class.c:1491 +! +! Contributed by + +module Communicator_Form + implicit none + type :: CommunicatorForm + contains + final :: Finalize + end type + type :: MessageTemplate + type ( CommunicatorForm ), pointer :: Communicator + end type +contains + subroutine Finalize ( C ) + type ( CommunicatorForm ) :: C + ! should not be called + STOP 1 + end subroutine +end module + +program p + use Communicator_Form + implicit none + class ( MessageTemplate ), pointer :: M + allocate(M) + deallocate(M) +end diff --git a/Fortran/gfortran/regression/finalize_32.f90 b/Fortran/gfortran/regression/finalize_32.f90 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_32.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! +! PR 79311: [OOP] ICE in generate_finalization_wrapper, at fortran/class.c:1992 +! +! Contributed by DIL + +module tensor_recursive + implicit none + + type :: tens_signature_t + contains + final :: tens_signature_dtor + end type + + type :: tens_header_t + type(tens_signature_t) :: signature + contains + final :: tens_header_dtor + end type + +contains + + subroutine tens_signature_dtor(this) + type(tens_signature_t) :: this + end subroutine + + subroutine tens_header_dtor(this) + type(tens_header_t) :: this + end subroutine + +end diff --git a/Fortran/gfortran/regression/finalize_33.f90 b/Fortran/gfortran/regression/finalize_33.f90 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_33.f90 @@ -0,0 +1,119 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! Tests the fix for PR87359 in which the finalization of +! 'source=process%component%extract_mci_template()' in the allocation +! of 'process%mci' caused invalid reads and freeing of already freed +! memory. This test is a greatly reduced version of the original code. +! +! Contributed by Juergen Reuter +! +module mci_base + implicit none + private + public :: mci_t + public :: mci_midpoint_t + public :: cnt + integer :: cnt = 0 + type, abstract :: mci_t + integer, dimension(:), allocatable :: chain + end type mci_t + type, extends (mci_t) :: mci_midpoint_t + contains + final :: mci_midpoint_final + end type mci_midpoint_t +contains + IMPURE ELEMENTAL SUBROUTINE mci_midpoint_final(arg) + TYPE(mci_midpoint_t), INTENT(INOUT) :: arg + cnt = cnt + 1 + END SUBROUTINE mci_midpoint_final +end module mci_base + +!!!!! + +module process_config + use mci_base + implicit none + private + public :: process_component_t + type :: process_component_t + class(mci_t), allocatable :: mci_template + contains + procedure :: init => process_component_init + procedure :: extract_mci_template => process_component_extract_mci_template + end type process_component_t + +contains + + subroutine process_component_init (component, mci_template) + class(process_component_t), intent(out) :: component + class(mci_t), intent(in), allocatable :: mci_template + if (allocated (mci_template)) & + allocate (component%mci_template, source = mci_template) + end subroutine process_component_init + + function process_component_extract_mci_template (component) & + result (mci_template) + class(mci_t), allocatable :: mci_template + class(process_component_t), intent(in) :: component + if (allocated (component%mci_template)) & + allocate (mci_template, source = component%mci_template) + end function process_component_extract_mci_template +end module process_config + +!!!!! + +module process + use mci_base + use process_config + implicit none + private + public :: process_t + type :: process_t + private + type(process_component_t) :: component + class(mci_t), allocatable :: mci + contains + procedure :: init_component => process_init_component + procedure :: setup_mci => process_setup_mci + end type process_t +contains + subroutine process_init_component & + (process, mci_template) + class(process_t), intent(inout), target :: process + class(mci_t), intent(in), allocatable :: mci_template + call process%component%init (mci_template) + end subroutine process_init_component + + subroutine process_setup_mci (process) + class(process_t), intent(inout) :: process + allocate (process%mci, source=process%component%extract_mci_template ()) + end subroutine process_setup_mci + +end module process + +!!!!! + +program main_ut + use mci_base + use process, only: process_t + implicit none + call event_transforms_1 () + if (cnt .ne. 4) stop 2 +contains + + subroutine event_transforms_1 () + class(mci_t), allocatable :: mci_template + type(process_t), allocatable, target :: process + allocate (process) + allocate (mci_midpoint_t :: mci_template) + call process%init_component (mci_template) + call process%setup_mci () ! generates 1 final call from call to extract_mci_template + if (cnt .ne. 1) stop 1 + end subroutine event_transforms_1 ! generates 3 final calls to mci_midpoint_final: + ! (i) process%component%mci_template + ! (ii) process%mci + ! (iii) mci_template +end program main_ut +! { dg-final { scan-tree-dump-times "__builtin_malloc" 17 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free" 20 "original" } } diff --git a/Fortran/gfortran/regression/finalize_34.f90 b/Fortran/gfortran/regression/finalize_34.f90 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_34.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } +! PR 87352 - this used to cause an excessive number of deallocations. +module testmodule + implicit none + public + + type :: evtlist_type + real, allocatable, dimension(:) :: p1 + real, allocatable, dimension(:) :: p2 + real, allocatable, dimension(:) :: p3 + real, allocatable, dimension(:) :: p4 + end type evtlist_type + + type :: evtlistlist_type + type(evtlist_type) :: evtlist(1:1) + end type evtlistlist_type + +end module testmodule + +program main + use testmodule + type(evtlist_type), dimension(10) :: a +end program main +! { dg-final { scan-tree-dump-times "__builtin_free" 24 "original" } } diff --git a/Fortran/gfortran/regression/finalize_35.f90 b/Fortran/gfortran/regression/finalize_35.f90 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_35.f90 @@ -0,0 +1,48 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } +! PR 94361 - this left open some memory leaks. Original test case by +! Antony Lewis. + +module debug + private + + Type TypeWithFinal + contains + FINAL :: finalizer !No leak if this line is commented + end type TypeWithFinal + + Type Tester + real, dimension(:), allocatable :: Dat + Type(TypeWithFinal) :: X + end Type Tester + + Type :: TestType2 + Type(Tester) :: T + end type TestType2 + public Leaker +contains + + subroutine Leaker + type(TestType2) :: Test + + allocate(Test%T%Dat(1000)) + end subroutine Leaker + + subroutine finalizer(this) + Type(TypeWithFinal) :: this + end subroutine finalizer + +end module debug + + +program run + use debug + implicit none + integer i + + do i=1, 1000 + call Leaker() + end do + +end program run +! { dg-final { scan-tree-dump-times "__builtin_free\\ \\(ptr2" 2 "original" } } diff --git a/Fortran/gfortran/regression/finalize_36.f90 b/Fortran/gfortran/regression/finalize_36.f90 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_36.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } +! PR 94109 +! This used to leak memory. Test case by Antony Lewis. + module debug + implicit none + + Type Tester + real, dimension(:), allocatable :: Dat, Dat2 + end Type + + Type TestType2 + Type(Tester) :: T + end type TestType2 + + contains + + subroutine Leaker + class(TestType2), pointer :: ActiveState + Type(Tester) :: Temp + + allocate(Temp%Dat2(10000)) + + allocate(TestType2::ActiveState) + ActiveState%T = Temp + deallocate(ActiveState) + + end subroutine + + end module + + + program run + use debug + + call Leaker() + + end program +! { dg-final { scan-tree-dump-times "__builtin_free\\ \\(ptr2" 4 "original" } } diff --git a/Fortran/gfortran/regression/finalize_37.f90 b/Fortran/gfortran/regression/finalize_37.f90 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_37.f90 @@ -0,0 +1,80 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } +! +! PR fortran/92587 +! + +module m + implicit none (type, external) + type t2 + contains + final :: fini + end type + type t3 + type(t2) :: a + end type + type, extends(t3) :: t4 + end type + class(t4), allocatable :: y + class(t4), allocatable :: z + integer :: fini_cnt = 0 +contains + subroutine sub + y = z + end + subroutine fini(x) + type(t2) :: x + fini_cnt = fini_cnt + 1 + end +end + +module m2 + use m + implicit none (type, external) + type, extends(t3) :: t5 + end type + type, extends(t3) :: t6 + contains + final :: fin2 + end type + integer :: fin2_cnt = 0 +contains + subroutine bar(x, y, z) + class(t4), allocatable, intent(out) :: x + class(t5), allocatable, intent(out) :: y + class(t6), allocatable, intent(out) :: z + end + subroutine fin2 (x) + type(t6) :: x + fin2_cnt = fin2_cnt + 1 + end +end + + use m + use m2 + implicit none (type, external) + class(t4), allocatable :: x2 + class(t5), allocatable :: y2 + class(t6), allocatable :: z2 + + if (fini_cnt /= 0 .or. fin2_cnt /= 0) stop 1 + call bar (x2, y2, z2) + if (fini_cnt /= 0 .or. fin2_cnt /= 0) stop 2 + if (allocated(x2) .or. allocated(y2) .or. allocated(z2)) stop 3 + + allocate(t4 :: x2) + allocate(t5 :: y2) + allocate(t6 :: z2) + call bar (x2, y2, z2) + if (fini_cnt /= 3 .or. fin2_cnt /= 1) stop 4 + if (allocated(x2) .or. allocated(y2) .or. allocated(z2)) stop 5 + + allocate(t6 :: z2) + call bar (x2, y2, z2) + if (fini_cnt /= 4 .or. fin2_cnt /= 2) stop 6 + if (allocated(x2) .or. allocated(y2) .or. allocated(z2)) stop 7 +end + +! { dg-final { scan-tree-dump "__final_m_T2 \\\(struct" "original" } } +! { dg-final { scan-tree-dump "__final_m_T3 \\\(struct" "original" } } +! { dg-final { scan-tree-dump "__final_m2_T6 \\\(struct" "original" } } diff --git a/Fortran/gfortran/regression/finalize_4.f03 b/Fortran/gfortran/regression/finalize_4.f03 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_4.f03 @@ -0,0 +1,50 @@ +! { dg-do compile } + +! Parsing of finalizer procedure definitions. +! Check parsing of valid finalizer definitions. + +MODULE final_type + IMPLICIT NONE + + TYPE :: mytype + INTEGER, ALLOCATABLE :: fooarr(:) + REAL :: foobar + CONTAINS + FINAL :: finalize_single + FINAL finalize_vector, finalize_matrix + ! TODO: Test with different kind type parameters once they are implemented. + END TYPE mytype + +CONTAINS + + ELEMENTAL SUBROUTINE finalize_single (el) + IMPLICIT NONE + TYPE(mytype), INTENT(IN) :: el + ! Do nothing in this test + END SUBROUTINE finalize_single + + SUBROUTINE finalize_vector (el) + IMPLICIT NONE + TYPE(mytype), INTENT(INOUT) :: el(:) + ! Do nothing in this test + END SUBROUTINE finalize_vector + + SUBROUTINE finalize_matrix (el) + IMPLICIT NONE + TYPE(mytype) :: el(:, :) + ! Do nothing in this test + END SUBROUTINE finalize_matrix + +END MODULE final_type + +PROGRAM finalizer + USE final_type, ONLY: mytype + IMPLICIT NONE + + TYPE(mytype) :: el, vec(42) + TYPE(mytype), ALLOCATABLE :: mat(:, :) + + ALLOCATE(mat(2, 3)) + DEALLOCATE(mat) + +END PROGRAM finalizer diff --git a/Fortran/gfortran/regression/finalize_5.f03 b/Fortran/gfortran/regression/finalize_5.f03 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_5.f03 @@ -0,0 +1,109 @@ +! { dg-do compile } + +! Parsing of finalizer procedure definitions. +! Check for appropriate errors on invalid final procedures. + +MODULE final_type + IMPLICIT NONE + + TYPE :: mytype + INTEGER, ALLOCATABLE :: fooarr(:) + REAL :: foobar + FINAL :: finalize_matrix ! { dg-error "must be inside a derived type" } + CONTAINS + FINAL :: ! { dg-error "Empty FINAL" } + FINAL ! { dg-error "Empty FINAL" } + FINAL :: + ! { dg-error "Expected module procedure name" } + FINAL :: iamnot ! { dg-error "is not a SUBROUTINE" } + FINAL :: finalize_single finalize_vector ! { dg-error "Expected ','" } + FINAL :: finalize_single, finalize_vector + FINAL :: finalize_single ! { dg-error "is already defined" } + FINAL :: finalize_vector_2 ! { dg-error "has the same rank" } + FINAL :: finalize_single_2 ! { dg-error "has the same rank" } + FINAL :: bad_function ! { dg-error "is not a SUBROUTINE" } + FINAL bad_num_args_1 ! { dg-error "must have exactly one argument" } + FINAL bad_num_args_2 ! { dg-error "must have exactly one argument" } + FINAL bad_arg_type + FINAL :: bad_pointer + FINAL :: bad_alloc + FINAL :: bad_optional + FINAL :: bad_intent_out + + ! TODO: Test for polymorphism, kind parameters once those are implemented. + END TYPE mytype + +CONTAINS + + SUBROUTINE finalize_single (el) + IMPLICIT NONE + TYPE(mytype) :: el + END SUBROUTINE finalize_single + + ELEMENTAL SUBROUTINE finalize_single_2 (el) + IMPLICIT NONE + TYPE(mytype), INTENT(IN) :: el + END SUBROUTINE finalize_single_2 + + SUBROUTINE finalize_vector (el) + IMPLICIT NONE + TYPE(mytype), INTENT(INOUT) :: el(:) + END SUBROUTINE finalize_vector + + SUBROUTINE finalize_vector_2 (el) + IMPLICIT NONE + TYPE(mytype), INTENT(IN) :: el(:) + END SUBROUTINE finalize_vector_2 + + SUBROUTINE finalize_matrix (el) + IMPLICIT NONE + TYPE(mytype) :: el(:, :) + END SUBROUTINE finalize_matrix + + INTEGER FUNCTION bad_function (el) + IMPLICIT NONE + TYPE(mytype) :: el + + bad_function = 42 + END FUNCTION bad_function + + SUBROUTINE bad_num_args_1 () + IMPLICIT NONE + END SUBROUTINE bad_num_args_1 + + SUBROUTINE bad_num_args_2 (el, x) + IMPLICIT NONE + TYPE(mytype) :: el + COMPLEX :: x + END SUBROUTINE bad_num_args_2 + + SUBROUTINE bad_arg_type (el) ! { dg-error "must be of type 'mytype'" } + IMPLICIT NONE + REAL :: el + END SUBROUTINE bad_arg_type + + SUBROUTINE bad_pointer (el) ! { dg-error "must not be a POINTER" } + IMPLICIT NONE + TYPE(mytype), POINTER :: el + END SUBROUTINE bad_pointer + + SUBROUTINE bad_alloc (el) ! { dg-error "must not be ALLOCATABLE" } + IMPLICIT NONE + TYPE(mytype), ALLOCATABLE :: el(:) + END SUBROUTINE bad_alloc + + SUBROUTINE bad_optional (el) ! { dg-error "must not be OPTIONAL" } + IMPLICIT NONE + TYPE(mytype), OPTIONAL :: el + END SUBROUTINE bad_optional + + SUBROUTINE bad_intent_out (el) ! { dg-error "must not be INTENT\\(OUT\\)" } + IMPLICIT NONE + TYPE(mytype), INTENT(OUT) :: el + END SUBROUTINE bad_intent_out + +END MODULE final_type + +PROGRAM finalizer + IMPLICIT NONE + ! Nothing here, errors above +END PROGRAM finalizer diff --git a/Fortran/gfortran/regression/finalize_6.f90 b/Fortran/gfortran/regression/finalize_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_6.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! { dg-options "-std=f95" } + +! Parsing of finalizer procedure definitions. +! Check that CONTAINS/FINAL in derived types is rejected for F95. + +MODULE final_type + IMPLICIT NONE + + TYPE :: mytype + INTEGER :: fooarr(42) + REAL :: foobar + CONTAINS ! { dg-error "Fortran 2003: CONTAINS block in derived type definition" } + FINAL :: finalize_single ! { dg-error "Fortran 2003: FINAL procedure declaration|FINAL procedure 'finalize_single' at .1. is not a SUBROUTINE" } + END TYPE mytype ! { dg-error "Fortran 2008: Derived type definition at .1. with empty CONTAINS section" } + +CONTAINS + + SUBROUTINE finalize_single (el) + IMPLICIT NONE + TYPE(mytype) :: el + ! Do nothing in this test + END SUBROUTINE finalize_single + +END MODULE final_type + +PROGRAM finalizer + IMPLICIT NONE + ! Do nothing +END PROGRAM finalizer diff --git a/Fortran/gfortran/regression/finalize_7.f03 b/Fortran/gfortran/regression/finalize_7.f03 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_7.f03 @@ -0,0 +1,54 @@ +! { dg-do compile } +! { dg-options "-Wsurprising" } + +! Implementation of finalizer procedures. +! Check for expected warnings on dubious FINAL constructs. + +MODULE final_type + IMPLICIT NONE + + TYPE :: type_1 + INTEGER, ALLOCATABLE :: fooarr(:) + REAL :: foobar + CONTAINS + ! Non-scalar procedures should be assumed shape + FINAL :: fin1_scalar + FINAL :: fin1_shape_1 + FINAL :: fin1_shape_2 + END TYPE type_1 + + TYPE :: type_2 ! { dg-warning "Only array FINAL procedures" } + REAL :: x + CONTAINS + ! No scalar finalizer, only array ones + FINAL :: fin2_vector + END TYPE type_2 + +CONTAINS + + SUBROUTINE fin1_scalar (el) + IMPLICIT NONE + TYPE(type_1) :: el + END SUBROUTINE fin1_scalar + + SUBROUTINE fin1_shape_1 (v) ! { dg-warning "assumed shape" } + IMPLICIT NONE + TYPE(type_1) :: v(*) + END SUBROUTINE fin1_shape_1 + + SUBROUTINE fin1_shape_2 (v) ! { dg-warning "assumed shape" } + IMPLICIT NONE + TYPE(type_1) :: v(42, 5) + END SUBROUTINE fin1_shape_2 + + SUBROUTINE fin2_vector (v) + IMPLICIT NONE + TYPE(type_2) :: v(:) + END SUBROUTINE fin2_vector + +END MODULE final_type + +PROGRAM finalizer + IMPLICIT NONE + ! Nothing here +END PROGRAM finalizer diff --git a/Fortran/gfortran/regression/finalize_8.f03 b/Fortran/gfortran/regression/finalize_8.f03 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_8.f03 @@ -0,0 +1,35 @@ +! { dg-do compile } + +! Parsing of finalizer procedure definitions. +! Check that FINAL-declarations are only allowed on types defined in the +! specification part of a module. + +MODULE final_type + IMPLICIT NONE + +CONTAINS + + SUBROUTINE bar + IMPLICIT NONE + + TYPE :: mytype + INTEGER, ALLOCATABLE :: fooarr(:) + REAL :: foobar + CONTAINS + FINAL :: myfinal ! { dg-error "in the specification part of a MODULE" } + END TYPE mytype + + CONTAINS + + SUBROUTINE myfinal (el) + TYPE(mytype) :: el + END SUBROUTINE myfinal + + END SUBROUTINE bar + +END MODULE final_type + +PROGRAM finalizer + IMPLICIT NONE + ! Do nothing here +END PROGRAM finalizer diff --git a/Fortran/gfortran/regression/finalize_9.f90 b/Fortran/gfortran/regression/finalize_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/finalize_9.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! +! PR 43244: Invalid statement misinterpreted as FINAL declaration +! +! Contributed by Janus Weil + +implicit none +type particle + integer :: ID +end type +type(particle), dimension(1,1:3) :: finalState +finalstate(1,(/1:2/))%ID = (/1,103/) ! { dg-error "Syntax error in array constructor" } +end diff --git a/Fortran/gfortran/regression/findloc_1.f90 b/Fortran/gfortran/regression/findloc_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/findloc_1.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! Test errors in findloc. +program main + integer, dimension(4) :: a + logical, dimension(3) :: msk + a = [2,4,6,8] + print *,findloc(a) ! { dg-error "Missing actual argument" } + print *,findloc(a,value=.true.) ! { dg-error "must be in type conformance to argument" } + print *,findloc(a,23,dim=6) ! { dg-error "is not a valid dimension index" } + print *,findloc(a,-42,dim=2.0) ! { dg-error "must be INTEGER" } + print *,findloc(a,6,msk) ! { dg-error "Different shape for arguments 'array' and 'mask'" } + print *,findloc(a,6,kind=98) ! { dg-error "Invalid kind for INTEGER" } +end program main diff --git a/Fortran/gfortran/regression/findloc_2.f90 b/Fortran/gfortran/regression/findloc_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/findloc_2.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! Various tests with findloc. +program main + implicit none + real, dimension(2,2) :: a, b + integer, dimension(2,3) :: c + logical, dimension(2,2) :: lo + integer, dimension(:), allocatable :: e + a = reshape([1.,2.,3.,4.], shape(a)) + b = reshape([1.,2.,1.,2.], shape(b)) + + lo = .true. + + if (any(findloc(a, 5.) /= [0,0])) stop 1 + if (any(findloc(a, 5., back=.true.) /= [0,0])) stop 2 + if (any(findloc(a, 2.) /= [2,1])) stop 2 + if (any(findloc(a, 2. ,back=.true.) /= [2,1])) stop 3 + + if (any(findloc(a,3.,mask=lo) /= [1,2])) stop 4 + if (any(findloc(a,3,mask=.true.) /= [1,2])) stop 5 + lo(1,2) = .false. + if (any(findloc(a,3.,mask=lo) /= [0,0])) stop 6 + if (any(findloc(b,2.) /= [2,1])) stop 7 + if (any(findloc(b,2.,back=.true.) /= [2,2])) stop 8 + if (any(findloc(b,1.,mask=lo,back=.true.) /= [1,1])) stop 9 + if (any(findloc(b,1.,mask=.false.) /= [0,0])) stop 10 + + c = reshape([1,2,2,2,-9,6], shape(c)) + if (any(findloc(c,value=2,dim=1) /= [2,1,0])) stop 11 + if (any(findloc(c,value=2,dim=2) /= [2,1])) stop 12 +end program main diff --git a/Fortran/gfortran/regression/findloc_3.f90 b/Fortran/gfortran/regression/findloc_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/findloc_3.f90 @@ -0,0 +1,77 @@ +! { dg-do run } +! Various tests with findloc with character variables. +program main + character(len=2) :: a(3,3), c(3,3), d(3,4) + character(len=3) :: b(3,3) + integer :: ret(2) + integer :: i,j + character(len=3) :: s + logical :: lo + logical, dimension(3,4) :: msk + data a /"11", "21", "31", "12", "22", "32", "13", "23", "33" / + data b /"11 ", "21 ", "31 ", "12 ", "22 ", "32 ", "13 ", "23 ", "33 " / + if (any(findloc(a,"11 ") /= [1,1])) stop 1 + ret = findloc(b,"31") + do j=1,3 + do i=1,3 + write(unit=s,fmt='(2I1," ")') i,j + ret = findloc(b,s) + if (b(ret(1),ret(2)) /= s) stop 2 + end do + end do + + if (any(findloc(b(::2,::2),"13") /= [1,2])) stop 3 + + do j=1,3 + do i=1,3 + write(unit=c(i,j),fmt='(I2)') 2+i-j + end do + end do + + if (any(findloc(c," 1") /= [1,2])) stop 4 + if (any(findloc(c," 1", back=.true.) /= [2,3])) stop 5 + if (any(findloc(c," 1", back=.true., mask=.false.) /= [0,0])) stop 6 + + lo = .true. + if (any(findloc(c," 2", dim=1) /= [1,2,3])) stop 7 + if (any(findloc(c," 2",dim=1,mask=lo) /= [1,2,3])) stop 8 + + if (any(findloc(c," 2", dim=1,back=.true.) /= [1,2,3])) stop 9 + if (any(findloc(c," 2",dim=1,mask=lo,back=.true.) /= [1,2,3])) stop 10 + do j=1,4 + do i=1,3 + if (j<= i) then + d(i,j) = "AA" + else + d(i,j) = "BB" + end if + end do + end do + print '(4A3)', transpose(d) + if (any(findloc(d,"AA") /= [1,1])) stop 11 + if (any(findloc(d,"BB") /= [1,2])) stop 12 + msk = .true. + if (any(findloc(d,"AA", mask=msk) /= [1,1])) stop 11 + if (any(findloc(d,"BB", mask=msk) /= [1,2])) stop 12 + if (any(findloc(d,"AA", dim=1) /= [1,2,3,0])) stop 13 + if (any(findloc(d,"BB", dim=1) /= [0,1,1,1])) stop 14 + if (any(findloc(d,"AA", dim=2) /= [1,1,1])) stop 15 + if (any(findloc(d,"BB", dim=2) /= [2,3,4])) stop 16 + if (any(findloc(d,"AA", dim=1,mask=msk) /= [1,2,3,0])) stop 17 + if (any(findloc(d,"BB", dim=1,mask=msk) /= [0,1,1,1])) stop 18 + if (any(findloc(d,"AA", dim=2,mask=msk) /= [1,1,1])) stop 19 + if (any(findloc(d,"BB", dim=2,mask=msk) /= [2,3,4])) stop 20 + + if (any(findloc(d,"AA", dim=1, back=.true.) /= [3,3,3,0])) stop 21 + if (any(findloc(d,"AA", dim=1, back=.true., mask=msk) /= [3,3,3,0])) stop 22 + if (any(findloc(d,"BB", dim=2, back=.true.) /= [4,4,4])) stop 23 + if (any(findloc(d,"BB", dim=2, back=.true.,mask=msk) /= [4,4,4])) stop 24 + + msk(1,:) = .false. + print '(4L3)', transpose(msk) + if (any(findloc(d,"AA", dim=1,mask=msk) /= [2,2,3,0])) stop 21 + if (any(findloc(d,"BB", dim=2,mask=msk) /= [0,3,4])) stop 22 + if (any(findloc(d,"AA", dim=2, mask=msk, back=.true.) /= [0,2,3])) stop 23 + if (any(findloc(d,"AA", dim=1, mask=msk, back=.true.) /= [3,3,3,0])) stop 24 + +end program main diff --git a/Fortran/gfortran/regression/findloc_4.f90 b/Fortran/gfortran/regression/findloc_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/findloc_4.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! Test findloc with dim argument. + +program main + implicit none + real, dimension(2,2) :: a, b + logical, dimension(2,2) :: lo + a = reshape([1.,2.,3.,4.], shape(a)) + b = reshape([1.,1.,1.,1.], shape(b)) + + lo = .true. + + if (any(findloc(b,value=1.,dim=1) /= [1,1])) stop 1 + if (any(findloc(b,value=1.,dim=2) /= [1,1])) stop 2 + if (any(findloc(b,value=1.,dim=1,back=.true.) /= [2,2])) stop 3 + if (any(findloc(b,value=1.,dim=2,back=.true.) /= [2,2])) stop 4 + if (any(findloc(b,value=1.,dim=1,mask=lo) /= [1,1])) stop 5 + + if (any(findloc(b,value=1.,dim=1,mask=lo,back=.true.) /= [2,2])) stop 6 + if (any(findloc(b,value=1.,dim=1,mask=.not. lo) /= [0,0])) stop 7 + lo(1,1) = .false. + if (any(findloc(b,value=1.,dim=1,mask=lo) /= [2,1])) stop 8 + if (any(findloc(a,value=1.5,dim=2,back=.true.) /= [0,0])) stop 9 + if (any(findloc(a,value=1,dim=1,mask=lo) /= [0,0])) stop 10 +end program main diff --git a/Fortran/gfortran/regression/findloc_5.f90 b/Fortran/gfortran/regression/findloc_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/findloc_5.f90 @@ -0,0 +1,47 @@ +! { dg-do run } +! Check compile-time simplification of FINDLOC +program main + integer, dimension(4), parameter :: a1 = [1, 2, 3, 1] + integer, parameter :: i1 = findloc(a1, 1, dim=1) + integer, parameter :: i2 = findloc(a1, 2, dim=1) + integer, parameter :: i3 = findloc(a1, 3, dim=1) + integer, parameter :: i4 = findloc(a1, 1, dim=1, back=.true.) + integer, parameter :: i0 = findloc(a1, -1, dim=1) + logical, dimension(4), parameter :: msk = [.false., .true., .true., .true.] + integer, parameter :: i4a = findloc(a1, 1, dim=1, mask=msk) + integer, parameter :: i4b = findloc(a1, 1, dim=1, mask=msk, back=.true.) + real, dimension(2,2), parameter :: a = reshape([1.,2.,3.,4.], [2,2]), & + b = reshape([1.,2.,1.,2.], [2,2]) + integer, parameter, dimension(2) :: t8 = findloc(a, 5.), t9 = findloc(a, 5., back=.true.) + integer, parameter, dimension(2) :: t10= findloc(a, 2.), t11= findloc(a, 2., back=.true.) + logical, dimension(2,2), parameter :: lo = reshape([.true., .false., .true., .true. ], [2,2]) + integer, parameter, dimension(2) :: t12 = findloc(b,2., mask=lo) + + integer, dimension(2,3), parameter :: c = reshape([1,2,2,2,-9,6], [2,3]) + integer, parameter, dimension(3) :: t13 = findloc(c, value=2, dim=1) + integer, parameter, dimension(2) :: t14 = findloc(c, value=2, dim=2) + + character(len=2), dimension(3,3), parameter :: ac = reshape ( & + ["11", "21", "31", "12", "22", "32", "13", "23", "33"], [3,3]); + character(len=3), dimension(3,3), parameter :: bc = reshape (& + ["11 ", "21 ", "31 ", "12 ", "22 ", "32 ", "13 ", "23 ", "33 "], [3,3]); + integer, parameter, dimension(2) :: t15 = findloc(ac, "11") + integer, parameter, dimension(2) :: t16 = findloc(bc, "31") + + if (i1 /= 1) stop 1 + if (i2 /= 2) stop 2 + if (i3 /= 3) stop 3 + if (i4 /= 4) stop 4 + if (i0 /= 0) stop 5 + if (i4a /= 4) stop 6 + if (i4b /= 4) stop 7 + if (any(t8 /= [0,0])) stop 8 + if (any(t9 /= [0,0])) stop 9 + if (any(t10 /= [2,1])) stop 10 + if (any(t11 /= [2,1])) stop 11 + if (any(t12 /= [2,2])) stop 12 + if (any(t13 /= [2,1,0])) stop 13 + if (any(t14 /= [2,1])) stop 14 + if (any(t15 /= [1,1])) stop 15 + if (any(t16 /= [3,1])) stop 16 +end program main diff --git a/Fortran/gfortran/regression/findloc_6.f90 b/Fortran/gfortran/regression/findloc_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/findloc_6.f90 @@ -0,0 +1,53 @@ +! { dg-do run } +! Test different code paths for findloc with scalar result. + +program main + integer, dimension(0:5) :: a = [1,2,3,1,2,3] + logical, dimension(6) :: mask = [.false.,.false.,.false.,.true.,.true.,.true.] + logical, dimension(6) :: mask2 + logical :: true, false + character(len=2), dimension(6) :: ch = ["AA", "BB", "CC", "AA", "BB", "CC"] + + true = .true. + false = .false. + mask2 = .not. mask + +! Tests without mask + + if (findloc(a,2,dim=1,back=false) /= 2) stop 1 + if (findloc(a,2,dim=1,back=.false.) /= 2) stop 2 + if (findloc(a,2,dim=1) /= 2) stop 3 + if (findloc(a,2,dim=1,back=.true.) /= 5) stop 4 + if (findloc(a,2,dim=1,back=true) /= 5) stop 5 + +! Test with array mask + if (findloc(a,2,dim=1,mask=mask) /= 5) stop 6 + if (findloc(a,2,dim=1,mask=mask,back=.true.) /= 5) stop 7 + if (findloc(a,2,dim=1,mask=mask,back=.false.) /= 5) stop 8 + if (findloc(a,2,dim=1,mask=mask2) /= 2) stop 9 + if (findloc(a,2,dim=1,mask=mask2,back=.true.) /= 2) stop 10 + if (findloc(a,2,dim=1,mask=mask2,back=true) /= 2) stop 11 + +! Test with scalar mask + + if (findloc(a,2,dim=1,mask=.true.) /= 2) stop 12 + if (findloc(a,2,dim=1,mask=.false.) /= 0) stop 13 + if (findloc(a,2,dim=1,mask=true) /= 2) stop 14 + if (findloc(a,2,dim=1,mask=false) /= 0) stop 15 + +! Some character tests + + if (findloc(ch,"AA",dim=1) /= 1) stop 16 + if (findloc(ch,"AA",dim=1,mask=mask) /= 4) stop 17 + if (findloc(ch,"AA",dim=1,back=.true.) /= 4) stop 18 + if (findloc(ch,"AA",dim=1,mask=mask2,back=.true.) /= 1) stop 19 + +! Nothing to be found here... + if (findloc(ch,"DD",dim=1) /= 0) stop 20 + if (findloc(a,4,dim=1) /= 0) stop 21 + +! Finally, character tests with a scalar mask. + + if (findloc(ch,"CC ",dim=1,mask=true) /= 3) stop 22 + if (findloc(ch,"CC ",dim=1,mask=false) /= 0) stop 23 +end program main diff --git a/Fortran/gfortran/regression/findloc_7.f90 b/Fortran/gfortran/regression/findloc_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/findloc_7.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! This used to ICE with an infinite recursion during development. +! Test case by Dominique d'Humieres. + +program logtest3 + implicit none + logical :: x = .true. + integer, parameter :: I_FINDLOC_BACK(1) = findloc([1,1],1, back=x) ! { dg-error "does not reduce to a constant expression" } +end program logtest3 diff --git a/Fortran/gfortran/regression/findloc_8.f90 b/Fortran/gfortran/regression/findloc_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/findloc_8.f90 @@ -0,0 +1,29 @@ +! PR libfortran/95390 +! { dg-do run { target fortran_real_10 } } + + complex(kind=10) :: a(6), b, d(2,2) + logical :: m(6), n, o(2,2) + integer :: c(1), e(2) + a = (/ 1., 2., 17., 2., 2., 6. /) + b = 17. + c = findloc (a, b) + if (c(1) /= 3) stop 1 + m = (/ .true., .false., .true., .true., .true., .true. /) + n = .true. + b = 2. + c = findloc (a, b, m) + if (c(1) /= 4) stop 2 + c = findloc (a, b, n) + if (c(1) /= 2) stop 3 + d = reshape((/ 1., 2., 2., 3. /), (/ 2, 2 /)) + e = findloc (d, b, 1) + if (e(1) /= 2 .or. e(2) /= 1) stop 4 + o = reshape((/ .true., .false., .true., .true. /), (/ 2, 2 /)) + e = findloc (d, b, 1, o) + if (e(1) /= 0 .or. e(2) /= 1) stop 5 + e = findloc (d, b, 1, n) + if (e(1) /= 2 .or. e(2) /= 1) stop 6 + n = .false. + e = findloc (d, b, 1, n) + if (e(1) /= 0 .or. e(2) /= 0) stop 7 +end diff --git a/Fortran/gfortran/regression/float_1.f90 b/Fortran/gfortran/regression/float_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/float_1.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! PR fortran/26816 +program test_float + integer(1) :: i1 = 1 + integer(2) :: i2 = 1 + integer(4) :: i4 = 1 + integer(8) :: i8 = 1 + if (float(i1) /= 1.) STOP 1! { dg-warning "non-default INTEGER" } + if (float(i2) /= 1.) STOP 2! { dg-warning "non-default INTEGER" } + if (float(i4) /= 1.) STOP 3 + if (float(i8) /= 1.) STOP 4! { dg-warning "non-default INTEGER" } + + if (kind(float(i4)) /= kind(1.0)) STOP 5 + if (kind(float(i8)) /= kind(1.0)) STOP 6! { dg-warning "non-default INTEGER" } +end program test_float diff --git a/Fortran/gfortran/regression/flush_1.f90 b/Fortran/gfortran/regression/flush_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/flush_1.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! PR 22390 Implement flush statement +program flush_1 + + character(len=256) msg + integer ios + + open (unit=10, access='SEQUENTIAL', status='SCRATCH') + + write (10, *) 42 + flush 10 + + write (10, *) 42 + flush(10) + + write (10, *) 42 + flush(unit=10, iostat=ios) + if (ios /= 0) STOP 1 + + write (10, *) 42 + flush (unit=10, err=20) + goto 30 +20 STOP 2 +30 continue + + call flush(10) + +end program flush_1 diff --git a/Fortran/gfortran/regression/fmt_bz_bn.f b/Fortran/gfortran/regression/fmt_bz_bn.f --- /dev/null +++ b/Fortran/gfortran/regression/fmt_bz_bn.f @@ -0,0 +1,27 @@ +c { dg-do run } +c PR38097 I/O with blanks in exponent fails; BN edit descriptor +c Test case derived from reporter. + character(11) :: a = ' 2. 3 e+ 3' + character(11) :: b = ' 2.003 e+ 3' + character(11) :: c = ' 2.002 e+1 ' + real :: f + + f = 0.0 + read (a,'(BZ,E11.0)') f + if (f .ne. 2003.0) STOP 1 + f = 0.0 + read (a,'(BN,E11.0)') f + if (f .ne. 2300.0) STOP 2 + f = 0.0 + read (b,'(BN,E11.0)') f + if (f .ne. 2003.0) STOP 3 + f = 0.0 + read (c,'(E11.0)') f + if (f .ne. 20.020) STOP 4 + f = 0.0 + read (c,'(BZ,E11.0)') f + if (f .ne. 2.002e10) STOP 5 + + end +c end of program + diff --git a/Fortran/gfortran/regression/fmt_bz_bn_err.f b/Fortran/gfortran/regression/fmt_bz_bn_err.f --- /dev/null +++ b/Fortran/gfortran/regression/fmt_bz_bn_err.f @@ -0,0 +1,17 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR38772 r143102 reveals missed error checking on floating point reads. +! Test case contributed by Jack Howarth. + program badread + implicit none + double precision r + character*20 temp + logical ok + temp=' end' + r = 3.14159d0 + ok=.true. + read(temp,'(f20.0)',err=8888) r + STOP 1 +8888 continue + end diff --git a/Fortran/gfortran/regression/fmt_cache_1.f b/Fortran/gfortran/regression/fmt_cache_1.f --- /dev/null +++ b/Fortran/gfortran/regression/fmt_cache_1.f @@ -0,0 +1,34 @@ +! { dg-do run { target fd_truncate } } +! pr40662 segfaults when specific format is invoked twice. +! pr40330 incorrect io. +! test case derived from pr40662, + program astap + implicit none + character(34) :: teststring + real(4) :: arlxca = 0.0 + open(10) + write(10,40) arlxca + write(10,40) arlxca +40 format(t4,"arlxca = ",1pg13.6,t27,"arlxcc = ",g13.6,t53, + . "atmpca = ",g13.6,t79,"atmpcc = ",g13.6,t105, + . "backup = ",g13.6,/, + . t4,"csgfac = ",g13.6,t27,"csgmax = ",g13.6,t53, + . "csgmin = ",g13.6,t79,"drlxca = ",g13.6,t105, + . "drlxcc = ",g13.6,/, + . t4,"dtimeh = ",g13.6,t27,"dtimei = ",g13.6,t53, + . "dtimel = ",g13.6,t79,"dtimeu = ",g13.6,t105, + . "dtmpca = ",g13.6,/, + . t4,"dtmpcc = ",g13.6,t27,"ebalna = ",g13.6,t53, + . "ebalnc = ",g13.6,t79,"ebalsa = ",g13.6,t105, + . "ebalsc = ",g13.6) + rewind 10 + teststring = "" + read(10,'(a)') teststring + if (teststring.ne." arlxca = 0.00000 arlxcc =")STOP 1 + teststring = "" + read(10,'(a)') teststring + if (teststring.ne." arlxca = 0.00000 arlxcc =")STOP 2 + close(10, status='delete') + end program astap + + diff --git a/Fortran/gfortran/regression/fmt_cache_2.f b/Fortran/gfortran/regression/fmt_cache_2.f --- /dev/null +++ b/Fortran/gfortran/regression/fmt_cache_2.f @@ -0,0 +1,36 @@ +! { dg-do run } +! PR42742 Handle very large format strings correctly +! Test derived from example developed by Manfred Schwarb. + character(12) bufarr(74) + character(74*13+30) fmtstr,fmtstr2 + character(1) delim + integer i,j,dat(5),pindx, loopcounter + character(983) big_string ! any less and this test fails. + + do i=1,74 + write(bufarr(i),'(i12)') i + enddo + + delim=" " + dat(1)=2009 + dat(2)=10 + dat(3)=31 + dat(4)=3 + dat(5)=0 + fmtstr="(i2,i6,4(a1,i2.2)" + open(10, status="scratch") + do j=1,74 + fmtstr=fmtstr(1:len_trim(fmtstr))//",a1,a12" + fmtstr2=fmtstr(1:len_trim(fmtstr))//")" +c write(0,*) "interation ",j,": ",len_trim(fmtstr2) + do i=1,10 + write(10,fmtstr2) + & i,dat(1),"-",dat(2),"-",dat(3), + & delim,dat(4),":",dat(5), + & (delim,bufarr(pindx),pindx=1,j) + enddo + loopcounter = j + enddo + close(10) + if (loopcounter /= 74) STOP 1 + end diff --git a/Fortran/gfortran/regression/fmt_cache_3.f90 b/Fortran/gfortran/regression/fmt_cache_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_cache_3.f90 @@ -0,0 +1,80 @@ +! { dg-do run } +! +! PR fortran/56737 +! +! Contributed by Jonathan Hogg +! +module hsl_mc73_single + implicit none + integer, parameter, private :: wp = kind(0.0) +contains + subroutine mc73_fiedler(n,lirn,irn,ip,list) + integer, intent (in) :: n + integer, intent (in) :: lirn + integer, intent (in) :: irn(*) + integer, intent (in) :: ip(*) + integer, intent (out) :: list(*) + + integer :: icntl(10) + + call fiedler_graph(icntl) + end subroutine mc73_fiedler + + subroutine mc73_order + integer :: icntl(10) + + call fiedler_graph(icntl) + end subroutine mc73_order + + subroutine fiedler_graph(icntl) + integer, intent (in) :: icntl(10) + + real (kind = wp) :: tol + real (kind = wp) :: tol1 + real (kind = wp) :: rtol + + call multilevel_eig(tol,tol1,rtol,icntl) + end subroutine fiedler_graph + + subroutine multilevel_eig(tol,tol1,rtol,icntl) + real (kind = wp), intent (in) :: tol,tol1,rtol + integer, intent(in) :: icntl(10) + + call level_print(6,'end of level ',1) + end subroutine multilevel_eig + + subroutine level_print(mp,title1,level) + character (len = *), intent(in) :: title1 + integer, intent(in) :: mp,level + character(len=80) fmt + integer :: char_len1,char_len2 + + char_len1=len_trim(title1) + + write (fmt,"('(',i4,'(1H ),6h===== ,a',i4,',i4,6h =====)')") & + level*3, char_len1 +! print *, "fmt = ", fmt +! print *, "title1= ", title1 +! print *, "level = ", level + write (66,fmt) title1,level + end subroutine level_print +end module hsl_mc73_single + +program test + use hsl_mc73_single + implicit none + character(len=200) :: str(2) + integer, parameter :: wp = kind(0.0) + + integer :: n, lirn + integer :: irn(1), ip(1), list(1) + + str = "" + open (66, status='scratch') + call mc73_order + call mc73_fiedler(n,lirn,irn,ip,list) + rewind (66) + read (66, '(a)') str + close (66) + if (any (str /= " ===== end of level 1 =====")) STOP 1 +end program test diff --git a/Fortran/gfortran/regression/fmt_colon.f90 b/Fortran/gfortran/regression/fmt_colon.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_colon.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! PR31395 Colon edit descriptor is ignored. +! Test case derived from PR. Prepared by Jerry DeLisle +! +PROGRAM test + INTEGER :: i = 1 + character(30) :: astring + WRITE(astring, 10) i + 10 FORMAT('i =',I2:' this should not print') + if (astring.ne."i = 1") STOP 1 + write(astring, 20) i, i + 20 format('i =',I2:' this should print',I2) + if (astring.ne."i = 1 this should print 1") STOP 2 +END PROGRAM test \ No newline at end of file diff --git a/Fortran/gfortran/regression/fmt_e.f90 b/Fortran/gfortran/regression/fmt_e.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_e.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! PR83811 fortran 'e' format broken for single digit exponents +program test + character(25) :: s + write(s, '(1pe5.0e1)') 1.e-4 + if (s.ne."1.E-4") STOP 1 + write(s, '(e5.1e1)') 1.e12 + if (s.ne."*****") STOP 2 +end + diff --git a/Fortran/gfortran/regression/fmt_en.f90 b/Fortran/gfortran/regression/fmt_en.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_en.f90 @@ -0,0 +1,183 @@ +! { dg-do run { target fd_truncate } } +! PR60128 Invalid outputs with EN descriptors +! Test case provided by Walt Brainerd. +program pr60128 +use ISO_FORTRAN_ENV + implicit none + integer, parameter :: j(size(real_kinds)+4)=[REAL_KINDS, [4, 4, 4, 4]] + logical :: l_skip(4) = .false. + integer :: i + integer :: n_tst = 0, n_cnt = 0, n_skip = 0 + character(len=20) :: s, s1 + +! Check that the default rounding mode is to nearest and to even on tie. + do i=1,size(real_kinds) + if (i == 1) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(1)), & + real(9.49999905,kind=j(1)), & + real(9.5,kind=j(1)), real(8.5,kind=j(1)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(1)), & + real(98765.0,kind=j(1)) + else if (i == 2) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(2)), & + real(9.49999905,kind=j(2)), & + real(9.5,kind=j(2)), real(8.5,kind=j(2)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(2)), & + real(98765.0,kind=j(2)) + else if (i == 3) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(3)), & + real(9.49999905,kind=j(3)), & + real(9.5,kind=j(3)), real(8.5,kind=j(3)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(3)), & + real(98765.0,kind=j(3)) + else if (i == 4) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(4)), & + real(9.49999905,kind=j(4)), & + real(9.5,kind=j(4)), real(8.5,kind=j(4)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(4)), & + real(98765.0,kind=j(4)) + end if + if (s /= '-9.5 9.5 10. 8.' .or. s1 /= ' 987.4E+03 98.76E+03') then + l_skip(i) = .true. +! print "('Unsupported rounding for real(',i0,')')", j(i) + end if + end do + + +! Original test. + call checkfmt("(en15.2)", -.44444, " -444.44E-03") + +! Test for the bug in comment 6. + call checkfmt("(en15.0)", 1.0, " 1.E+00") + call checkfmt("(en15.0)", 1.00000012, " 1.E+00") + call checkfmt("(en15.0)", 0.99999994, " 1.E+00") + call checkfmt("(en15.0)", 10.0, " 10.E+00") + call checkfmt("(en15.0)", 10.0000010, " 10.E+00") + call checkfmt("(en15.0)", 9.99999905, " 10.E+00") + call checkfmt("(en15.0)", 100.0, " 100.E+00") + call checkfmt("(en15.0)", 100.000008, " 100.E+00") + call checkfmt("(en15.0)", 99.9999924, " 100.E+00") + call checkfmt("(en15.0)", 1000.0, " 1.E+03") + call checkfmt("(en15.0)", 1000.00006, " 1.E+03") + call checkfmt("(en15.0)", 999.999939, " 1.E+03") + call checkfmt("(en15.0)", 9.5, " 10.E+00") + call checkfmt("(en15.0)", 9.50000095, " 10.E+00") + call checkfmt("(en15.0)", 9.49999905, " 9.E+00") + call checkfmt("(en15.0)", 99.5, " 100.E+00") + call checkfmt("(en15.0)", 99.5000076, " 100.E+00") + call checkfmt("(en15.0)", 99.4999924, " 99.E+00") + call checkfmt("(en15.0)", 999.5, " 1.E+03") + call checkfmt("(en15.0)", 999.500061, " 1.E+03") + call checkfmt("(en15.0)", 999.499939, " 999.E+00") + call checkfmt("(en15.0)", 9500.0, " 10.E+03") + call checkfmt("(en15.0)", 9500.00098, " 10.E+03") + call checkfmt("(en15.0)", 9499.99902, " 9.E+03") + call checkfmt("(en15.1)", 9950.0, " 10.0E+03") + call checkfmt("(en15.2)", 9995.0, " 10.00E+03") + call checkfmt("(en15.3)", 9999.5, " 10.000E+03") + call checkfmt("(en15.1)", 9.5, " 9.5E+00") + call checkfmt("(en15.1)", 9.50000095, " 9.5E+00") + call checkfmt("(en15.1)", 9.49999905, " 9.5E+00") + call checkfmt("(en15.1)", 0.099951, " 100.0E-03") + call checkfmt("(en15.1)", 0.009951, " 10.0E-03") + call checkfmt("(en15.1)", 0.000999951," 1.0E-03") + + call checkfmt("(en15.0)", -1.0, " -1.E+00") + call checkfmt("(en15.0)", -1.00000012, " -1.E+00") + call checkfmt("(en15.0)", -0.99999994, " -1.E+00") + call checkfmt("(en15.0)", -10.0, " -10.E+00") + call checkfmt("(en15.0)", -10.0000010, " -10.E+00") + call checkfmt("(en15.0)", -9.99999905, " -10.E+00") + call checkfmt("(en15.0)", -100.0, " -100.E+00") + call checkfmt("(en15.0)", -100.000008, " -100.E+00") + call checkfmt("(en15.0)", -99.9999924, " -100.E+00") + call checkfmt("(en15.0)", -1000.0, " -1.E+03") + call checkfmt("(en15.0)", -1000.00006, " -1.E+03") + call checkfmt("(en15.0)", -999.999939, " -1.E+03") + call checkfmt("(en15.0)", -9.5, " -10.E+00") + call checkfmt("(en15.0)", -9.50000095, " -10.E+00") + call checkfmt("(en15.0)", -9.49999905, " -9.E+00") + call checkfmt("(en15.0)", -99.5, " -100.E+00") + call checkfmt("(en15.0)", -99.5000076, " -100.E+00") + call checkfmt("(en15.0)", -99.4999924, " -99.E+00") + call checkfmt("(en15.0)", -999.5, " -1.E+03") + call checkfmt("(en15.0)", -999.500061, " -1.E+03") + call checkfmt("(en15.0)", -999.499939, " -999.E+00") + call checkfmt("(en15.0)", -9500.0, " -10.E+03") + call checkfmt("(en15.0)", -9500.00098, " -10.E+03") + call checkfmt("(en15.0)", -9499.99902, " -9.E+03") + call checkfmt("(en15.1)", -9950.0, " -10.0E+03") + call checkfmt("(en15.2)", -9995.0, " -10.00E+03") + call checkfmt("(en15.3)", -9999.5, " -10.000E+03") + call checkfmt("(en15.1)", -9.5, " -9.5E+00") + call checkfmt("(en15.1)", -9.50000095, " -9.5E+00") + call checkfmt("(en15.1)", -9.49999905, " -9.5E+00") + call checkfmt("(en15.1)", -0.099951, " -100.0E-03") + call checkfmt("(en15.1)", -0.009951, " -10.0E-03") + call checkfmt("(en15.1)", -0.000999951," -1.0E-03") + + call checkfmt("(en15.1)", 987350., " 987.4E+03") + call checkfmt("(en15.2)", 98735., " 98.74E+03") + call checkfmt("(en15.3)", 9873.5, " 9.874E+03") + call checkfmt("(en15.1)", 987650., " 987.6E+03") + call checkfmt("(en15.2)", 98765., " 98.76E+03") + call checkfmt("(en15.3)", 9876.5, " 9.876E+03") + call checkfmt("(en15.1)", 3.125E-02, " 31.2E-03") + call checkfmt("(en15.1)", 9.375E-02, " 93.8E-03") + call checkfmt("(en15.2)", 1.5625E-02, " 15.62E-03") + call checkfmt("(en15.2)", 4.6875E-02, " 46.88E-03") + call checkfmt("(en15.3)", 7.8125E-03, " 7.812E-03") + call checkfmt("(en15.3)", 2.34375E-02, " 23.438E-03") + call checkfmt("(en15.3)", 9.765625E-04," 976.562E-06") + call checkfmt("(en15.6)", 2.9296875E-03," 2.929688E-03") + + call checkfmt("(en15.1)", -987350., " -987.4E+03") + call checkfmt("(en15.2)", -98735., " -98.74E+03") + call checkfmt("(en15.3)", -9873.5, " -9.874E+03") + call checkfmt("(en15.1)", -987650., " -987.6E+03") + call checkfmt("(en15.2)", -98765., " -98.76E+03") + call checkfmt("(en15.3)", -9876.5, " -9.876E+03") + call checkfmt("(en15.1)", -3.125E-02, " -31.2E-03") + call checkfmt("(en15.1)", -9.375E-02, " -93.8E-03") + call checkfmt("(en15.2)", -1.5625E-02, " -15.62E-03") + call checkfmt("(en15.2)", -4.6875E-02, " -46.88E-03") + call checkfmt("(en15.3)", -7.8125E-03, " -7.812E-03") + call checkfmt("(en15.3)", -2.34375E-02, " -23.438E-03") + call checkfmt("(en15.3)", -9.765625E-04," -976.562E-06") + call checkfmt("(en15.6)", -2.9296875E-03," -2.929688E-03") + + ! print *, n_tst, n_cnt, n_skip + if (n_cnt /= 0) STOP 1 + if (all(.not. l_skip)) print *, "All kinds rounded to nearest" + +contains + subroutine checkfmt(fmt, x, cmp) + implicit none + integer :: i + character(len=*), intent(in) :: fmt + real, intent(in) :: x + character(len=*), intent(in) :: cmp + do i=1,size(real_kinds) + if (i == 1) then + write(s, fmt) real(x,kind=j(1)) + else if (i == 2) then + write(s, fmt) real(x,kind=j(2)) + else if (i == 3) then + write(s, fmt) real(x,kind=j(3)) + else if (i == 4) then + write(s, fmt) real(x,kind=j(4)) + end if + n_tst = n_tst + 1 + if (s /= cmp) then + if (l_skip(i)) then + n_skip = n_skip + 1 + else + print "(a,1x,a,' expected: ',1x,a)", fmt, s, cmp + n_cnt = n_cnt + 1 + end if + end if + end do + + end subroutine +end program +! { dg-output "All kinds rounded to nearest" { xfail { i?86-*-solaris2.9* hppa*-*-hpux* } } } diff --git a/Fortran/gfortran/regression/fmt_en_rd.f90 b/Fortran/gfortran/regression/fmt_en_rd.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_en_rd.f90 @@ -0,0 +1,185 @@ +! { dg-do run } +! PR60128 Invalid outputs with EN descriptors +! Test case provided by Walt Brainerd. +program pr60128 +use ISO_FORTRAN_ENV + implicit none + integer, parameter :: j(size(real_kinds)+4)=[REAL_KINDS, [4, 4, 4, 4]] + logical :: l_skip(4) = .false. + integer :: i + integer :: n_tst = 0, n_cnt = 0, n_skip = 0 + character(len=20,kind=4) :: s, s1 + +! Check that the default rounding mode is to nearest and to even on tie. + do i=1,size(real_kinds) + if (i == 1) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(1)), & + real(9.49999905,kind=j(1)), & + real(9.5,kind=j(1)), real(8.5,kind=j(1)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(1)), & + real(98765.0,kind=j(1)) + else if (i == 2) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(2)), & + real(9.49999905,kind=j(2)), & + real(9.5,kind=j(2)), real(8.5,kind=j(2)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(2)), & + real(98765.0,kind=j(2)) + else if (i == 3) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(3)), & + real(9.49999905,kind=j(3)), & + real(9.5,kind=j(3)), real(8.5,kind=j(3)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(3)), & + real(98765.0,kind=j(3)) + else if (i == 4) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(4)), & + real(9.49999905,kind=j(4)), & + real(9.5,kind=j(4)), real(8.5,kind=j(4)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(4)), & + real(98765.0,kind=j(4)) + end if + if (s /= 4_'-9.5 9.5 10. 8.' .or. s1 /= 4_' 987.4E+03 98.76E+03') then + l_skip(i) = .true. + print "('Unsupported rounding for real(',i0,')')", j(i) + end if + end do + + +! Original test. + call checkfmt("(en15.2)", -.44444, 4_" -444.44E-03") + +! Test for the bug in comment 6. + call checkfmt("(rd,en15.0)", 1.0, 4_" 1.E+00") + call checkfmt("(rd,en15.0)", 1.00000012, 4_" 1.E+00") + call checkfmt("(rd,en15.0)", 0.99999994, 4_" 999.E-03") + call checkfmt("(rd,en15.0)", 10.0, 4_" 10.E+00") + call checkfmt("(rd,en15.0)", 10.0000010, 4_" 10.E+00") + call checkfmt("(rd,en15.0)", 9.99999905, 4_" 9.E+00") + call checkfmt("(ru,en15.0)", 100.0, 4_" 100.E+00") + call checkfmt("(rd,en15.0)", 100.000008, 4_" 100.E+00") + call checkfmt("(rd,en15.0)", 99.9999924, 4_" 99.E+00") + call checkfmt("(rd,en15.0)", 1000.0, 4_" 1.E+03") + call checkfmt("(rd,en15.0)", 1000.00006, 4_" 1.E+03") + call checkfmt("(rd,en15.0)", 999.999939, 4_" 999.E+00") + call checkfmt("(rd,en15.0)", 9.5, 4_" 9.E+00") + call checkfmt("(rd,en15.0)", 9.50000095, 4_" 9.E+00") + call checkfmt("(rd,en15.0)", 9.49999905, 4_" 9.E+00") + call checkfmt("(rd,en15.0)", 99.5, 4_" 99.E+00") + call checkfmt("(rd,en15.0)", 99.5000076, 4_" 99.E+00") + call checkfmt("(rd,en15.0)", 99.4999924, 4_" 99.E+00") + call checkfmt("(rd,en15.0)", 999.5, 4_" 999.E+00") + call checkfmt("(rd,en15.0)", 999.500061, 4_" 999.E+00") + call checkfmt("(rd,en15.0)", 999.499939, 4_" 999.E+00") + call checkfmt("(rd,en15.0)", 9500.0, 4_" 9.E+03") + call checkfmt("(rd,en15.0)", 9500.00098, 4_" 9.E+03") + call checkfmt("(rd,en15.0)", 9499.99902, 4_" 9.E+03") + call checkfmt("(rd,en15.1)", 9950.0, 4_" 9.9E+03") + call checkfmt("(rd,en15.2)", 9995.0, 4_" 9.99E+03") + call checkfmt("(rd,en15.3)", 9999.5, 4_" 9.999E+03") + call checkfmt("(rd,en15.1)", 9.5, 4_" 9.5E+00") + call checkfmt("(rd,en15.1)", 9.50000095, 4_" 9.5E+00") + call checkfmt("(rd,en15.1)", 9.49999905, 4_" 9.4E+00") + call checkfmt("(rd,en15.1)", 0.099951, 4_" 99.9E-03") + call checkfmt("(rd,en15.1)", 0.009951, 4_" 9.9E-03") + call checkfmt("(rd,en15.1)", 0.000999951,4_" 999.9E-06") + + call checkfmt("(rd,en15.0)", -1.0, 4_" -1.E+00") + call checkfmt("(rd,en15.0)", -1.00000012, 4_" -2.E+00") + call checkfmt("(rd,en15.0)", -0.99999994, 4_" -1.E+00") + call checkfmt("(rd,en15.0)", -10.0, 4_" -10.E+00") + call checkfmt("(rd,en15.0)", -10.0000010, 4_" -11.E+00") + call checkfmt("(rd,en15.0)", -9.99999905, 4_" -10.E+00") + call checkfmt("(rd,en15.0)", -100.0, 4_" -100.E+00") + call checkfmt("(rd,en15.0)", -100.000008, 4_" -101.E+00") + call checkfmt("(rd,en15.0)", -99.9999924, 4_" -100.E+00") + call checkfmt("(rd,en15.0)", -1000.0, 4_" -1.E+03") + call checkfmt("(rd,en15.0)", -1000.00006, 4_" -2.E+03") + call checkfmt("(rd,en15.0)", -999.999939, 4_" -1.E+03") + call checkfmt("(rd,en15.0)", -9.5, 4_" -10.E+00") + call checkfmt("(rd,en15.0)", -9.50000095, 4_" -10.E+00") + call checkfmt("(rd,en15.0)", -9.49999905, 4_" -10.E+00") + call checkfmt("(rd,en15.0)", -99.5, 4_" -100.E+00") + call checkfmt("(rd,en15.0)", -99.5000076, 4_" -100.E+00") + call checkfmt("(rd,en15.0)", -99.4999924, 4_" -100.E+00") + call checkfmt("(rd,en15.0)", -999.5, 4_" -1.E+03") + call checkfmt("(rd,en15.0)", -999.500061, 4_" -1.E+03") + call checkfmt("(rd,en15.0)", -999.499939, 4_" -1.E+03") + call checkfmt("(rd,en15.0)", -9500.0, 4_" -10.E+03") + call checkfmt("(rd,en15.0)", -9500.00098, 4_" -10.E+03") + call checkfmt("(rd,en15.0)", -9499.99902, 4_" -10.E+03") + call checkfmt("(rd,en15.1)", -9950.0, 4_" -10.0E+03") + call checkfmt("(rd,en15.2)", -9995.0, 4_" -10.00E+03") + call checkfmt("(rd,en15.3)", -9999.5, 4_" -10.000E+03") + call checkfmt("(rd,en15.1)", -9.5, 4_" -9.5E+00") + call checkfmt("(rd,en15.1)", -9.50000095, 4_" -9.6E+00") + call checkfmt("(rd,en15.1)", -9.49999905, 4_" -9.5E+00") + call checkfmt("(rd,en15.1)", -0.099951, 4_" -100.0E-03") + call checkfmt("(rd,en15.1)", -0.009951, 4_" -10.0E-03") + call checkfmt("(rd,en15.1)", -0.000999951,4_" -1.0E-03") + + call checkfmt("(rd,en15.1)", 987350., 4_" 987.3E+03") + call checkfmt("(rd,en15.2)", 98735., 4_" 98.73E+03") + call checkfmt("(rd,en15.3)", 9873.5, 4_" 9.873E+03") + call checkfmt("(rd,en15.1)", 987650., 4_" 987.6E+03") + call checkfmt("(rd,en15.2)", 98765., 4_" 98.76E+03") + call checkfmt("(rd,en15.3)", 9876.5, 4_" 9.876E+03") + call checkfmt("(rd,en15.1)", 3.125E-02, 4_" 31.2E-03") + call checkfmt("(rd,en15.1)", 9.375E-02, 4_" 93.7E-03") + call checkfmt("(rd,en15.2)", 1.5625E-02, 4_" 15.62E-03") + call checkfmt("(rd,en15.2)", 4.6875E-02, 4_" 46.87E-03") + call checkfmt("(rd,en15.3)", 7.8125E-03, 4_" 7.812E-03") + call checkfmt("(rd,en15.3)", 2.34375E-02, 4_" 23.437E-03") + call checkfmt("(rd,en15.3)", 9.765625E-04,4_" 976.562E-06") + call checkfmt("(rd,en15.6)", 2.9296875E-03,4_" 2.929687E-03") + + call checkfmt("(rd,en15.1)", -987350., 4_" -987.4E+03") + call checkfmt("(rd,en15.2)", -98735., 4_" -98.74E+03") + call checkfmt("(rd,en15.3)", -9873.5, 4_" -9.874E+03") + call checkfmt("(rd,en15.1)", -987650., 4_" -987.7E+03") + call checkfmt("(rd,en15.2)", -98765., 4_" -98.77E+03") + call checkfmt("(rd,en15.3)", -9876.5, 4_" -9.877E+03") + call checkfmt("(rd,en15.1)", -3.125E-02, 4_" -31.3E-03") + call checkfmt("(rd,en15.1)", -9.375E-02, 4_" -93.8E-03") + call checkfmt("(rd,en15.2)", -1.5625E-02, 4_" -15.63E-03") + call checkfmt("(rd,en15.2)", -4.6875E-02, 4_" -46.88E-03") + call checkfmt("(rd,en15.3)", -7.8125E-03, 4_" -7.813E-03") + call checkfmt("(rd,en15.3)", -2.34375E-02, 4_" -23.438E-03") + call checkfmt("(rd,en15.3)", -9.765625E-04,4_" -976.563E-06") + call checkfmt("(rd,en15.6)", -2.9296875E-03,4_" -2.929688E-03") + + print *, n_tst, n_cnt, n_skip + if (n_cnt /= 0) stop n_cnt + if (all(.not. l_skip)) print *, "All kinds rounded down" + +contains + subroutine checkfmt(fmt, x, cmp) + implicit none + integer :: i + character(len=*), intent(in) :: fmt + real, intent(in) :: x + character(len=*, kind=4), intent(in) :: cmp + do i=1,size(real_kinds) + if (l_skip(i)) cycle + if (i == 1) then + write(s, fmt) real(x,kind=j(1)) + else if (i == 2) then + write(s, fmt) real(x,kind=j(2)) + else if (i == 3) then + write(s, fmt) real(x,kind=j(3)) + else if (i == 4) then + write(s, fmt) real(x,kind=j(4)) + end if + n_tst = n_tst + 1 + if (s /= cmp) then + if (l_skip(i)) then + n_skip = n_skip + 1 + else + print "(a,1x,a,' expected: ',1x,a)", fmt, s, cmp + n_cnt = n_cnt + 1 + end if + end if + end do + + end subroutine +end program +! { dg-output "All kinds rounded down" { xfail { i?86-*-solaris2.9* hppa*-*-hpux* } } } +! { dg-final { cleanup-saved-temps } } diff --git a/Fortran/gfortran/regression/fmt_en_rn.f90 b/Fortran/gfortran/regression/fmt_en_rn.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_en_rn.f90 @@ -0,0 +1,185 @@ +! { dg-do run } +! PR60128 Invalid outputs with EN descriptors +! Test case provided by Walt Brainerd. +program pr60128 +use ISO_FORTRAN_ENV + implicit none + integer, parameter :: j(size(real_kinds)+4)=[REAL_KINDS, [4, 4, 4, 4]] + logical :: l_skip(4) = .false. + integer :: i + integer :: n_tst = 0, n_cnt = 0, n_skip = 0 + character(len=20,kind=4) :: s, s1 + +! Check that the default rounding mode is to nearest and to even on tie. + do i=1,size(real_kinds) + if (i == 1) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(1)), & + real(9.49999905,kind=j(1)), & + real(9.5,kind=j(1)), real(8.5,kind=j(1)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(1)), & + real(98765.0,kind=j(1)) + else if (i == 2) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(2)), & + real(9.49999905,kind=j(2)), & + real(9.5,kind=j(2)), real(8.5,kind=j(2)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(2)), & + real(98765.0,kind=j(2)) + else if (i == 3) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(3)), & + real(9.49999905,kind=j(3)), & + real(9.5,kind=j(3)), real(8.5,kind=j(3)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(3)), & + real(98765.0,kind=j(3)) + else if (i == 4) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(4)), & + real(9.49999905,kind=j(4)), & + real(9.5,kind=j(4)), real(8.5,kind=j(4)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(4)), & + real(98765.0,kind=j(4)) + end if + if (s /= 4_'-9.5 9.5 10. 8.' .or. s1 /= 4_' 987.4E+03 98.76E+03') then + l_skip(i) = .true. + print "('Unsupported rounding for real(',i0,')')", j(i) + end if + end do + + +! Original test. + call checkfmt("(en15.2)", -.44444, 4_" -444.44E-03") + +! Test for the bug in comment 6. + call checkfmt("(rn,en15.0)", 1.0, 4_" 1.E+00") + call checkfmt("(rn,en15.0)", 1.00000012, 4_" 1.E+00") + call checkfmt("(rn,en15.0)", 0.99999994, 4_" 1.E+00") + call checkfmt("(rn,en15.0)", 10.0, 4_" 10.E+00") + call checkfmt("(rn,en15.0)", 10.0000010, 4_" 10.E+00") + call checkfmt("(rn,en15.0)", 9.99999905, 4_" 10.E+00") + call checkfmt("(rn,en15.0)", 100.0, 4_" 100.E+00") + call checkfmt("(rn,en15.0)", 100.000008, 4_" 100.E+00") + call checkfmt("(rn,en15.0)", 99.9999924, 4_" 100.E+00") + call checkfmt("(rn,en15.0)", 1000.0, 4_" 1.E+03") + call checkfmt("(rn,en15.0)", 1000.00006, 4_" 1.E+03") + call checkfmt("(rn,en15.0)", 999.999939, 4_" 1.E+03") + call checkfmt("(rn,en15.0)", 9.5, 4_" 10.E+00") + call checkfmt("(rn,en15.0)", 9.50000095, 4_" 10.E+00") + call checkfmt("(rn,en15.0)", 9.49999905, 4_" 9.E+00") + call checkfmt("(rn,en15.0)", 99.5, 4_" 100.E+00") + call checkfmt("(rn,en15.0)", 99.5000076, 4_" 100.E+00") + call checkfmt("(rn,en15.0)", 99.4999924, 4_" 99.E+00") + call checkfmt("(rn,en15.0)", 999.5, 4_" 1.E+03") + call checkfmt("(rn,en15.0)", 999.500061, 4_" 1.E+03") + call checkfmt("(rn,en15.0)", 999.499939, 4_" 999.E+00") + call checkfmt("(rn,en15.0)", 9500.0, 4_" 10.E+03") + call checkfmt("(rn,en15.0)", 9500.00098, 4_" 10.E+03") + call checkfmt("(rn,en15.0)", 9499.99902, 4_" 9.E+03") + call checkfmt("(rn,en15.1)", 9950.0, 4_" 10.0E+03") + call checkfmt("(rn,en15.2)", 9995.0, 4_" 10.00E+03") + call checkfmt("(rn,en15.3)", 9999.5, 4_" 10.000E+03") + call checkfmt("(rn,en15.1)", 9.5, 4_" 9.5E+00") + call checkfmt("(rn,en15.1)", 9.50000095, 4_" 9.5E+00") + call checkfmt("(rn,en15.1)", 9.49999905, 4_" 9.5E+00") + call checkfmt("(rn,en15.1)", 0.099951, 4_" 100.0E-03") + call checkfmt("(rn,en15.1)", 0.009951, 4_" 10.0E-03") + call checkfmt("(rn,en15.1)", 0.000999951,4_" 1.0E-03") + + call checkfmt("(rn,en15.0)", -1.0, 4_" -1.E+00") + call checkfmt("(rn,en15.0)", -1.00000012, 4_" -1.E+00") + call checkfmt("(rn,en15.0)", -0.99999994, 4_" -1.E+00") + call checkfmt("(rn,en15.0)", -10.0, 4_" -10.E+00") + call checkfmt("(rn,en15.0)", -10.0000010, 4_" -10.E+00") + call checkfmt("(rn,en15.0)", -9.99999905, 4_" -10.E+00") + call checkfmt("(rn,en15.0)", -100.0, 4_" -100.E+00") + call checkfmt("(rn,en15.0)", -100.000008, 4_" -100.E+00") + call checkfmt("(rn,en15.0)", -99.9999924, 4_" -100.E+00") + call checkfmt("(rn,en15.0)", -1000.0, 4_" -1.E+03") + call checkfmt("(rn,en15.0)", -1000.00006, 4_" -1.E+03") + call checkfmt("(rn,en15.0)", -999.999939, 4_" -1.E+03") + call checkfmt("(rn,en15.0)", -9.5, 4_" -10.E+00") + call checkfmt("(rn,en15.0)", -9.50000095, 4_" -10.E+00") + call checkfmt("(rn,en15.0)", -9.49999905, 4_" -9.E+00") + call checkfmt("(rn,en15.0)", -99.5, 4_" -100.E+00") + call checkfmt("(rn,en15.0)", -99.5000076, 4_" -100.E+00") + call checkfmt("(rn,en15.0)", -99.4999924, 4_" -99.E+00") + call checkfmt("(rn,en15.0)", -999.5, 4_" -1.E+03") + call checkfmt("(rn,en15.0)", -999.500061, 4_" -1.E+03") + call checkfmt("(rn,en15.0)", -999.499939, 4_" -999.E+00") + call checkfmt("(rn,en15.0)", -9500.0, 4_" -10.E+03") + call checkfmt("(rn,en15.0)", -9500.00098, 4_" -10.E+03") + call checkfmt("(rn,en15.0)", -9499.99902, 4_" -9.E+03") + call checkfmt("(rn,en15.1)", -9950.0, 4_" -10.0E+03") + call checkfmt("(rn,en15.2)", -9995.0, 4_" -10.00E+03") + call checkfmt("(rn,en15.3)", -9999.5, 4_" -10.000E+03") + call checkfmt("(rn,en15.1)", -9.5, 4_" -9.5E+00") + call checkfmt("(rn,en15.1)", -9.50000095, 4_" -9.5E+00") + call checkfmt("(rn,en15.1)", -9.49999905, 4_" -9.5E+00") + call checkfmt("(rn,en15.1)", -0.099951, 4_" -100.0E-03") + call checkfmt("(rn,en15.1)", -0.009951, 4_" -10.0E-03") + call checkfmt("(rn,en15.1)", -0.000999951,4_" -1.0E-03") + + call checkfmt("(rn,en15.1)", 987350., 4_" 987.4E+03") + call checkfmt("(rn,en15.2)", 98735., 4_" 98.74E+03") + call checkfmt("(rn,en15.3)", 9873.5, 4_" 9.874E+03") + call checkfmt("(rn,en15.1)", 987650., 4_" 987.6E+03") + call checkfmt("(rn,en15.2)", 98765., 4_" 98.76E+03") + call checkfmt("(rn,en15.3)", 9876.5, 4_" 9.876E+03") + call checkfmt("(rn,en15.1)", 3.125E-02, 4_" 31.2E-03") + call checkfmt("(rn,en15.1)", 9.375E-02, 4_" 93.8E-03") + call checkfmt("(rn,en15.2)", 1.5625E-02, 4_" 15.62E-03") + call checkfmt("(rn,en15.2)", 4.6875E-02, 4_" 46.88E-03") + call checkfmt("(rn,en15.3)", 7.8125E-03, 4_" 7.812E-03") + call checkfmt("(rn,en15.3)", 2.34375E-02, 4_" 23.438E-03") + call checkfmt("(rn,en15.3)", 9.765625E-04,4_" 976.562E-06") + call checkfmt("(rn,en15.6)", 2.9296875E-03,4_" 2.929688E-03") + + call checkfmt("(rn,en15.1)", -987350., 4_" -987.4E+03") + call checkfmt("(rn,en15.2)", -98735., 4_" -98.74E+03") + call checkfmt("(rn,en15.3)", -9873.5, 4_" -9.874E+03") + call checkfmt("(rn,en15.1)", -987650., 4_" -987.6E+03") + call checkfmt("(rn,en15.2)", -98765., 4_" -98.76E+03") + call checkfmt("(rn,en15.3)", -9876.5, 4_" -9.876E+03") + call checkfmt("(rn,en15.1)", -3.125E-02, 4_" -31.2E-03") + call checkfmt("(rn,en15.1)", -9.375E-02, 4_" -93.8E-03") + call checkfmt("(rn,en15.2)", -1.5625E-02, 4_" -15.62E-03") + call checkfmt("(rn,en15.2)", -4.6875E-02, 4_" -46.88E-03") + call checkfmt("(rn,en15.3)", -7.8125E-03, 4_" -7.812E-03") + call checkfmt("(rn,en15.3)", -2.34375E-02, 4_" -23.438E-03") + call checkfmt("(rn,en15.3)", -9.765625E-04,4_" -976.562E-06") + call checkfmt("(rn,en15.6)", -2.9296875E-03,4_" -2.929688E-03") + + print *, n_tst, n_cnt, n_skip + if (n_cnt /= 0) stop n_cnt + if (all(.not. l_skip)) print *, "All kinds rounded to nearest" + +contains + subroutine checkfmt(fmt, x, cmp) + implicit none + integer :: i + character(len=*), intent(in) :: fmt + real, intent(in) :: x + character(len=*, kind=4), intent(in) :: cmp + do i=1,size(real_kinds) + if (l_skip(i)) cycle + if (i == 1) then + write(s, fmt) real(x,kind=j(1)) + else if (i == 2) then + write(s, fmt) real(x,kind=j(2)) + else if (i == 3) then + write(s, fmt) real(x,kind=j(3)) + else if (i == 4) then + write(s, fmt) real(x,kind=j(4)) + end if + n_tst = n_tst + 1 + if (s /= cmp) then + if (l_skip(i)) then + n_skip = n_skip + 1 + else + print "(a,1x,a,' expected: ',1x,a)", fmt, s, cmp + n_cnt = n_cnt + 1 + end if + end if + end do + + end subroutine +end program +! { dg-output "All kinds rounded to nearest" { xfail { i?86-*-solaris2.9* hppa*-*-hpux* } } } +! { dg-final { cleanup-saved-temps } } diff --git a/Fortran/gfortran/regression/fmt_en_ru.f90 b/Fortran/gfortran/regression/fmt_en_ru.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_en_ru.f90 @@ -0,0 +1,185 @@ +! { dg-do run } +! PR60128 Invalid outputs with EN descriptors +! Test case provided by Walt Brainerd. +program pr60128 +use ISO_FORTRAN_ENV + implicit none + integer, parameter :: j(size(real_kinds)+4)=[REAL_KINDS, [4, 4, 4, 4]] + logical :: l_skip(4) = .false. + integer :: i + integer :: n_tst = 0, n_cnt = 0, n_skip = 0 + character(len=20,kind=4) :: s, s1 + +! Check that the default rounding mode is to nearest and to even on tie. + do i=1,size(real_kinds) + if (i == 1) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(1)), & + real(9.49999905,kind=j(1)), & + real(9.5,kind=j(1)), real(8.5,kind=j(1)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(1)), & + real(98765.0,kind=j(1)) + else if (i == 2) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(2)), & + real(9.49999905,kind=j(2)), & + real(9.5,kind=j(2)), real(8.5,kind=j(2)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(2)), & + real(98765.0,kind=j(2)) + else if (i == 3) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(3)), & + real(9.49999905,kind=j(3)), & + real(9.5,kind=j(3)), real(8.5,kind=j(3)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(3)), & + real(98765.0,kind=j(3)) + else if (i == 4) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(4)), & + real(9.49999905,kind=j(4)), & + real(9.5,kind=j(4)), real(8.5,kind=j(4)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(4)), & + real(98765.0,kind=j(4)) + end if + if (s /= 4_'-9.5 9.5 10. 8.' .or. s1 /= 4_' 987.4E+03 98.76E+03') then + l_skip(i) = .true. + print "('Unsupported rounding for real(',i0,')')", j(i) + end if + end do + + +! Original test. + call checkfmt("(en15.2)", -.44444, 4_" -444.44E-03") + +! Test for the bug in comment 6. + call checkfmt("(ru,en15.0)", 1.0, 4_" 1.E+00") + call checkfmt("(ru,en15.0)", 1.00000012, 4_" 2.E+00") + call checkfmt("(ru,en15.0)", 0.99999994, 4_" 1.E+00") + call checkfmt("(ru,en15.0)", 10.0, 4_" 10.E+00") + call checkfmt("(ru,en15.0)", 10.0000010, 4_" 11.E+00") + call checkfmt("(ru,en15.0)", 9.99999905, 4_" 10.E+00") + call checkfmt("(ru,en15.0)", 100.0, 4_" 100.E+00") + call checkfmt("(ru,en15.0)", 100.000008, 4_" 101.E+00") + call checkfmt("(ru,en15.0)", 99.9999924, 4_" 100.E+00") + call checkfmt("(ru,en15.0)", 1000.0, 4_" 1.E+03") + call checkfmt("(ru,en15.0)", 1000.00006, 4_" 2.E+03") + call checkfmt("(ru,en15.0)", 999.999939, 4_" 1.E+03") + call checkfmt("(ru,en15.0)", 9.5, 4_" 10.E+00") + call checkfmt("(ru,en15.0)", 9.50000095, 4_" 10.E+00") + call checkfmt("(ru,en15.0)", 9.49999905, 4_" 10.E+00") + call checkfmt("(ru,en15.0)", 99.5, 4_" 100.E+00") + call checkfmt("(ru,en15.0)", 99.5000076, 4_" 100.E+00") + call checkfmt("(ru,en15.0)", 99.4999924, 4_" 100.E+00") + call checkfmt("(ru,en15.0)", 999.5, 4_" 1.E+03") + call checkfmt("(ru,en15.0)", 999.500061, 4_" 1.E+03") + call checkfmt("(ru,en15.0)", 999.499939, 4_" 1.E+03") + call checkfmt("(ru,en15.0)", 9500.0, 4_" 10.E+03") + call checkfmt("(ru,en15.0)", 9500.00098, 4_" 10.E+03") + call checkfmt("(ru,en15.0)", 9499.99902, 4_" 10.E+03") + call checkfmt("(ru,en15.1)", 9950.0, 4_" 10.0E+03") + call checkfmt("(ru,en15.2)", 9995.0, 4_" 10.00E+03") + call checkfmt("(ru,en15.3)", 9999.5, 4_" 10.000E+03") + call checkfmt("(ru,en15.1)", 9.5, 4_" 9.5E+00") + call checkfmt("(ru,en15.1)", 9.50000095, 4_" 9.6E+00") + call checkfmt("(ru,en15.1)", 9.49999905, 4_" 9.5E+00") + call checkfmt("(ru,en15.1)", 0.099951, 4_" 100.0E-03") + call checkfmt("(ru,en15.1)", 0.009951, 4_" 10.0E-03") + call checkfmt("(ru,en15.1)", 0.000999951,4_" 1.0E-03") + + call checkfmt("(ru,en15.0)", -1.0, 4_" -1.E+00") + call checkfmt("(ru,en15.0)", -1.00000012, 4_" -1.E+00") + call checkfmt("(ru,en15.0)", -0.99999994, 4_" -999.E-03") + call checkfmt("(ru,en15.0)", -10.0, 4_" -10.E+00") + call checkfmt("(ru,en15.0)", -10.0000010, 4_" -10.E+00") + call checkfmt("(ru,en15.0)", -9.99999905, 4_" -9.E+00") + call checkfmt("(ru,en15.0)", -100.0, 4_" -100.E+00") + call checkfmt("(ru,en15.0)", -100.000008, 4_" -100.E+00") + call checkfmt("(ru,en15.0)", -99.9999924, 4_" -99.E+00") + call checkfmt("(ru,en15.0)", -1000.0, 4_" -1.E+03") + call checkfmt("(ru,en15.0)", -1000.00006, 4_" -1.E+03") + call checkfmt("(ru,en15.0)", -999.999939, 4_" -999.E+00") + call checkfmt("(ru,en15.0)", -9.5, 4_" -9.E+00") + call checkfmt("(ru,en15.0)", -9.50000095, 4_" -9.E+00") + call checkfmt("(ru,en15.0)", -9.49999905, 4_" -9.E+00") + call checkfmt("(ru,en15.0)", -99.5, 4_" -99.E+00") + call checkfmt("(ru,en15.0)", -99.5000076, 4_" -99.E+00") + call checkfmt("(ru,en15.0)", -99.4999924, 4_" -99.E+00") + call checkfmt("(ru,en15.0)", -999.5, 4_" -999.E+00") + call checkfmt("(ru,en15.0)", -999.500061, 4_" -999.E+00") + call checkfmt("(ru,en15.0)", -999.499939, 4_" -999.E+00") + call checkfmt("(ru,en15.0)", -9500.0, 4_" -9.E+03") + call checkfmt("(ru,en15.0)", -9500.00098, 4_" -9.E+03") + call checkfmt("(ru,en15.0)", -9499.99902, 4_" -9.E+03") + call checkfmt("(ru,en15.1)", -9950.0, 4_" -9.9E+03") + call checkfmt("(ru,en15.2)", -9995.0, 4_" -9.99E+03") + call checkfmt("(ru,en15.3)", -9999.5, 4_" -9.999E+03") + call checkfmt("(ru,en15.1)", -9.5, 4_" -9.5E+00") + call checkfmt("(ru,en15.1)", -9.50000095, 4_" -9.5E+00") + call checkfmt("(ru,en15.1)", -9.49999905, 4_" -9.4E+00") + call checkfmt("(ru,en15.1)", -0.099951, 4_" -99.9E-03") + call checkfmt("(ru,en15.1)", -0.009951, 4_" -9.9E-03") + call checkfmt("(ru,en15.1)", -0.000999951,4_" -999.9E-06") + + call checkfmt("(ru,en15.1)", 987350., 4_" 987.4E+03") + call checkfmt("(ru,en15.2)", 98735., 4_" 98.74E+03") + call checkfmt("(ru,en15.3)", 9873.5, 4_" 9.874E+03") + call checkfmt("(ru,en15.1)", 987650., 4_" 987.7E+03") + call checkfmt("(ru,en15.2)", 98765., 4_" 98.77E+03") + call checkfmt("(ru,en15.3)", 9876.5, 4_" 9.877E+03") + call checkfmt("(ru,en15.1)", 3.125E-02, 4_" 31.3E-03") + call checkfmt("(ru,en15.1)", 9.375E-02, 4_" 93.8E-03") + call checkfmt("(ru,en15.2)", 1.5625E-02, 4_" 15.63E-03") + call checkfmt("(ru,en15.2)", 4.6875E-02, 4_" 46.88E-03") + call checkfmt("(ru,en15.3)", 7.8125E-03, 4_" 7.813E-03") + call checkfmt("(ru,en15.3)", 2.34375E-02, 4_" 23.438E-03") + call checkfmt("(ru,en15.3)", 9.765625E-04,4_" 976.563E-06") + call checkfmt("(ru,en15.6)", 2.9296875E-03,4_" 2.929688E-03") + + call checkfmt("(ru,en15.1)", -987350., 4_" -987.3E+03") + call checkfmt("(ru,en15.2)", -98735., 4_" -98.73E+03") + call checkfmt("(ru,en15.3)", -9873.5, 4_" -9.873E+03") + call checkfmt("(ru,en15.1)", -987650., 4_" -987.6E+03") + call checkfmt("(ru,en15.2)", -98765., 4_" -98.76E+03") + call checkfmt("(ru,en15.3)", -9876.5, 4_" -9.876E+03") + call checkfmt("(ru,en15.1)", -3.125E-02, 4_" -31.2E-03") + call checkfmt("(ru,en15.1)", -9.375E-02, 4_" -93.7E-03") + call checkfmt("(ru,en15.2)", -1.5625E-02, 4_" -15.62E-03") + call checkfmt("(ru,en15.2)", -4.6875E-02, 4_" -46.87E-03") + call checkfmt("(ru,en15.3)", -7.8125E-03, 4_" -7.812E-03") + call checkfmt("(ru,en15.3)", -2.34375E-02, 4_" -23.437E-03") + call checkfmt("(ru,en15.3)", -9.765625E-04,4_" -976.562E-06") + call checkfmt("(ru,en15.6)", -2.9296875E-03,4_" -2.929687E-03") + + print *, n_tst, n_cnt, n_skip + if (n_cnt /= 0) stop n_cnt + if (all(.not. l_skip)) print *, "All kinds rounded up" + +contains + subroutine checkfmt(fmt, x, cmp) + implicit none + integer :: i + character(len=*), intent(in) :: fmt + real, intent(in) :: x + character(len=*, kind=4), intent(in) :: cmp + do i=1,size(real_kinds) + if (l_skip(i)) cycle + if (i == 1) then + write(s, fmt) real(x,kind=j(1)) + else if (i == 2) then + write(s, fmt) real(x,kind=j(2)) + else if (i == 3) then + write(s, fmt) real(x,kind=j(3)) + else if (i == 4) then + write(s, fmt) real(x,kind=j(4)) + end if + n_tst = n_tst + 1 + if (s /= cmp) then + if (l_skip(i)) then + n_skip = n_skip + 1 + else + print "(a,1x,a,' expected: ',1x,a)", fmt, s, cmp + n_cnt = n_cnt + 1 + end if + end if + end do + + end subroutine +end program +! { dg-output "All kinds rounded up" { xfail { i?86-*-solaris2.9* hppa*-*-hpux* } } } +! { dg-final { cleanup-saved-temps } } diff --git a/Fortran/gfortran/regression/fmt_en_rz.f90 b/Fortran/gfortran/regression/fmt_en_rz.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_en_rz.f90 @@ -0,0 +1,185 @@ +! { dg-do run } +! PR60128 Invalid outputs with EN descriptors +! Test case provided by Walt Brainerd. +program pr60128 +use ISO_FORTRAN_ENV + implicit none + integer, parameter :: j(size(real_kinds)+4)=[REAL_KINDS, [4, 4, 4, 4]] + logical :: l_skip(4) = .false. + integer :: i + integer :: n_tst = 0, n_cnt = 0, n_skip = 0 + character(len=20,kind=4) :: s, s1 + +! Check that the default rounding mode is to nearest and to even on tie. + do i=1,size(real_kinds) + if (i == 1) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(1)), & + real(9.49999905,kind=j(1)), & + real(9.5,kind=j(1)), real(8.5,kind=j(1)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(1)), & + real(98765.0,kind=j(1)) + else if (i == 2) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(2)), & + real(9.49999905,kind=j(2)), & + real(9.5,kind=j(2)), real(8.5,kind=j(2)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(2)), & + real(98765.0,kind=j(2)) + else if (i == 3) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(3)), & + real(9.49999905,kind=j(3)), & + real(9.5,kind=j(3)), real(8.5,kind=j(3)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(3)), & + real(98765.0,kind=j(3)) + else if (i == 4) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(4)), & + real(9.49999905,kind=j(4)), & + real(9.5,kind=j(4)), real(8.5,kind=j(4)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(4)), & + real(98765.0,kind=j(4)) + end if + if (s /= 4_'-9.5 9.5 10. 8.' .or. s1 /= 4_' 987.4E+03 98.76E+03') then + l_skip(i) = .true. + print "('Unsupported rounding for real(',i0,')')", j(i) + end if + end do + + +! Original test. + call checkfmt("(en15.2)", -.44444, 4_" -444.44E-03") + +! Test for the bug in comment 6. + call checkfmt("(rz,en15.0)", 1.0, 4_" 1.E+00") + call checkfmt("(rz,en15.0)", 1.00000012, 4_" 1.E+00") + call checkfmt("(rz,en15.0)", 0.99999994, 4_" 999.E-03") + call checkfmt("(rz,en15.0)", 10.0, 4_" 10.E+00") + call checkfmt("(rz,en15.0)", 10.0000010, 4_" 10.E+00") + call checkfmt("(rz,en15.0)", 9.99999905, 4_" 9.E+00") + call checkfmt("(rz,en15.0)", 100.0, 4_" 100.E+00") + call checkfmt("(rz,en15.0)", 100.000008, 4_" 100.E+00") + call checkfmt("(rz,en15.0)", 99.9999924, 4_" 99.E+00") + call checkfmt("(rz,en15.0)", 1000.0, 4_" 1.E+03") + call checkfmt("(rz,en15.0)", 1000.00006, 4_" 1.E+03") + call checkfmt("(rz,en15.0)", 999.999939, 4_" 999.E+00") + call checkfmt("(rz,en15.0)", 9.5, 4_" 9.E+00") + call checkfmt("(rz,en15.0)", 9.50000095, 4_" 9.E+00") + call checkfmt("(rz,en15.0)", 9.49999905, 4_" 9.E+00") + call checkfmt("(rz,en15.0)", 99.5, 4_" 99.E+00") + call checkfmt("(rz,en15.0)", 99.5000076, 4_" 99.E+00") + call checkfmt("(rz,en15.0)", 99.4999924, 4_" 99.E+00") + call checkfmt("(rz,en15.0)", 999.5, 4_" 999.E+00") + call checkfmt("(rz,en15.0)", 999.500061, 4_" 999.E+00") + call checkfmt("(rz,en15.0)", 999.499939, 4_" 999.E+00") + call checkfmt("(rz,en15.0)", 9500.0, 4_" 9.E+03") + call checkfmt("(rz,en15.0)", 9500.00098, 4_" 9.E+03") + call checkfmt("(rz,en15.0)", 9499.99902, 4_" 9.E+03") + call checkfmt("(rz,en15.1)", 9950.0, 4_" 9.9E+03") + call checkfmt("(rz,en15.2)", 9995.0, 4_" 9.99E+03") + call checkfmt("(rz,en15.3)", 9999.5, 4_" 9.999E+03") + call checkfmt("(rz,en15.1)", 9.5, 4_" 9.5E+00") + call checkfmt("(rz,en15.1)", 9.50000095, 4_" 9.5E+00") + call checkfmt("(rz,en15.1)", 9.49999905, 4_" 9.4E+00") + call checkfmt("(rz,en15.1)", 0.099951, 4_" 99.9E-03") + call checkfmt("(rz,en15.1)", 0.009951, 4_" 9.9E-03") + call checkfmt("(rz,en15.1)", 0.000999951,4_" 999.9E-06") + + call checkfmt("(rz,en15.0)", -1.0, 4_" -1.E+00") + call checkfmt("(rz,en15.0)", -1.00000012, 4_" -1.E+00") + call checkfmt("(rz,en15.0)", -0.99999994, 4_" -999.E-03") + call checkfmt("(rz,en15.0)", -10.0, 4_" -10.E+00") + call checkfmt("(rz,en15.0)", -10.0000010, 4_" -10.E+00") + call checkfmt("(rz,en15.0)", -9.99999905, 4_" -9.E+00") + call checkfmt("(rz,en15.0)", -100.0, 4_" -100.E+00") + call checkfmt("(rz,en15.0)", -100.000008, 4_" -100.E+00") + call checkfmt("(rz,en15.0)", -99.9999924, 4_" -99.E+00") + call checkfmt("(rz,en15.0)", -1000.0, 4_" -1.E+03") + call checkfmt("(rz,en15.0)", -1000.00006, 4_" -1.E+03") + call checkfmt("(rz,en15.0)", -999.999939, 4_" -999.E+00") + call checkfmt("(rz,en15.0)", -9.5, 4_" -9.E+00") + call checkfmt("(rz,en15.0)", -9.50000095, 4_" -9.E+00") + call checkfmt("(rz,en15.0)", -9.49999905, 4_" -9.E+00") + call checkfmt("(rz,en15.0)", -99.5, 4_" -99.E+00") + call checkfmt("(rz,en15.0)", -99.5000076, 4_" -99.E+00") + call checkfmt("(rz,en15.0)", -99.4999924, 4_" -99.E+00") + call checkfmt("(rz,en15.0)", -999.5, 4_" -999.E+00") + call checkfmt("(rz,en15.0)", -999.500061, 4_" -999.E+00") + call checkfmt("(rz,en15.0)", -999.499939, 4_" -999.E+00") + call checkfmt("(rz,en15.0)", -9500.0, 4_" -9.E+03") + call checkfmt("(rz,en15.0)", -9500.00098, 4_" -9.E+03") + call checkfmt("(rz,en15.0)", -9499.99902, 4_" -9.E+03") + call checkfmt("(rz,en15.1)", -9950.0, 4_" -9.9E+03") + call checkfmt("(rz,en15.2)", -9995.0, 4_" -9.99E+03") + call checkfmt("(rz,en15.3)", -9999.5, 4_" -9.999E+03") + call checkfmt("(rz,en15.1)", -9.5, 4_" -9.5E+00") + call checkfmt("(rz,en15.1)", -9.50000095, 4_" -9.5E+00") + call checkfmt("(rz,en15.1)", -9.49999905, 4_" -9.4E+00") + call checkfmt("(rz,en15.1)", -0.099951, 4_" -99.9E-03") + call checkfmt("(rz,en15.1)", -0.009951, 4_" -9.9E-03") + call checkfmt("(rz,en15.1)", -0.000999951,4_" -999.9E-06") + + call checkfmt("(rz,en15.1)", 987350., 4_" 987.3E+03") + call checkfmt("(rz,en15.2)", 98735., 4_" 98.73E+03") + call checkfmt("(rz,en15.3)", 9873.5, 4_" 9.873E+03") + call checkfmt("(rz,en15.1)", 987650., 4_" 987.6E+03") + call checkfmt("(rz,en15.2)", 98765., 4_" 98.76E+03") + call checkfmt("(rz,en15.3)", 9876.5, 4_" 9.876E+03") + call checkfmt("(rz,en15.1)", 3.125E-02, 4_" 31.2E-03") + call checkfmt("(rz,en15.1)", 9.375E-02, 4_" 93.7E-03") + call checkfmt("(rz,en15.2)", 1.5625E-02, 4_" 15.62E-03") + call checkfmt("(rz,en15.2)", 4.6875E-02, 4_" 46.87E-03") + call checkfmt("(rz,en15.3)", 7.8125E-03, 4_" 7.812E-03") + call checkfmt("(rz,en15.3)", 2.34375E-02, 4_" 23.437E-03") + call checkfmt("(rz,en15.3)", 9.765625E-04,4_" 976.562E-06") + call checkfmt("(rz,en15.6)", 2.9296875E-03,4_" 2.929687E-03") + + call checkfmt("(rz,en15.1)", -987350., 4_" -987.3E+03") + call checkfmt("(rz,en15.2)", -98735., 4_" -98.73E+03") + call checkfmt("(rz,en15.3)", -9873.5, 4_" -9.873E+03") + call checkfmt("(rz,en15.1)", -987650., 4_" -987.6E+03") + call checkfmt("(rz,en15.2)", -98765., 4_" -98.76E+03") + call checkfmt("(rz,en15.3)", -9876.5, 4_" -9.876E+03") + call checkfmt("(rz,en15.1)", -3.125E-02, 4_" -31.2E-03") + call checkfmt("(rz,en15.1)", -9.375E-02, 4_" -93.7E-03") + call checkfmt("(rz,en15.2)", -1.5625E-02, 4_" -15.62E-03") + call checkfmt("(rz,en15.2)", -4.6875E-02, 4_" -46.87E-03") + call checkfmt("(rz,en15.3)", -7.8125E-03, 4_" -7.812E-03") + call checkfmt("(rz,en15.3)", -2.34375E-02, 4_" -23.437E-03") + call checkfmt("(rz,en15.3)", -9.765625E-04,4_" -976.562E-06") + call checkfmt("(rz,en15.6)", -2.9296875E-03,4_" -2.929687E-03") + + print *, n_tst, n_cnt, n_skip + if (n_cnt /= 0) stop n_cnt + if (all(.not. l_skip)) print *, "All kinds rounded to zero" + +contains + subroutine checkfmt(fmt, x, cmp) + implicit none + integer :: i + character(len=*), intent(in) :: fmt + real, intent(in) :: x + character(len=*, kind=4), intent(in) :: cmp + do i=1,size(real_kinds) + if (l_skip(i)) cycle + if (i == 1) then + write(s, fmt) real(x,kind=j(1)) + else if (i == 2) then + write(s, fmt) real(x,kind=j(2)) + else if (i == 3) then + write(s, fmt) real(x,kind=j(3)) + else if (i == 4) then + write(s, fmt) real(x,kind=j(4)) + end if + n_tst = n_tst + 1 + if (s /= cmp) then + if (l_skip(i)) then + n_skip = n_skip + 1 + else + print "(a,1x,a,' expected: ',1x,a)", fmt, s, cmp + n_cnt = n_cnt + 1 + end if + end if + end do + + end subroutine +end program +! { dg-output "All kinds rounded to zero" { xfail { i?86-*-solaris2.9* hppa*-*-hpux* } } } +! { dg-final { cleanup-saved-temps } } diff --git a/Fortran/gfortran/regression/fmt_error.f90 b/Fortran/gfortran/regression/fmt_error.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_error.f90 @@ -0,0 +1,4 @@ +! { dg-do compile } +! PR32545 Give compile error not warning for wrong edit format statements. +read (5,'(i0)') i ! { dg-error "Positive width required in format" } +end diff --git a/Fortran/gfortran/regression/fmt_error_10.f b/Fortran/gfortran/regression/fmt_error_10.f --- /dev/null +++ b/Fortran/gfortran/regression/fmt_error_10.f @@ -0,0 +1,29 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! PR38439 I/O PD edit descriptor inconsistency +! Test case prepared by Jerry DeLisle + character(len=25) :: str + character(len=132) :: msg, line + str = '(1pd24.15e6)' + line = "initial string" + x = 555.25 + + write (line,str,iostat=istat, iomsg=msg) 1.0d0, 1.234 + if (istat.ne.0) STOP 1 + if (line.ne." 1.000000000000000D+001.E+00") STOP 2 + + write (line,'(1pd24.15e6)',iostat=istat, iomsg=msg) 1.0d0, 1.234 ! { dg-warning "Period required" } + if (istat.ne.0) STOP 3 + if (line.ne." 1.000000000000000D+001.E+00") STOP 4 + + str = '(1pd0.15)' + write (line,str,iostat=istat, iomsg=msg) 1.0d0 + if (line.ne."1.000000000000000") STOP 5 + read (*,str,iostat=istat, iomsg=msg) x + if (istat.ne.5006 .or. msg(1:10).ne."Zero width") STOP 6 + if (x.ne.555.25) STOP 7 + + write (line,'(1pd24.15e11.3)') 1.0d0, 1.234 + if (line.ne." 1.000000000000000D+00 1.234E+00") STOP 8 + + end diff --git a/Fortran/gfortran/regression/fmt_error_11.f03 b/Fortran/gfortran/regression/fmt_error_11.f03 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_error_11.f03 @@ -0,0 +1,8 @@ +! { dg-do run } +! PR45143 Endless loop with unlimited edit descriptor + print 20, "1234", "abcd", "14rfa5" + 20 format ( *('start',('ahdh',('dhdhhow',a),'ndlownd '))) + print 30, "1234", "abcd", "14rfa5" + 30 format ( *('start',('ahdh',('dhdhhow'),'ndlownd '))) +end +! { dg-shouldfail "Fortran runtime error: '*' requires at least one associated data descriptor" } diff --git a/Fortran/gfortran/regression/fmt_error_2.f90 b/Fortran/gfortran/regression/fmt_error_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_error_2.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +! PR 33269: we used to not simplify format strings before checking if +! they were valid, leading to a missed error. + +IMPLICIT CHARACTER*5 (h-z) + +CHARACTER*5 f +CHARACTER*5 bad, good +parameter(bad="a", good="(a)") + +PRINT ('a'), "hello" ! { dg-error "Missing leading left parenthesis in format string" } +WRITE (*, ("a")) "error" ! { dg-error "Missing leading left parenthesis in format string" } + +PRINT 'a', "hello" ! { dg-error "Missing leading left parenthesis in format string" } +WRITE (*, "a") "error" ! { dg-error "Missing leading left parenthesis in format string" } +WRITE (*, bad) "error" ! { dg-error "Missing leading left parenthesis in format string" } + +PRINT 'a' // ', a', "err", "or" ! { dg-error "Missing leading left parenthesis in format string" } + +PRINT '(' // 'a' ! { dg-error "Unexpected end of format string in format string" } + +! the following are ok +PRINT "(2f5.3)", bar, foo +PRINT ' (a)', "hello" +WRITE (*, " ((a))") "hello" +print "(a" // ")", "all is fine" +print good, "great" + +! verify that we haven't broken non-constant expressions +f = "(f5.3)" +print f, 3.14159 +print (f), 2.71813 +print implicitly_typed, "something" +write (*, implicitly_typed_as_well) "something else" +END diff --git a/Fortran/gfortran/regression/fmt_error_3.f90 b/Fortran/gfortran/regression/fmt_error_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_error_3.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } + +! PR fortran/29835 +! Check for improved format error messages with correct locus and more detailed +! "unexpected element" messages. + +SUBROUTINE format_labels + IMPLICIT NONE + +1 FORMAT (A, & + A, & + Q, & ! { dg-error "Unexpected element 'Q'" } + A) + +2 FORMAT (A, & + I, & ! { dg-error "Nonnegative width" } + A) + +END SUBROUTINE format_labels + +SUBROUTINE format_strings + IMPLICIT NONE + CHARACTER(len=32), PARAMETER :: str = "hello" + INTEGER :: x + + PRINT '(A, Q, A)', & ! { dg-error "Unexpected element 'Q'" } + str, str, str ! { dg-bogus "Unexpected element" } + + PRINT '(A, ' // & ! { dg-error "Nonnegative width" } + ' I, ' // & + ' A)', str, str, str ! { dg-bogus "Nonnegative width" } + + READ '(Q)', & ! { dg-error "Unexpected element 'Q'" } + x ! { dg-bogus "Unexpected element" } + +END SUBROUTINE format_strings diff --git a/Fortran/gfortran/regression/fmt_error_4.f90 b/Fortran/gfortran/regression/fmt_error_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_error_4.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! { dg-shouldfail "runtime error" } + +! PR fortran/29835 +! Check for improved format error messages with correct locus and more detailed +! "unexpected element" messages. + +! Now with runtime supplied format strings +SUBROUTINE format_runtime (fmtstr) + IMPLICIT NONE + CHARACTER(len=*) :: fmtstr + CHARACTER(len=32), PARAMETER :: str = "hello" + + PRINT fmtstr, str, str, str +END SUBROUTINE format_runtime + +PROGRAM main + IMPLICIT NONE + CALL format_runtime ('(A, Q, A)') +END PROGRAM main + +! { dg-output "Unexpected element 'Q'.*(\r*\n+)\\(A, Q, A\\)(\r*\n+) \\^" } diff --git a/Fortran/gfortran/regression/fmt_error_5.f90 b/Fortran/gfortran/regression/fmt_error_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_error_5.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! { dg-shouldfail "runtime error" } + +! PR fortran/29835 +! Check for improved format error messages with correct locus and more detailed +! "unexpected element" messages. + +! Now with runtime supplied format strings +SUBROUTINE format_runtime (fmtstr) + IMPLICIT NONE + CHARACTER(len=*) :: fmtstr + INTEGER :: x + + PRINT fmtstr, x +END SUBROUTINE format_runtime + +PROGRAM main + IMPLICIT NONE + CALL format_runtime ('(Q)') +END PROGRAM main + +! { dg-output "Unexpected element 'Q'.*(\r*\n+)\\(Q\\)(\r*\n+) \\^" } diff --git a/Fortran/gfortran/regression/fmt_error_6.f90 b/Fortran/gfortran/regression/fmt_error_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_error_6.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! { dg-options } +! PR37988 Edit descriptor checking (compile time) for "T)" +! Test case derived from the reporter. + 8001 FORMAT(//,' SIGNIFICANCE LEVEL =',F7.4, 21H ONE-SIDED AT THE LEFT) ! { dg-error "required with T descriptor" } + end diff --git a/Fortran/gfortran/regression/fmt_error_7.f b/Fortran/gfortran/regression/fmt_error_7.f --- /dev/null +++ b/Fortran/gfortran/regression/fmt_error_7.f @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-std=f95" } + +! PR37446 Diagnostic of edit descriptors, esp. EN + character(40) :: fmt_string + write(*, '(1P,2E12.4)') 1.0 + write(*,'(EN)') 5.0 ! { dg-error "positive width required" } + write(*,'("abcdefg",EN6,"hjjklmnop")') 5.0 ! { dg-error "Period required" } + end diff --git a/Fortran/gfortran/regression/fmt_error_8.f b/Fortran/gfortran/regression/fmt_error_8.f --- /dev/null +++ b/Fortran/gfortran/regression/fmt_error_8.f @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-std=f95" } +! PR35754 -std=f95: Reject "1P2E12.4" w/o a comma after the "P" +! PR +! Test case provided by Jerry DeLisle + character(40) :: fmt_string + write(*, '(1P2E12.4)') 1.0 ! { dg-error "Comma required" } + write(*, '(1PT12,F12.4)') 1.0 ! { dg-error "Comma required" } + write(*, '(1PE12.4)') 1.0 ! This is OK by the standard 10.1.1 + write (*,'(1PD24.15,F4.2,0P)') 1.0d0 ! This OK too. + end diff --git a/Fortran/gfortran/regression/fmt_error_9.f b/Fortran/gfortran/regression/fmt_error_9.f --- /dev/null +++ b/Fortran/gfortran/regression/fmt_error_9.f @@ -0,0 +1,29 @@ +! { dg-do run } +! { dg-options "-std=gnu" } +! PR38439 I/O PD edit descriptor inconsistency +! Test case prepared by Jerry DeLisle + character(len=25) :: str + character(len=132) :: msg, line + str = '(1pd24.15e6)' + line = "initial string" + x = 555.25 + + write (line,str,iostat=istat, iomsg=msg) 1.0d0, 1.234 + if (istat.ne.5006 .or. msg(1:15).ne."Period required") STOP 1 + if (line.ne."initial string") STOP 2 + + str = '(1pf0.15)' + write (line,str,iostat=istat, iomsg=msg) 1.0d0 + if (istat.ne.0) STOP 3 + read (*,str,iostat=istat, iomsg=msg) x + if (istat.ne.5006 .or. msg(1:10).ne."Zero width") STOP 4 + if (x.ne.555.25) STOP 5 + + write (line,'(1pd24.15e11.3)') 1.0d0, 1.234 + if (line.ne." 1.000000000000000D+00 1.234E+00") STOP 6 + + str = '(1p2d24.15)' + msg = " 1.000000000000000D+00 1.233999967575073D+00That's it!" + write (line,'(1p2d24.15a)') 1.0d0, 1.234, "That's it!" + if (line.ne.msg) print *, msg + end diff --git a/Fortran/gfortran/regression/fmt_exhaust.f90 b/Fortran/gfortran/regression/fmt_exhaust.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_exhaust.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! PR27304 Test running out of data descriptors with data remaining. +! Derived from case in PR. Submitted by Jerry DeLisle . + program test + implicit none + integer :: n + n = 1 + open(10, status="scratch") + write(10,"(i7,(' abcd'))", err=10) n, n + STOP 1 + 10 close(10) + end program test diff --git a/Fortran/gfortran/regression/fmt_f0_1.f90 b/Fortran/gfortran/regression/fmt_f0_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_f0_1.f90 @@ -0,0 +1,64 @@ +! { dg-do run } +! PR39304 write of 0.0 with F0.3 gives ** +! PR47567 Small absolute values. +! Test case developed from case provided by reporter. + REAL :: x + CHARACTER(80) :: str + x = 0.0 + write (str,'(f0.0)') x + if (str.ne."0.") STOP 1 + write (str,'(f0.1)') x + if (str.ne.".0") STOP 2 + write (str,'(f0.2)') x + if (str.ne.".00") STOP 3 + write (str,'(f0.3)') x + if (str.ne.".000") STOP 4 + write (str,'(f0.4)') x + if (str.ne.".0000") STOP 5 + write (str,'(F0.0)') 0.0 + if (str.ne."0.") STOP 6 + write (str,'(F0.0)') 0.001 + if (str.ne."0.") STOP 7 + write (str,'(F0.0)') 0.01 + if (str.ne."0.") STOP 8 + write (str,'(F0.0)') 0.1 + if (str.ne."0.") STOP 9 + write (str,'(F1.0)') -0.0 + if (str.ne."*") STOP 10 + write (str,'(F1.0)') 0.001 + if (str.ne."*") STOP 11 + write (str,'(F1.0)') 0.01 + if (str.ne."*") STOP 12 + write (str,'(F1.0)') 0.1 + if (str.ne."*") STOP 13 + write (str,'(F2.0)') -0.001 + if (str.ne."**") STOP 14 + write (str,'(F2.0)') -0.01 + if (str.ne."**") STOP 15 + write (str,'(F2.0)') -0.1 + if (str.ne."**") STOP 16 + write (str,'(F0.2)') 0.0 + if (str.ne.".00") STOP 17 + write (str,'(F0.0)') -0.0 + if (str.ne."-0.") STOP 18 + write (str,'(F0.1)') -0.0 + if (str.ne."-.0") STOP 19 + write (str,'(F0.2)') -0.0 + if (str.ne."-.00") STOP 20 + write (str,'(F0.3)') -0.0 + if (str.ne."-.000") STOP 21 + write (str,'(F3.0)') -0.0 + if (str.ne."-0.") STOP 22 + write (str,'(F2.0)') -0.0 + if (str.ne."**") STOP 23 + write (str,'(F1.0)') -0.0 + if (str.ne."*") STOP 24 + write (str,'(F0.1)') -0.0 + if (str.ne."-.0") STOP 25 + write (str,'(F3.1)') -0.0 + if (str.ne."-.0") STOP 26 + write (str,'(F2.1)') -0.0 + if (str.ne."**") STOP 27 + write (str,'(F1.1)') -0.0 + if (str.ne."*") STOP 28 + END diff --git a/Fortran/gfortran/regression/fmt_f0_2.f90 b/Fortran/gfortran/regression/fmt_f0_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_f0_2.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! PR77393 +program testbigf0 ! Can enormous numbers be printed with F0.0 format? + use ISO_FORTRAN_ENV + implicit none + integer i + integer, parameter :: j(size(real_kinds)+4)=[REAL_KINDS, [4, 4, 4, 4]] + character(10000) :: str + + do i=1,size(real_kinds) + select case (i) + case (1) + write(str, "(f0.0)") -huge(real(1.0,kind=j(1))) + case (2) + write(str, "(f0.0)") -huge(real(1.0,kind=j(2))) + case (3) + write(str, "(f0.0)") -huge(real(1.0,kind=j(3))) + case (4) + write(str, "(f0.10)") -huge(real(1.0,kind=j(4))) + end select + enddo +end program testbigf0 + diff --git a/Fortran/gfortran/regression/fmt_f0_3.f90 b/Fortran/gfortran/regression/fmt_f0_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_f0_3.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! PR77393, this segfaulted before +program testbigf0 + use ISO_FORTRAN_ENV + implicit none + integer i + integer, parameter :: j(size(real_kinds)+4)=[REAL_KINDS, [4, 4, 4, 4]] + character(10000) :: str + + do i=1,size(real_kinds) + select case (i) + case (1) + write(str, "(f8.0)") huge(real(1.0,kind=j(1))) + case (2) + write(str, "(f18.0)") huge(real(1.0,kind=j(2))) + case (3) + write(str, "(f20.0)") huge(real(1.0,kind=j(3))) + case (4) + write(str, "(f40.0)") huge(real(1.0,kind=j(4))) + end select + enddo +end program testbigf0 + diff --git a/Fortran/gfortran/regression/fmt_f_an_p.f b/Fortran/gfortran/regression/fmt_f_an_p.f --- /dev/null +++ b/Fortran/gfortran/regression/fmt_f_an_p.f @@ -0,0 +1,10 @@ +! { dg-do run } +! PR38285 wrong i/o output: interaction between f and p for output +! Special case of kPFw.d when d = 0 + program f_and_p + character(28) string + write(string,1) 3742. , 0.3742 + 1 format ( f14.0, 4pf14.0 ) + if (string.ne." 3742. 3742.") STOP 1 + end program f_and_p + diff --git a/Fortran/gfortran/regression/fmt_f_default_field_width_1.f90 b/Fortran/gfortran/regression/fmt_f_default_field_width_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_f_default_field_width_1.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +! { dg-options "-cpp -fdec" } +! +! Test case for the default field widths enabled by the -fdec-format-defaults flag. +! +! This feature is not part of any Fortran standard, but it is supported by the +! Oracle Fortran compiler and others. +! + +program test + implicit none + character(50) :: buffer + + real(4) :: real_4 + real(8) :: real_8 +#ifdef __GFC_REAL_16__ + real(16) :: real_16 +#endif + integer :: len + character(*), parameter :: fmt = "(A, F, A)" + + real_4 = 4.18 + write(buffer, fmt) ':',real_4,':' + print *,buffer + if (buffer.ne.": 4.1799998:") stop 1 + + real_4 = 0.00000018 + write(buffer, fmt) ':',real_4,':' + print *,buffer + if (buffer.ne.": 0.0000002:") stop 2 + + real_8 = 4.18 + write(buffer, fmt) ':',real_8,':' + print *,buffer + len = len_trim(buffer) + if (len /= 27) stop 3 + +#ifdef __GFC_REAL_16__ + real_16 = 4.18 + write(buffer, fmt) ':',real_16,':' + print *,buffer + len = len_trim(buffer) + if (len /= 44) stop 4 +#endif +end diff --git a/Fortran/gfortran/regression/fmt_f_default_field_width_2.f90 b/Fortran/gfortran/regression/fmt_f_default_field_width_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_f_default_field_width_2.f90 @@ -0,0 +1,48 @@ +! { dg-do run } +! { dg-options "-cpp -fdec-format-defaults" } +! +! Test case for the default field widths enabled by the -fdec-format-defaults flag. +! +! This feature is not part of any Fortran standard, but it is supported by the +! Oracle Fortran compiler and others. +! +! Test case added by Mark Eggleston to check +! use of -fdec-format-defaults +! + +program test + implicit none + character(50) :: buffer + + real(4) :: real_4 + real(8) :: real_8 +#ifdef __GFC_REAL_16__ + real(16) :: real_16 +#endif + integer :: len + character(*), parameter :: fmt = "(A, F, A)" + + real_4 = 4.18 + write(buffer, fmt) ':',real_4,':' + print *,buffer + if (buffer.ne.": 4.1799998:") stop 1 + + real_4 = 0.00000018 + write(buffer, fmt) ':',real_4,':' + print *,buffer + if (buffer.ne.": 0.0000002:") stop 2 + + real_8 = 4.18 + write(buffer, fmt) ':',real_8,':' + print *,buffer + len = len_trim(buffer) + if (len /= 27) stop 3 + +#ifdef __GFC_REAL_16__ + real_16 = 4.18 + write(buffer, fmt) ':',real_16,':' + print *,buffer + len = len_trim(buffer) + if (len /= 44) stop 4 +#endif +end diff --git a/Fortran/gfortran/regression/fmt_f_default_field_width_3.f90 b/Fortran/gfortran/regression/fmt_f_default_field_width_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_f_default_field_width_3.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! { dg-options "-cpp -fdec -fno-dec-format-defaults" } +! +! Test case for the default field widths not enabled. +! +! Test case added by Mark Eggleston to check +! use of -fno-dec-format-defaults +! + +program test + implicit none + character(50) :: buffer + + real*4 :: real_4 + real*8 :: real_8 +#ifdef __GFC_REAL_16__ + real*16 :: real_16 +#endif + integer :: len + character(*), parameter :: fmt = "(A, F, A)" + + real_4 = 4.18 + write(buffer, fmt) ':',real_4,':' ! { dg-error "Nonnegative width required" } + + real_4 = 0.00000018 + write(buffer, fmt) ':',real_4,':' ! { dg-error "Nonnegative width required" } + + real_8 = 4.18 + write(buffer, fmt) ':',real_8,':' ! { dg-error "Nonnegative width required" } + +#ifdef __GFC_REAL_16__ + real_16 = 4.18 + write(buffer, fmt) ':',real_16,':' ! { dg-error "Nonnegative width required" "" { target fortran_real_16 } } +#endif +end diff --git a/Fortran/gfortran/regression/fmt_float.f90 b/Fortran/gfortran/regression/fmt_float.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_float.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! PR33225 Missing last digit in some formatted output (on 32bit targets) +! related to per kind write_float patch +! Test case from PR. +real x +x = 1.0 +print '(3E20.2e2)', x, x/10.0, x/100.0 +print '(3E20.2e3)', x, x/10.0, x/100.0 +print '(3E20.2e4)', x, x/10.0, x/100.0 +print '(3E20.2e5)', x, x/10.0, x/100.0 +print '(3E20.2e6)', x, x/10.0, x/100.0 +print '(3E20.2e7)', x, x/10.0, x/100.0 +print '(3E20.3e2)', x, x/10.0, x/100.0 +print '(3E20.3e3)', x, x/10.0, x/100.0 +print '(3E20.3e4)', x, x/10.0, x/100.0 +print '(3E20.3e5)', x, x/10.0, x/100.0 +print '(3E20.3e6)', x, x/10.0, x/100.0 +print '(3E20.3e7)', x, x/10.0, x/100.0 +print '(3E20.4e2)', x, x/10.0, x/100.0 +print '(3E20.4e3)', x, x/10.0, x/100.0 +print '(3E20.4e4)', x, x/10.0, x/100.0 +print '(3E20.4e5)', x, x/10.0, x/100.0 +print '(3E20.4e6)', x, x/10.0, x/100.0 +print '(3E20.4e7)', x, x/10.0, x/100.0 +end +! { dg-output " 0.10E\\+01 0.10E\\+00 0.10E-01(\r*\n+)" } +! { dg-output " 0.10E\\+001 0.10E\\+000 0.10E-001(\r*\n+)" } +! { dg-output " 0.10E\\+0001 0.10E\\+0000 0.10E-0001(\r*\n+)" } +! { dg-output " 0.10E\\+00001 0.10E\\+00000 0.10E-00001(\r*\n+)" } +! { dg-output " 0.10E\\+000001 0.10E\\+000000 0.10E-000001(\r*\n+)" } +! { dg-output " 0.10E\\+0000001 0.10E\\+0000000 0.10E-0000001(\r*\n+)" } +! { dg-output " 0.100E\\+01 0.100E\\+00 0.100E-01(\r*\n+)" } +! { dg-output " 0.100E\\+001 0.100E\\+000 0.100E-001(\r*\n+)" } +! { dg-output " 0.100E\\+0001 0.100E\\+0000 0.100E-0001(\r*\n+)" } +! { dg-output " 0.100E\\+00001 0.100E\\+00000 0.100E-00001(\r*\n+)" } +! { dg-output " 0.100E\\+000001 0.100E\\+000000 0.100E-000001(\r*\n+)" } +! { dg-output " 0.100E\\+0000001 0.100E\\+0000000 0.100E-0000001(\r*\n+)" } +! { dg-output " 0.1000E\\+01 0.1000E\\+00 0.1000E-01(\r*\n+)" } +! { dg-output " 0.1000E\\+001 0.1000E\\+000 0.1000E-001(\r*\n+)" } +! { dg-output " 0.1000E\\+0001 0.1000E\\+0000 0.1000E-0001(\r*\n+)" } +! { dg-output " 0.1000E\\+00001 0.1000E\\+00000 0.1000E-00001(\r*\n+)" } +! { dg-output " 0.1000E\\+000001 0.1000E\\+000000 0.1000E-000001(\r*\n+)" } +! { dg-output " 0.1000E\\+0000001 0.1000E\\+0000000 0.1000E-0000001(\r*\n+)" } diff --git a/Fortran/gfortran/regression/fmt_fw_d.f90 b/Fortran/gfortran/regression/fmt_fw_d.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_fw_d.f90 @@ -0,0 +1,131 @@ +! { dg-do run } +! { dg-options "-std=gnu" } +! PR47567 Wrong output for small absolute values with F editing +! Test case provided by Thomas Henlich +call verify_fmt(1.2) +call verify_fmt(-0.1) +call verify_fmt(1e-7) +call verify_fmt(1e-6) +call verify_fmt(1e-5) +call verify_fmt(1e-4) +call verify_fmt(1e-3) +call verify_fmt(1e-2) +call verify_fmt(-1e-7) +call verify_fmt(-1e-6) +call verify_fmt(-1e-5) +call verify_fmt(-1e-4) +call verify_fmt(-1e-3) +call verify_fmt(-1e-2) +call verify_fmt(tiny(0.0)) +call verify_fmt(-tiny(0.0)) +call verify_fmt(0.0) +call verify_fmt(-0.0) +call verify_fmt(100.0) +call verify_fmt(.12345) +call verify_fmt(1.2345) +call verify_fmt(12.345) +call verify_fmt(123.45) +call verify_fmt(1234.5) +call verify_fmt(12345.6) +call verify_fmt(123456.7) +call verify_fmt(99.999) +call verify_fmt(-100.0) +call verify_fmt(-99.999) +end + +! loop through values for w, d +subroutine verify_fmt(x) + real, intent(in) :: x + integer :: w, d + character(len=80) :: str, str0 + integer :: len, len0 + character(len=80) :: fmt_w_d + logical :: result, have_num, verify_fmt_w_d + + do d = 0, 10 + have_num = .false. + do w = 1, 20 + str = fmt_w_d(x, w, d) + len = len_trim(str) + + result = verify_fmt_w_d(x, str, len, w, d) + if (.not. have_num .and. result) then + have_num = .true. + str0 = fmt_w_d(x, 0, d) + len0 = len_trim(str0) + if (len /= len0) then + call errormsg(x, str0, len0, 0, d, "selected width is wrong") + else + if (str(:len) /= str0(:len0)) call errormsg(x, str0, len0, 0, d, "output is wrong") + end if + end if + end do + end do + +end subroutine + +! checks for standard-compliance, returns .true. if field contains number, .false. on overflow +function verify_fmt_w_d(x, str, len, w, d) + real, intent(in) :: x + character(len=80), intent(in) :: str + integer, intent(in) :: len + integer, intent(in) :: w, d + logical :: verify_fmt_w_d + integer :: pos + character :: decimal_sep = "." + + verify_fmt_w_d = .false. + + ! check if string is all asterisks + pos = verify(str(:len), "*") + if (pos == 0) return + + ! check if string contains a digit + pos = scan(str(:len), "0123456789") + if (pos == 0) call errormsg(x, str, len, w, d, "no digits") + + ! contains decimal separator? + pos = index(str(:len), decimal_sep) + if (pos == 0) call errormsg(x, str, len, w, d, "no decimal separator") + + ! negative and starts with minus? + if (sign(1., x) < 0.) then + pos = verify(str, " ") + if (pos == 0) call errormsg(x, str, len, w, d, "only spaces") + if (str(pos:pos) /= "-") call errormsg(x, str, len, w, d, "no minus sign") + end if + + verify_fmt_w_d = .true. +end function + +function fmt_w_d(x, w, d) + real, intent(in) :: x + integer, intent(in) :: w, d + character(len=*) :: fmt_w_d + character(len=10) :: fmt, make_fmt + + fmt = make_fmt(w, d) + write (fmt_w_d, fmt) x +end function + +function make_fmt(w, d) + integer, intent(in) :: w, d + character(len=10) :: make_fmt + + write (make_fmt,'("(f",i0,".",i0,")")') w, d +end function + +subroutine errormsg(x, str, len, w, d, reason) + real, intent(in) :: x + character(len=80), intent(in) :: str + integer, intent(in) :: len, w, d + character(len=*), intent(in) :: reason + integer :: fmt_len + character(len=10) :: fmt, make_fmt + + fmt = make_fmt(w, d) + fmt_len = len_trim(fmt) + + !print *, "print '", fmt(:fmt_len), "', ", x, " ! => ", str(:len), ": ", reason + STOP 1 +end subroutine diff --git a/Fortran/gfortran/regression/fmt_g.f b/Fortran/gfortran/regression/fmt_g.f --- /dev/null +++ b/Fortran/gfortran/regression/fmt_g.f @@ -0,0 +1,43 @@ +! { dg-do run } +! PR47285 G format outputs wrong number of characters. +! Test case prepared by Jerry DeLisle + PROGRAM FOO + character(len=50) :: buffer + + WRITE(buffer,"(G0.5,'<')") -10000. + if (buffer.ne."-10000.<") STOP 1 + WRITE(buffer,"(G1.5E5,'<')") -10000. + if (buffer.ne."*<") STOP 2 + WRITE(buffer,"(G2.5E5,'<')") -10000. + if (buffer.ne."**<") STOP 3 + WRITE(buffer,"(G3.5E5,'<')") -10000. + if (buffer.ne."***<") STOP 4 + WRITE(buffer,"(G4.5E5,'<')") -10000. + if (buffer.ne."****<") STOP 5 + WRITE(buffer,"(G5.5E5,'<')") -10000. + if (buffer.ne."*****<") STOP 6 + WRITE(buffer,"(G6.5E5,'<')") -10000. + if (buffer.ne."******<") STOP 7 + WRITE(buffer,"(G7.5E5,'<')") -10000. + if (buffer.ne."*******<") STOP 8 + WRITE(buffer,"(G8.5E5,'<')") -10000. + if (buffer.ne."********<") STOP 9 + WRITE(buffer,"(G9.5E5,'<')") -10000. + if (buffer.ne."*********<") STOP 10 + WRITE(buffer,"(G10.5E5,'<')") -10000. + if (buffer.ne."**********<") STOP 11 + WRITE(buffer,"(G11.5E5,'<')") -10000. + if (buffer.ne."***********<") STOP 12 + WRITE(buffer,"(G12.5E5,'<')") -10000. + if (buffer.ne."************<") STOP 13 + WRITE(buffer,"(G13.5E5,'<')") -10000. + if (buffer.ne."*************<") STOP 14 + WRITE(buffer,"(G14.5E5,'<')") -10000. + if (buffer.ne."-10000. <") STOP 15 + WRITE(buffer,"(G15.5E5,'<')") -10000. + if (buffer.ne." -10000. <") STOP 16 + WRITE(buffer,"(G16.5E5,'<')") -10000. + if (buffer.ne." -10000. <") STOP 17 + + STOP + END diff --git a/Fortran/gfortran/regression/fmt_g0_1.f08 b/Fortran/gfortran/regression/fmt_g0_1.f08 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_g0_1.f08 @@ -0,0 +1,20 @@ +! { dg-do run } +! PR36420 Fortran 2008: g0 edit descriptor +! Test case provided by Jerry DeLisle + character(25) :: string = "(g0,g0,g0)" + character(50) :: buffer + write(buffer, '(g0,g0,g0)') ':',12340,':' + if (buffer.ne.":12340:") STOP 1 + write(buffer, string) ':',0,':' + if (buffer.ne.":0:") STOP 2 + write(buffer, string) ':',1.0_8/3.0_8,':' + if (buffer.ne.":0.33333333333333331:") STOP 3 + write(buffer, '(1x,a,g0,a)') ':',1.0_8/3.0_8,':' + if (buffer.ne." :0.33333333333333331:") STOP 4 + write(buffer, string) ':',"hello",':' + if (buffer.ne.":hello:") STOP 5 + write(buffer, "(g0,g0,g0,g0)") ':',.true.,.false.,':' + if (buffer.ne.":TF:") STOP 6 + write(buffer, "(g0,g0,',',g0,g0)") '(',( 1.2345_8, 2.4567_8 ),')' + if (buffer.ne."(1.2344999999999999,2.4567000000000001)") STOP 7 +end diff --git a/Fortran/gfortran/regression/fmt_g0_2.f08 b/Fortran/gfortran/regression/fmt_g0_2.f08 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_g0_2.f08 @@ -0,0 +1,11 @@ +! { dg-do run } +! { dg-options "-std=f95 -pedantic " } +! { dg-shouldfail "Zero width in format descriptor" } +! PR36420 Fortran 2008: g0 edit descriptor +! Test case provided by Jerry DeLisle + character(25) :: string = "(g0,g0,g0)" + character(33) :: buffer + write(buffer, string) ':',0,':' + if (buffer.ne.":0:") STOP 1 +end +! { dg-output "Fortran runtime error: Zero width in format descriptor(\n|\r\n|\r)" } diff --git a/Fortran/gfortran/regression/fmt_g0_3.f08 b/Fortran/gfortran/regression/fmt_g0_3.f08 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_g0_3.f08 @@ -0,0 +1,7 @@ +! { dg-do compile } +! { dg-options "-std=f95" }! PR36420 Fortran 2008: g0 edit descriptor +! Test case provided by Jerry DeLisle + character(25) :: string = "(g0,g0,g0)" + character(33) :: buffer + write(buffer, '(g0,g0,g0)') ':',12340,':' ! { dg-error "Fortran 2008:" } +end diff --git a/Fortran/gfortran/regression/fmt_g0_4.f08 b/Fortran/gfortran/regression/fmt_g0_4.f08 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_g0_4.f08 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! PR36725 Compile time error for g0 edit descriptor +character(30) :: line +write(line, '(g0.3)') 0.1 +if (line.ne." 1.000E-01") STOP 1 +write(line, '(g0.9)') 1.0 +if (line.ne."1.000000000E+00") STOP 2 +write(line, '(g0.5)') 29.23 +if (line.ne." 2.92300E+01") STOP 3 +write(line, '(g0.8)') -28.4 +if (line.ne."-2.83999996E+01") STOP 4 +write(line, '(g0.8)') -0.0001 +if (line.ne."-9.99999975E-05") STOP 5 +end diff --git a/Fortran/gfortran/regression/fmt_g0_5.f08 b/Fortran/gfortran/regression/fmt_g0_5.f08 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_g0_5.f08 @@ -0,0 +1,39 @@ +! { dg-do run } +! { dg-add-options ieee } +! PR48589 Invalid G0/G0.d editing for NaN/infinity +! Test case by Thomas Henlich +program test_g0_special + + call check_all("(g10.3)", "(f10.3)") + call check_all("(g10.3e3)", "(f10.3)") + call check_all("(spg10.3)", "(spf10.3)") + call check_all("(spg10.3e3)", "(spf10.3)") + !print *, "-----------------------------------" + call check_all("(g0)", "(f0.0)") + call check_all("(g0.15)", "(f0.0)") + call check_all("(spg0)", "(spf0.0)") + call check_all("(spg0.15)", "(spf0.0)") +contains + subroutine check_all(fmt1, fmt2) + character(len=*), intent(in) :: fmt1, fmt2 + real(8) :: one = 1.0D0, zero = 0.0D0, nan, pinf, minf + + nan = zero / zero + pinf = one / zero + minf = -one / zero + call check_equal(fmt1, fmt2, nan) + call check_equal(fmt1, fmt2, pinf) + call check_equal(fmt1, fmt2, minf) + end subroutine check_all + subroutine check_equal(fmt1, fmt2, r) + real(8), intent(in) :: r + character(len=*), intent(in) :: fmt1, fmt2 + character(len=80) :: s1, s2 + + write(s1, fmt1) r + write(s2, fmt2) r + if (s1 /= s2) STOP 1 + !if (s1 /= s2) print "(6a)", trim(fmt1), ": '", trim(s1), "' /= '", trim(s2), "'" + !print "(6a)", trim(fmt1), ": '", trim(s1), "' /= '", trim(s2), "'" + end subroutine check_equal +end program test_g0_special diff --git a/Fortran/gfortran/regression/fmt_g0_6.f08 b/Fortran/gfortran/regression/fmt_g0_6.f08 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_g0_6.f08 @@ -0,0 +1,83 @@ +! { dg-do run } +! { dg-options "-ffloat-store" } +! PR48602 Invalid F conversion of G descriptor for values close to powers of 10 +! Test case provided by Thomas Henlich +program test_g0fr + use iso_fortran_env + implicit none + integer, parameter :: RT = REAL64 + + call check_all(0.0_RT, 15, 2, 0) + call check_all(0.991_RT, 15, 2, 0) + call check_all(0.995_RT, 15, 2, 0) + call check_all(0.996_RT, 15, 2, 0) + call check_all(0.999_RT, 15, 2, 0) +contains + subroutine check_all(val, w, d, e) + real(kind=RT), intent(in) :: val + integer, intent(in) :: w + integer, intent(in) :: d + integer, intent(in) :: e + + call check_f_fmt(val, 'C', w, d, e) + call check_f_fmt(val, 'U', w, d, e) + call check_f_fmt(val, 'D', w, d, e) + end subroutine check_all + + subroutine check_f_fmt(val, roundmode, w, d, e) + real(kind=RT), intent(in) :: val + character, intent(in) :: roundmode + integer, intent(in) :: w + integer, intent(in) :: d + integer, intent(in) :: e + character(len=80) :: fmt_f, fmt_g + character(len=80) :: s_f, s_g + real(kind=RT) :: mag, lower, upper + real(kind=RT) :: r + integer :: n, dec + + mag = abs(val) + if (e == 0) then + n = 4 + else + n = e + 2 + end if + select case (roundmode) + case('U') + r = 1.0_RT + case('D') + r = 0.0_RT + case('C') + r = 0.5_RT + end select + + if (mag == 0) then + write(fmt_f, "('R', a, ',F', i0, '.', i0, ',', i0, 'X')") roundmode, w - n, d - 1, n + else + do dec = d, 0, -1 + lower = 10.0_RT ** (d - 1 - dec) - r * 10.0_RT ** (- dec - 1) + upper = 10.0_RT ** (d - dec) - r * 10.0_RT ** (- dec) + if (lower <= mag .and. mag < upper) then + write(fmt_f, "('R', a, ',F', i0, '.', i0, ',', i0, 'X')") roundmode, w - n, dec, n + exit + end if + end do + end if + if (len_trim(fmt_f) == 0) then + ! e editing + return + end if + if (e == 0) then + write(fmt_g, "('R', a, ',G', i0, '.', i0)") roundmode, w, d + else + write(fmt_g, "('R', a, ',G', i0, '.', i0, 'e', i0)") roundmode, w, d, e + end if + write(s_g, "('''', " // trim(fmt_g) // ",'''')") val + write(s_f, "('''', " // trim(fmt_f) // ",'''')") val + if (s_g /= s_f) STOP 1 + !if (s_g /= s_f) then + !print "(a,g0,a,g0)", "lower=", lower, " upper=", upper + ! print "(a, ' /= ', a, ' ', a, '/', a, ':', g0)", trim(s_g), trim(s_f), trim(fmt_g), trim(fmt_f), val + !end if + end subroutine check_f_fmt +end program test_g0fr diff --git a/Fortran/gfortran/regression/fmt_g0_7.f08 b/Fortran/gfortran/regression/fmt_g0_7.f08 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_g0_7.f08 @@ -0,0 +1,31 @@ +! { dg-do run } +! { dg-options "-std=gnu" } +! PR58722 +program testit +use ISO_FORTRAN_ENV + implicit none + integer, parameter :: j(size(real_kinds)+4)=[REAL_KINDS, [4, 4, 4, 4]] + character(50) :: astring + integer :: i, l, n + + n = 0 + do i=1,size(real_kinds) + if (i == 1) then + write(astring, '(ru,g0)') 1.0/real(10.0, kind=j(1)) + else if (i == 2) then + write(astring, '(ru,g0)') 1.0/real(10.0, kind=j(2)) + else if (i == 3) then + write(astring, '(ru,g0)') 1.0/real(10.0, kind=j(3)) + else if (i == 4) then + write(astring, '(ru,g0)') 1.0/real(10.0, kind=j(4)) + end if + if (astring(2:2) /= '9') then + l = index(astring, 'E') + if (l /= 0) then + !print *, i, l, trim(astring) + n = n + l + end if + end if + end do + if (n /= 0) STOP 1 +end program diff --git a/Fortran/gfortran/regression/fmt_g_1.f90 b/Fortran/gfortran/regression/fmt_g_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_g_1.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! PR59771 Cleanup handling of Gw.0 and Gw.0Ee format +! Test case prepared by Dominique d'Humieres + PROGRAM FOO + character(len=60) :: buffer, buffer1 + + write (buffer ,'(6(1X,1PG9.0e2))') 0.0, 0.04, 0.06, 0.4, 0.6, 243.0 + write (buffer1,'(6(1X,1PE9.0e2))') 0.0, 0.04, 0.06, 0.4, 0.6, 243.0 + + if (buffer /= buffer1) STOP 1 + end diff --git a/Fortran/gfortran/regression/fmt_g_default_field_width_1.f90 b/Fortran/gfortran/regression/fmt_g_default_field_width_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_g_default_field_width_1.f90 @@ -0,0 +1,50 @@ +! { dg-do run } +! { dg-options "-cpp -fdec" } +! +! Test case for the default field widths enabled by the -fdec-format-defaults flag. +! +! This feature is not part of any Fortran standard, but it is supported by the +! Oracle Fortran compiler and others. +! + +program test + implicit none + character(50) :: buffer + + real(4) :: real_4 + real(8) :: real_8 +#ifdef __GFC_REAL_16__ + real(16) :: real_16 +#endif + integer :: len + character(*), parameter :: fmt = "(A, G, A)" + + real_4 = 4.18 + write(buffer, fmt) ':',real_4,':' + print *,buffer + if (buffer.ne.": 4.180000 :") stop 1 + + real_4 = 0.00000018 + write(buffer, fmt) ':',real_4,':' + print *,buffer + if (buffer.ne.": 0.1800000E-06:") stop 2 + + real_4 = 18000000.4 + write(buffer, fmt) ':',real_4,':' + print *,buffer + if (buffer.ne.": 0.1800000E+08:") stop 3 + + real_8 = 4.18 + write(buffer, fmt) ':',real_8,':' + print *,buffer + len = len_trim(buffer) + if (len /= 27) stop 4 + +#ifdef __GFC_REAL_16__ + real_16 = 4.18 + write(buffer, fmt) ':',real_16,':' + print *,buffer + len = len_trim(buffer) + if (len /= 44) stop 5 +#endif +end diff --git a/Fortran/gfortran/regression/fmt_g_default_field_width_2.f90 b/Fortran/gfortran/regression/fmt_g_default_field_width_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_g_default_field_width_2.f90 @@ -0,0 +1,53 @@ +! { dg-do run } +! { dg-options "-cpp -fdec-format-defaults" } +! +! Test case for the default field widths enabled by the -fdec-format-defaults flag. +! +! This feature is not part of any Fortran standard, but it is supported by the +! Oracle Fortran compiler and others. +! +! Test case added by Mark Eggleston to check +! use of -fdec-format-defaults +! + +program test + implicit none + character(50) :: buffer + + real(4) :: real_4 + real(8) :: real_8 +#ifdef __GFC_REAL_16__ + real(16) :: real_16 +#endif + integer :: len + character(*), parameter :: fmt = "(A, G, A)" + + real_4 = 4.18 + write(buffer, fmt) ':',real_4,':' + print *,buffer + if (buffer.ne.": 4.180000 :") stop 1 + + real_4 = 0.00000018 + write(buffer, fmt) ':',real_4,':' + print *,buffer + if (buffer.ne.": 0.1800000E-06:") stop 2 + + real_4 = 18000000.4 + write(buffer, fmt) ':',real_4,':' + print *,buffer + if (buffer.ne.": 0.1800000E+08:") stop 3 + + real_8 = 4.18 + write(buffer, fmt) ':',real_8,':' + print *,buffer + len = len_trim(buffer) + if (len /= 27) stop 4 + +#ifdef __GFC_REAL_16__ + real_16 = 4.18 + write(buffer, fmt) ':',real_16,':' + print *,buffer + len = len_trim(buffer) + if (len /= 44) stop 5 +#endif +end diff --git a/Fortran/gfortran/regression/fmt_g_default_field_width_3.f90 b/Fortran/gfortran/regression/fmt_g_default_field_width_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_g_default_field_width_3.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! { dg-options "-cpp -fdec -fno-dec-format-defaults" } +! +! Test case for the default field widths not enabled. +! +! Test case added by Mark Eggleston to check +! use of -fno-dec-format-defaults +! + +program test + implicit none + character(50) :: buffer + + real(4) :: real_4 + real(8) :: real_8 +#ifdef __GFC_REAL_16__ + real(16) :: real_16 +#endif + integer :: len + character(*), parameter :: fmt = "(A, G, A)" + + real_4 = 4.18 + write(buffer, fmt) ':',real_4,':' ! { dg-error "Positive width required" } + + real_4 = 0.00000018 + write(buffer, fmt) ':',real_4,':' ! { dg-error "Positive width required" } + + real_4 = 18000000.4 + write(buffer, fmt) ':',real_4,':' ! { dg-error "Positive width required" } + + real_8 = 4.18 + write(buffer, fmt) ':',real_8,':' ! { dg-error "Positive width required" } + +#ifdef __GFC_REAL_16__ + real_16 = 4.18 + write(buffer, fmt) ':',real_16,':' ! { dg-error "Positive width required" "" { target fortran_real_16 } } +#endif +end diff --git a/Fortran/gfortran/regression/fmt_huge.f90 b/Fortran/gfortran/regression/fmt_huge.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_huge.f90 @@ -0,0 +1,6 @@ +! { dg-do run } +! PR32446 printing big numbers in F0.1 format. +! This segfaulted before the patch. + open (10, status="scratch") + write (10,'(F0.1)') huge(1.0) + END diff --git a/Fortran/gfortran/regression/fmt_i_default_field_width_1.f90 b/Fortran/gfortran/regression/fmt_i_default_field_width_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_i_default_field_width_1.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! { dg-options -fdec } +! +! Test case for the default field widths enabled by the -fdec-format-defaults flag. +! +! This feature is not part of any Fortran standard, but it is supported by the +! Oracle Fortran compiler and others. + +program test + character(50) :: buffer + character(1) :: colon + + integer(2) :: integer_2 + integer(4) :: integer_4 + integer(8) :: integer_8 + character(*), parameter :: fmt = "(A, I, A)" + + write(buffer, fmt) ':',12340,':' + print *,buffer + if (buffer.ne.": 12340:") stop 1 + + read(buffer, "(1A, I, 1A)") colon, integer_4, colon + if ((integer_4.ne.12340).or.(colon.ne.":")) stop 2 + + integer_2 = -99 + write(buffer, fmt) ':',integer_2,':' + print *,buffer + if (buffer.ne.": -99:") stop 3 + + integer_8 = -11112222 + write(buffer, fmt) ':',integer_8,':' + print *,buffer + if (buffer.ne.": -11112222:") stop 4 + +! If the width is 7 and there are 7 leading zeroes, the result should be zero. + integer_2 = 789 + buffer = '0000000789' + read(buffer, '(I)') integer_2 + if (integer_2.ne.0) stop 5 +end diff --git a/Fortran/gfortran/regression/fmt_i_default_field_width_2.f90 b/Fortran/gfortran/regression/fmt_i_default_field_width_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_i_default_field_width_2.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! { dg-options -fdec-format-defaults } +! +! Test case for the default field widths enabled by the -fdec-format-defaults flag. +! +! This feature is not part of any Fortran standard, but it is supported by the +! Oracle Fortran compiler and others. +! +! Test case added by Mark Eggleston to check +! use of -fdec-format-defaults +! + +program test + character(50) :: buffer + character(1) :: colon + + integer(2) :: integer_2 + integer(4) :: integer_4 + integer(8) :: integer_8 + character(*), parameter :: fmt = "(A, I, A)" + + write(buffer, fmt) ':',12340,':' + print *,buffer + if (buffer.ne.": 12340:") stop 1 + + read(buffer, '(A1, I, A1)') colon, integer_4, colon + if ((integer_4.ne.12340).or.(colon.ne.":")) stop 2 + + integer_2 = -99 + write(buffer, fmt) ':',integer_2,':' + print *,buffer + if (buffer.ne.": -99:") stop 3 + + integer_8 = -11112222 + write(buffer, fmt) ':',integer_8,':' + print *,buffer + if (buffer.ne.": -11112222:") stop 4 + +! If the width is 7 and there are 7 leading zeroes, the result should be zero. + integer_2 = 789 + buffer = '0000000789' + read(buffer, '(I)') integer_2 + if (integer_2.ne.0) stop 5 +end diff --git a/Fortran/gfortran/regression/fmt_i_default_field_width_3.f90 b/Fortran/gfortran/regression/fmt_i_default_field_width_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_i_default_field_width_3.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! { dg-options "-fdec -fno-dec-format-defaults" } +! +! Test case for the default field widths enabled by the -fdec-format-defaults flag. +! +! This feature is not part of any Fortran standard, but it is supported by the +! Oracle Fortran compiler and others. +! +! Test case added by Mark Eggleston to check +! use of -fdec-format-defaults +! + +program test + character(50) :: buffer + character(1) :: colon + + integer(2) :: integer_2 + integer(4) :: integer_4 + integer(8) :: integer_8 + character(*), parameter :: fmt = "(A, I, A)" + + write(buffer, fmt) ':',12340,':' ! { dg-error "Nonnegative width required" } + + read(buffer, '(A1, I, A1)') colon, integer_4, colon ! { dg-error "Nonnegative width required" } + if (integer_4.ne.12340) stop 2 + + integer_2 = -99 + write(buffer, fmt) ':',integer_2,':' ! { dg-error "Nonnegative width required" } + + integer_8 = -11112222 + write(buffer, fmt) ':',integer_8,':' ! { dg-error "Nonnegative width required" } + +! If the width is 7 and there are 7 leading zeroes, the result should be zero. + integer_2 = 789 + buffer = '0000000789' + read(buffer, '(I)') integer_2 ! { dg-error "Nonnegative width required" } +end diff --git a/Fortran/gfortran/regression/fmt_int_sign.f90 b/Fortran/gfortran/regression/fmt_int_sign.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_int_sign.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options -fno-range-check } +! PR38504 double minus sign when printing integer +! Test case derived from example by Jos de Kloe +program IntAdtest + + integer, parameter :: i8_ = Selected_Int_Kind(18) ! = integer*8 + character(len=22) :: str_value + integer(i8_) :: value + character(len=*), parameter :: format_IntAd = "(i22)" + + value = -9223372036854775807_i8_ -1 + write(str_value, format_IntAd) value + if (str_value.ne." -9223372036854775808") STOP 1 + +end program IntAdtest diff --git a/Fortran/gfortran/regression/fmt_l.f90 b/Fortran/gfortran/regression/fmt_l.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_l.f90 @@ -0,0 +1,85 @@ +! { dg-do run } +! { dg-options "-std=gnu -pedantic -ffree-line-length-none" } +! Test the GNU extension of a L format descriptor without width +! PR libfortran/21303 +program test_l + logical(kind=1) :: l1 + logical(kind=2) :: l2 + logical(kind=4) :: l4 + logical(kind=8) :: l8 + + character(len=20) :: str + + l1 = .true. + write (str,"(L)") l1 ! { dg-warning "Extension: Missing positive width after L descriptor" } + read (str,"(L)") l1 ! { dg-warning "Extension: Missing positive width after L descriptor" } + if (l1 .neqv. .true.) STOP 1 + + l2 = .true. + write (str,"(L)") l2 ! { dg-warning "Extension: Missing positive width after L descriptor" } + read (str,"(L)") l2 ! { dg-warning "Extension: Missing positive width after L descriptor" } + if (l2 .neqv. .true.) STOP 2 + + l4 = .true. + write (str,"(L)") l4 ! { dg-warning "Extension: Missing positive width after L descriptor" } + read (str,"(L)") l4 ! { dg-warning "Extension: Missing positive width after L descriptor" } + if (l4 .neqv. .true.) STOP 3 + + l8 = .true. + write (str,"(L)") l8 ! { dg-warning "Extension: Missing positive width after L descriptor" } + read (str,"(L)") l8 ! { dg-warning "Extension: Missing positive width after L descriptor" } + if (l8 .neqv. .true.) STOP 4 + + l1 = .false. + write (str,"(L)") l1 ! { dg-warning "Extension: Missing positive width after L descriptor" } + read (str,"(L)") l1 ! { dg-warning "Extension: Missing positive width after L descriptor" } + if (l1 .neqv. .false.) STOP 5 + + l2 = .false. + write (str,"(L)") l2 ! { dg-warning "Extension: Missing positive width after L descriptor" } + read (str,"(L)") l2 ! { dg-warning "Extension: Missing positive width after L descriptor" } + if (l2 .neqv. .false.) STOP 6 + + l4 = .false. + write (str,"(L)") l4 ! { dg-warning "Extension: Missing positive width after L descriptor" } + read (str,"(L)") l4 ! { dg-warning "Extension: Missing positive width after L descriptor" } + if (l4 .neqv. .false.) STOP 7 + + l8 = .false. + write (str,"(L)") l8 ! { dg-warning "Extension: Missing positive width after L descriptor" } + read (str,"(L)") l8 ! { dg-warning "Extension: Missing positive width after L descriptor" } + if (l8 .neqv. .false.) STOP 8 + +end program test_l +! { dg-output "At line 14 of file.*" } +! { dg-output "Fortran runtime warning: Positive width required with L descriptor(\r*\n+)" } +! { dg-output "At line 15 of file.*" } +! { dg-output "Fortran runtime warning: Positive width required with L descriptor(\r*\n+)" } +! { dg-output "At line 19 of file.*" } +! { dg-output "Fortran runtime warning: Positive width required with L descriptor(\r*\n+)" } +! { dg-output "At line 20 of file.*" } +! { dg-output "Fortran runtime warning: Positive width required with L descriptor(\r*\n+)" } +! { dg-output "At line 24 of file.*" } +! { dg-output "Fortran runtime warning: Positive width required with L descriptor(\r*\n+)" } +! { dg-output "At line 25 of file.*" } +! { dg-output "Fortran runtime warning: Positive width required with L descriptor(\r*\n+)" } +! { dg-output "At line 29 of file.*" } +! { dg-output "Fortran runtime warning: Positive width required with L descriptor(\r*\n+)" } +! { dg-output "At line 30 of file.*" } +! { dg-output "Fortran runtime warning: Positive width required with L descriptor(\r*\n+)" } +! { dg-output "At line 34 of file.*" } +! { dg-output "Fortran runtime warning: Positive width required with L descriptor(\r*\n+)" } +! { dg-output "At line 35 of file.*" } +! { dg-output "Fortran runtime warning: Positive width required with L descriptor(\r*\n+)" } +! { dg-output "At line 39 of file.*" } +! { dg-output "Fortran runtime warning: Positive width required with L descriptor(\r*\n+)" } +! { dg-output "At line 40 of file.*" } +! { dg-output "Fortran runtime warning: Positive width required with L descriptor(\r*\n+)" } +! { dg-output "At line 44 of file.*" } +! { dg-output "Fortran runtime warning: Positive width required with L descriptor(\r*\n+)" } +! { dg-output "At line 45 of file.*" } +! { dg-output "Fortran runtime warning: Positive width required with L descriptor(\r*\n+)" } +! { dg-output "At line 49 of file.*" } +! { dg-output "Fortran runtime warning: Positive width required with L descriptor(\r*\n+)" } +! { dg-output "At line 50 of file.*" } +! { dg-output "Fortran runtime warning: Positive width required with L descriptor(\r*\n+)" } diff --git a/Fortran/gfortran/regression/fmt_l0.f90 b/Fortran/gfortran/regression/fmt_l0.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_l0.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! { dg-options "-std=gnu -pedantic" } +! Test the GNU extension of a L format descriptor without width +! PR libfortran/54679 +program main + implicit none + character(len=20) :: str + character(len=60) :: format2 = "(2(1x,l0,1x))" + write(str,format2) +end program main +! { dg-output "At line 9 of file.*" } +! { dg-output "Fortran runtime warning: Zero width after L descriptor(\n|\r\n|\r)" } diff --git a/Fortran/gfortran/regression/fmt_label_1.f90 b/Fortran/gfortran/regression/fmt_label_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_label_1.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! +! Check for diagnostics (PR 34108) + write (*,0) 'xxx' ! { dg-error "Statement label .* is zero" } + write (*,1) 'xxx' ! { dg-error "FORMAT label .* not defined" } + write (*,123456) 'xxx' ! { dg-error "Too many digits in statement label" } + write (*,-1) 'xxx' ! { dg-error "" } + end diff --git a/Fortran/gfortran/regression/fmt_missing_period_1.f b/Fortran/gfortran/regression/fmt_missing_period_1.f --- /dev/null +++ b/Fortran/gfortran/regression/fmt_missing_period_1.f @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR27634 Missing period in format specifier. Test case derived from case given +! in PR. Submitted by Jerry DeLisle + real aval + character(6) :: str + character(12) :: input = "1234abcdef" + read(input,'(f4,a6)') aval, str !{ dg-error "Period required" } + read(input,'(d10,a6)') aval, str !{ dg-error "Period required" } + end + diff --git a/Fortran/gfortran/regression/fmt_missing_period_2.f b/Fortran/gfortran/regression/fmt_missing_period_2.f --- /dev/null +++ b/Fortran/gfortran/regression/fmt_missing_period_2.f @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-options "-w -std=legacy" } +! PR27634 Missing period in format specifier. Test case derived from case given +! in PR. Submitted by Jerry DeLisle + real :: aval = 3.14 + character(6) :: str = "xyz" + character(12) :: input = "1234abcdef" + read(input,'(f4,a6)') aval, str + if (aval.ne.1234.0) STOP 1 + if (str.ne."abcdef") STOP 2 + aval = 0.0 + str = "xyz" + read(input,'(d4,a6)') aval, str + if (aval.ne.1234.0) STOP 3 + if (str.ne."abcdef") STOP 4 + end diff --git a/Fortran/gfortran/regression/fmt_missing_period_3.f b/Fortran/gfortran/regression/fmt_missing_period_3.f --- /dev/null +++ b/Fortran/gfortran/regression/fmt_missing_period_3.f @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! PR27634 Missing period in format specifier. Test case derived from case given +! in PR. Submitted by Jerry DeLisle + real :: aval = 3.14 + character(6) :: str = "xyz" + character(12) :: input = "1234abcdef" + character(8) :: fmtstr = "(f4,a6)" + aval = 0.0 + str = "xyz" + read(input,fmtstr) aval, str + if (aval.ne.1234.0) STOP 1 + if (str.ne."abcdef") STOP 2 + end + diff --git a/Fortran/gfortran/regression/fmt_nonchar_1.f90 b/Fortran/gfortran/regression/fmt_nonchar_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_nonchar_1.f90 @@ -0,0 +1,46 @@ +! { dg-do compile } +! +! PR fortran/99111 +! +program p + use iso_c_binding + implicit none + type t + integer :: a(1) + end type + type(t), parameter :: x(3) = [t(transfer('("he', 1)), & + t(transfer('llo ', 1)), & + t(transfer('W1")', 1))] + type t2 + procedure(), pointer, nopass :: ppt + end type t2 + type(t2) :: ppcomp(1) + interface + function fptr() + procedure(), pointer :: fptr + end function + end interface + class(t), allocatable :: cl(:) + type(c_ptr) :: cptr(1) + type(c_funptr) :: cfunptr(1) + procedure(), pointer :: proc + external proc2 + + print x ! { dg-error "Non-character non-Hollerith in FORMAT tag" } + print cl ! { dg-error "Non-character non-Hollerith in FORMAT tag" } + print cptr ! { dg-error "Non-character non-Hollerith in FORMAT tag" } + print cfunptr ! { dg-error "Non-character non-Hollerith in FORMAT tag" } + + print proc ! { dg-error "Syntax error in PRINT statement" } + print proc2 ! { dg-error "Syntax error in PRINT statement" } + print ppcomp%ppt ! { dg-error "Syntax error in PRINT statement" } + + print fptr() ! { dg-error "must be of type default-kind CHARACTER or of INTEGER" } + + call bar(1) +contains + subroutine bar (xx) + type(*) :: xx + print xx ! { dg-error "Assumed-type variable xx at ... may only be used as actual argument" } + end +end diff --git a/Fortran/gfortran/regression/fmt_nonchar_2.f90 b/Fortran/gfortran/regression/fmt_nonchar_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_nonchar_2.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! +! PR fortran/99111 +! +program p + implicit none + type t + integer :: a(1) + end type + type(t), parameter :: x(3) = [t(transfer('("he', 1)), & + t(transfer('llo ', 1)), & + t(transfer('W1")', 1))] + + integer, parameter :: y(3) = transfer('("hello W2")', 1, size=3) + real, parameter :: z(3) = transfer('("hello W3")', 1.0, size=3) + + print y ! { dg-warning "Legacy Extension: Non-character in FORMAT" } + print z ! { dg-warning "Legacy Extension: Non-character in FORMAT" } + print x%a(1) ! { dg-warning "Legacy Extension: Non-character in FORMAT" } +end + +! { dg-output "hello W2(\r*\n+)hello W3(\r*\n+)hello W1" } diff --git a/Fortran/gfortran/regression/fmt_nonchar_3.f90 b/Fortran/gfortran/regression/fmt_nonchar_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_nonchar_3.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/101084 + +program p + integer, parameter :: a(0) = 1 + print int(a) ! { dg-error "Non-character non-Hollerith in FORMAT tag" } +end diff --git a/Fortran/gfortran/regression/fmt_p_1.f90 b/Fortran/gfortran/regression/fmt_p_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_p_1.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! PR32554 Bug in P formatting +! Test case from the bug reporter +program gfcbug66 + real(8) :: x = 1.0e-100_8 + character(50) :: outstr + write (outstr,'(1X,2E12.3)') x, 2 * x + if (outstr.ne." 0.100E-99 0.200E-99") STOP 1 + ! Before patch 2 * x was put out wrong + write (outstr,'(1X,1P,2E12.3)') x, 2 * x + if (outstr.ne." 1.000-100 2.000-100") STOP 2 +end program gfcbug66 + diff --git a/Fortran/gfortran/regression/fmt_pf.f90 b/Fortran/gfortran/regression/fmt_pf.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_pf.f90 @@ -0,0 +1,226 @@ +! { dg-do run } +! PR70235 Incorrect output with PF format. +! Test case provided by Antoine Gardeux. +program pr70235 +use ISO_FORTRAN_ENV + implicit none + integer, parameter :: j(size(real_kinds)+4)=[REAL_KINDS, [4, 4, 4, 4]] + logical :: l_skip(4) = .false. + integer :: i + integer :: n_tst = 0, n_cnt = 0, n_skip = 0 + character(len=20) :: s, s1 + +! Check that the default rounding mode is to nearest and to even on tie. + do i=1,size(real_kinds) + if (i == 1) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(1)), & + real(9.49999905,kind=j(1)), & + real(9.5,kind=j(1)), real(8.5,kind=j(1)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(1)), & + real(98765.0,kind=j(1)) + else if (i == 2) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(2)), & + real(9.49999905,kind=j(2)), & + real(9.5,kind=j(2)), real(8.5,kind=j(2)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(2)), & + real(98765.0,kind=j(2)) + else if (i == 3) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(3)), & + real(9.49999905,kind=j(3)), & + real(9.5,kind=j(3)), real(8.5,kind=j(3)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(3)), & + real(98765.0,kind=j(3)) + else if (i == 4) then + write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(4)), & + real(9.49999905,kind=j(4)), & + real(9.5,kind=j(4)), real(8.5,kind=j(4)) + write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(4)), & + real(98765.0,kind=j(4)) + end if + if (s /= '-9.5 9.5 10. 8.' .or. s1 /= ' 987.4E+03 98.76E+03') then + l_skip(i) = .true. +! print "('Unsupported rounding for real(',i0,')')", j(i) + end if + end do + + +! Original test. + call checkfmt("(-6PF8.3)", 1.0e4, " 0.010") + call checkfmt("(-6PF8.3)", 0.0, " 0.000") + +! Test for the bug in comment 6. + call checkfmt("(-8pf18.3)", 643.125, " 0.000") + call checkfmt("(-7pf18.3)", 643.125, " 0.000") + call checkfmt("(-6pf18.3)", 643.125, " 0.001") + call checkfmt("(-5pf18.3)", 643.125, " 0.006") + call checkfmt("(-4pf18.3)", 643.125, " 0.064") + call checkfmt("(-3pf18.3)", 643.125, " 0.643") + call checkfmt("(-2pf18.3)", 643.125, " 6.431") + call checkfmt("(-1pf18.3)", 643.125, " 64.312") + call checkfmt("( 0pf18.3)", 643.125, " 643.125") + + call checkfmt("(ru,-8pf18.3)", 643.125, " 0.001") + call checkfmt("(ru,-7pf18.3)", 643.125, " 0.001") + call checkfmt("(ru,-6pf18.3)", 643.125, " 0.001") + call checkfmt("(ru,-5pf18.3)", 643.125, " 0.007") + call checkfmt("(ru,-4pf18.3)", 643.125, " 0.065") + call checkfmt("(ru,-3pf18.3)", 643.125, " 0.644") + call checkfmt("(ru,-2pf18.3)", 643.125, " 6.432") + call checkfmt("(ru,-1pf18.3)", 643.125, " 64.313") + call checkfmt("(ru, 0pf18.3)", 643.125, " 643.125") + + call checkfmt("(rd,-8pf18.3)", 643.125, " 0.000") + call checkfmt("(rd,-7pf18.3)", 643.125, " 0.000") + call checkfmt("(rd,-6pf18.3)", 643.125, " 0.000") + call checkfmt("(rd,-5pf18.3)", 643.125, " 0.006") + call checkfmt("(rd,-4pf18.3)", 643.125, " 0.064") + call checkfmt("(rd,-3pf18.3)", 643.125, " 0.643") + call checkfmt("(rd,-2pf18.3)", 643.125, " 6.431") + call checkfmt("(rd,-1pf18.3)", 643.125, " 64.312") + call checkfmt("(rd, 0pf18.3)", 643.125, " 643.125") + + call checkfmt("(rz,-8pf18.3)", 643.125, " 0.000") + call checkfmt("(rz,-7pf18.3)", 643.125, " 0.000") + call checkfmt("(rz,-6pf18.3)", 643.125, " 0.000") + call checkfmt("(rz,-5pf18.3)", 643.125, " 0.006") + call checkfmt("(rz,-4pf18.3)", 643.125, " 0.064") + call checkfmt("(rz,-3pf18.3)", 643.125, " 0.643") + call checkfmt("(rz,-2pf18.3)", 643.125, " 6.431") + call checkfmt("(rz,-1pf18.3)", 643.125, " 64.312") + call checkfmt("(rz, 0pf18.3)", 643.125, " 643.125") + + call checkfmt("(rc,-8pf18.3)", 643.125, " 0.000") + call checkfmt("(rc,-7pf18.3)", 643.125, " 0.000") + call checkfmt("(rc,-6pf18.3)", 643.125, " 0.001") + call checkfmt("(rc,-5pf18.3)", 643.125, " 0.006") + call checkfmt("(rc,-4pf18.3)", 643.125, " 0.064") + call checkfmt("(rc,-3pf18.3)", 643.125, " 0.643") + call checkfmt("(rc,-2pf18.3)", 643.125, " 6.431") + call checkfmt("(rc,-1pf18.3)", 643.125, " 64.313") + call checkfmt("(rc, 0pf18.3)", 643.125, " 643.125") + + call checkfmt("(rn,-8pf18.3)", 643.125, " 0.000") + call checkfmt("(rn,-7pf18.3)", 643.125, " 0.000") + call checkfmt("(rn,-6pf18.3)", 643.125, " 0.001") + call checkfmt("(rn,-5pf18.3)", 643.125, " 0.006") + call checkfmt("(rn,-4pf18.3)", 643.125, " 0.064") + call checkfmt("(rn,-3pf18.3)", 643.125, " 0.643") + call checkfmt("(rn,-2pf18.3)", 643.125, " 6.431") + call checkfmt("(rn,-1pf18.3)", 643.125, " 64.312") + call checkfmt("(rn, 0pf18.3)", 643.125, " 643.125") + + call checkfmt("(rp,-8pf18.3)", 643.125, " 0.000") + call checkfmt("(rp,-7pf18.3)", 643.125, " 0.000") + call checkfmt("(rp,-6pf18.3)", 643.125, " 0.001") + call checkfmt("(rp,-5pf18.3)", 643.125, " 0.006") + call checkfmt("(rp,-4pf18.3)", 643.125, " 0.064") + call checkfmt("(rp,-3pf18.3)", 643.125, " 0.643") + call checkfmt("(rp,-2pf18.3)", 643.125, " 6.431") + call checkfmt("(rp,-1pf18.3)", 643.125, " 64.312") + call checkfmt("(rp, 0pf18.3)", 643.125, " 643.125") + + call checkfmt("(-8pf18.3)", -643.125, " -0.000") + call checkfmt("(-7pf18.3)", -643.125, " -0.000") + call checkfmt("(-6pf18.3)", -643.125, " -0.001") + call checkfmt("(-5pf18.3)", -643.125, " -0.006") + call checkfmt("(-4pf18.3)", -643.125, " -0.064") + call checkfmt("(-3pf18.3)", -643.125, " -0.643") + call checkfmt("(-2pf18.3)", -643.125, " -6.431") + call checkfmt("(-1pf18.3)", -643.125, " -64.312") + call checkfmt("( 0pf18.3)", -643.125, " -643.125") + + call checkfmt("(ru,-8pf18.3)", -643.125, " -0.000") + call checkfmt("(ru,-7pf18.3)", -643.125, " -0.000") + call checkfmt("(ru,-6pf18.3)", -643.125, " -0.000") + call checkfmt("(ru,-5pf18.3)", -643.125, " -0.006") + call checkfmt("(ru,-4pf18.3)", -643.125, " -0.064") + call checkfmt("(ru,-3pf18.3)", -643.125, " -0.643") + call checkfmt("(ru,-2pf18.3)", -643.125, " -6.431") + call checkfmt("(ru,-1pf18.3)", -643.125, " -64.312") + call checkfmt("(ru, 0pf18.3)", -643.125, " -643.125") + + call checkfmt("(rd,-8pf18.3)", -643.125, " -0.001") + call checkfmt("(rd,-7pf18.3)", -643.125, " -0.001") + call checkfmt("(rd,-6pf18.3)", -643.125, " -0.001") + call checkfmt("(rd,-5pf18.3)", -643.125, " -0.007") + call checkfmt("(rd,-4pf18.3)", -643.125, " -0.065") + call checkfmt("(rd,-3pf18.3)", -643.125, " -0.644") + call checkfmt("(rd,-2pf18.3)", -643.125, " -6.432") + call checkfmt("(rd,-1pf18.3)", -643.125, " -64.313") + call checkfmt("(rd, 0pf18.3)", -643.125, " -643.125") + + call checkfmt("(rz,-8pf18.3)", -643.125, " -0.000") + call checkfmt("(rz,-7pf18.3)", -643.125, " -0.000") + call checkfmt("(rz,-6pf18.3)", -643.125, " -0.000") + call checkfmt("(rz,-5pf18.3)", -643.125, " -0.006") + call checkfmt("(rz,-4pf18.3)", -643.125, " -0.064") + call checkfmt("(rz,-3pf18.3)", -643.125, " -0.643") + call checkfmt("(rz,-2pf18.3)", -643.125, " -6.431") + call checkfmt("(rz,-1pf18.3)", -643.125, " -64.312") + call checkfmt("(rz, 0pf18.3)", -643.125, " -643.125") + + call checkfmt("(rc,-8pf18.3)", -643.125, " -0.000") + call checkfmt("(rc,-7pf18.3)", -643.125, " -0.000") + call checkfmt("(rc,-6pf18.3)", -643.125, " -0.001") + call checkfmt("(rc,-5pf18.3)", -643.125, " -0.006") + call checkfmt("(rc,-4pf18.3)", -643.125, " -0.064") + call checkfmt("(rc,-3pf18.3)", -643.125, " -0.643") + call checkfmt("(rc,-2pf18.3)", -643.125, " -6.431") + call checkfmt("(rc,-1pf18.3)", -643.125, " -64.313") + call checkfmt("(rc, 0pf18.3)", -643.125, " -643.125") + + call checkfmt("(rn,-8pf18.3)", -643.125, " -0.000") + call checkfmt("(rn,-7pf18.3)", -643.125, " -0.000") + call checkfmt("(rn,-6pf18.3)", -643.125, " -0.001") + call checkfmt("(rn,-5pf18.3)", -643.125, " -0.006") + call checkfmt("(rn,-4pf18.3)", -643.125, " -0.064") + call checkfmt("(rn,-3pf18.3)", -643.125, " -0.643") + call checkfmt("(rn,-2pf18.3)", -643.125, " -6.431") + call checkfmt("(rn,-1pf18.3)", -643.125, " -64.312") + call checkfmt("(rn, 0pf18.3)", -643.125, " -643.125") + + call checkfmt("(rp,-8pf18.3)", -643.125, " -0.000") + call checkfmt("(rp,-7pf18.3)", -643.125, " -0.000") + call checkfmt("(rp,-6pf18.3)", -643.125, " -0.001") + call checkfmt("(rp,-5pf18.3)", -643.125, " -0.006") + call checkfmt("(rp,-4pf18.3)", -643.125, " -0.064") + call checkfmt("(rp,-3pf18.3)", -643.125, " -0.643") + call checkfmt("(rp,-2pf18.3)", -643.125, " -6.431") + call checkfmt("(rp,-1pf18.3)", -643.125, " -64.312") + call checkfmt("(rp, 0pf18.3)", -643.125, " -643.125") + + ! print *, n_tst, n_cnt, n_skip + if (n_cnt /= 0) STOP 1 + if (all(.not. l_skip)) print *, "All kinds rounded to nearest" + +contains + subroutine checkfmt(fmt, x, cmp) + implicit none + integer :: i + character(len=*), intent(in) :: fmt + real, intent(in) :: x + character(len=*), intent(in) :: cmp + do i=1,size(real_kinds) + if (i == 1) then + write(s, fmt) real(x,kind=j(1)) + else if (i == 2) then + write(s, fmt) real(x,kind=j(2)) + else if (i == 3) then + write(s, fmt) real(x,kind=j(3)) + else if (i == 4) then + write(s, fmt) real(x,kind=j(4)) + end if + n_tst = n_tst + 1 + if (s /= cmp) then + if (l_skip(i)) then + n_skip = n_skip + 1 + else + print "(a,1x,a,' expected: ',1x,a)", fmt, s, cmp + n_cnt = n_cnt + 1 + end if + end if + end do + + end subroutine +end program +! { dg-output "All kinds rounded to nearest" { xfail { hppa*-*-hpux* } } } diff --git a/Fortran/gfortran/regression/fmt_read.f90 b/Fortran/gfortran/regression/fmt_read.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_read.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! pr18398, missing data on sequential formatted reads +! test contributed by Thomas.Koenig@online.de + open(7,status='scratch') + write (7,'(F12.5)') 1.0, 2.0, 3.0 + rewind(7) + read(7,'(F15.5)') a,b +! note the read format is wider than the write + if (abs(a-1.0) .gt. 1e-5) STOP 1 + if (abs(b-2.0) .gt. 1e-5) STOP 2 + end diff --git a/Fortran/gfortran/regression/fmt_read_2.f90 b/Fortran/gfortran/regression/fmt_read_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_read_2.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR fortran/32483 + implicit none + integer :: r + real :: a + write (*,'(i0)') r + read (*,'(i0)') r ! { dg-error "Positive width required" } + read (*,'(f0.2)') a ! { dg-error "Positive width required" } + print *, r,a + END diff --git a/Fortran/gfortran/regression/fmt_read_3.f90 b/Fortran/gfortran/regression/fmt_read_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_read_3.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! PR52393 "READ format" statement with parenthesed default-char-expr +PROGRAM ReadMeTwo + IMPLICIT NONE + CHARACTER(10) :: var + var = "TestStr" + PRINT ('(') // 'A)', var + PRINT ('(') // 'A)', var + READ ('(') // 'A)', var + PRINT *, var + READ *, var +END PROGRAM ReadMeTwo + diff --git a/Fortran/gfortran/regression/fmt_read_4.f90 b/Fortran/gfortran/regression/fmt_read_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_read_4.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! PR52393 "READ format" statement with parenthesed default-char-expr +PROGRAM ReadMeTwo + IMPLICIT NONE + CHARACTER(10) :: var + var = "TestStr" + READ ('((') // 'A)', var ! { dg-error "Unexpected end of format" } +END PROGRAM ReadMeTwo diff --git a/Fortran/gfortran/regression/fmt_read_5.f b/Fortran/gfortran/regression/fmt_read_5.f --- /dev/null +++ b/Fortran/gfortran/regression/fmt_read_5.f @@ -0,0 +1,8 @@ +c { dg-do compile } +c PR71404 [7 Regression] 416.gamess in SPEC CPU 2006 failed to build + SUBROUTINE SQRINT (LFILE,IREGION,LENGTH) + DIMENSION IREGION(LENGTH) + LOGICAL DSKWRK,MASWRK + IF (DSKWRK.OR.MASWRK) READ(LFILE, END=200) IREGION + 200 CONTINUE + END diff --git a/Fortran/gfortran/regression/fmt_read_bz_bn.f90 b/Fortran/gfortran/regression/fmt_read_bz_bn.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_read_bz_bn.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! Test various uses of BZ and BN format specifiers. +! Portions inspired by NIST F77 testsuite FM711.f +! Contributed by jvdelisle@verizon.net +program test_bn + +integer I1(2,2), I2(2,2,2) +real A1(5) +real(kind=8) A2(0:3) +character*80 :: IDATA1="111 2 2 3 3. 3E-1 44 5 5 6 . 67 . 78 8. 8E-1" +character*80 :: IDATA2="2345 1 34512 45123 51234 2345 1 34512 45123 5" +character*80 :: IDATA3="-8.0D0 1.0D-4 0.50D0 0.250D0" +character*80 :: ODATA="" +character*80 :: CORRECT1=" 1110 2020 .30303E-07 44 55 6.6 70.07 .888E+01" +character*80 :: CORRECT2="23450 10345. 12.45 1235 1234 2345 1345. 12.45 1235" +character*80 :: CORRECT3=" -0.8000000000D+01 0.1000000000D-03& + & 0.5000000000D+00 0.2500000000D+00" +READ(IDATA1, 10) I1(1,2), IVI, A1(3), JVI, KVI, A1(2), AVS, A1(1) +10 FORMAT (BZ,(2I4, E10.1, BN, 2I4, F5.2, BZ, F5.2, BN, E10.1)) + +WRITE(ODATA, 20) I1(1,2), IVI, A1(3), JVI, KVI, A1(2), AVS, A1(1) +20 FORMAT (2I5, 1X, E10.5, BN, 2I5, F6.1, BZ, F6.2, BN, 1X, E8.3, I5) + +if (ODATA /= CORRECT1) STOP 1 +ODATA="" + +READ(IDATA2, 30) I2(1,2,1), A1(3), AVS, IVI, I1(1,1), JVI, BVS, A1(2), I2(1,1,1) +30 FORMAT (BZ, (I5, F5.0, BN, F5.2, 2I5, I5, F5.0, BN, F5.2, I5)) + +WRITE(ODATA, 40) I2(1,2,1), A1(3), AVS, IVI, I1(1,1), JVI, BVS, A1(2), I2(1,1,1) +40 FORMAT (I5, F7.0, BZ, 1X, F5.2, 2(1X,I4),I5, F7.0, BZ, 1X, F5.2, 1X, I4) + +if (ODATA /= CORRECT2) STOP 2 +ODATA="" + +READ(IDATA3, 50) A2 +50 FORMAT (4D8.0) + +WRITE(ODATA,60) A2 +60 FORMAT (4D20.10) + +if (ODATA /= CORRECT3) STOP 3 + +end program test_bn diff --git a/Fortran/gfortran/regression/fmt_t_1.f90 b/Fortran/gfortran/regression/fmt_t_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_t_1.f90 @@ -0,0 +1,12 @@ +! { dg-do run } + integer nrow, vec(15) + open (10, status="scratch") + write (10, fmt='(a)') '001 1 2 3 4 5 6' + write (10, fmt='(a)') '000000 7 8 9101112' + write (10, fmt='(a)') '000000131415' + rewind (10) + read (10, fmt='(i6, (t7, 6i2))') nrow, (vec(i), i=1,15) + close (10) + if (nrow.ne.1) STOP 1 + if (any (vec.ne.(/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15/))) STOP 2 + end diff --git a/Fortran/gfortran/regression/fmt_t_2.f90 b/Fortran/gfortran/regression/fmt_t_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_t_2.f90 @@ -0,0 +1,27 @@ +! { dg-options "" } +! { dg-do run } +! pr24699, handle end-of-record on READ with T format +! test contributed by Jerry DeLisle + character*132 :: foost1, foost2, foost3 + open (11, status="scratch", action="readwrite") + write(11, '(a)') "ab cdefghijkl mnop qrst" + write(11, '(a)') "123456789 123456789 123456789" + write(11, '(a)') " Now is the time for all good." + rewind(11) + + read (11, '(a040,t1,040a)', end = 999) foost1 , foost2 + if (foost1.ne.foost2) STOP 1 + + read (11, '(a032,t2,a032t3,a032)', end = 999) foost1 , foost2, foost3 + if (foost1(1:32).ne."123456789 123456789 123456789 ") STOP 2 + if (foost2(1:32).ne."23456789 123456789 123456789 ") STOP 3 + if (foost3(1:32).ne."3456789 123456789 123456789 ") STOP 4 + + read (11, '(a017,t1,a0017)', end = 999) foost1 , foost2 + if (foost1.ne.foost2) STOP 5 + if (foost2(1:17).ne." Now is the time ") STOP 6 + goto 1000 + 999 STOP 7 + 1000 continue + close(11) + end diff --git a/Fortran/gfortran/regression/fmt_t_3.f90 b/Fortran/gfortran/regression/fmt_t_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_t_3.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! PR31051 bug with x and t format descriptors. +! Test case prepared by Jerry DeLisle from PR. +program t + integer, parameter :: n = 9 + character(len=40) :: fmt + character(len=2), dimension(n) :: y + open(unit=10, status="scratch") + y = 'a ' + fmt = '(a,1x,(t7, 3a))' + write(10, fmt) 'xxxx', (y(i), i = 1,n) + rewind(10) + read(10, '(a)') fmt + if (fmt.ne."xxxx a a a") STOP 1 +end program t diff --git a/Fortran/gfortran/regression/fmt_t_4.f90 b/Fortran/gfortran/regression/fmt_t_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_t_4.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! PR31199, test case from PR report. + program write_write + character(len=20) :: a,b,c + open(10, status="scratch") + write (10,"(a,t1,a,a)") "xxxxxxxxx", "abc", "def" + write (10,"(a,t1,a)",advance='no') "xxxxxxxxx", "abc" + write (10,"(a)") "def" + write (10,"(a)") "abcdefxxx" + rewind(10) + read(10,*) a + read(10,*) b + read(10,*) c + close(10) + if (a.ne.b) STOP 1 + IF (b.ne.c) STOP 2 + end + diff --git a/Fortran/gfortran/regression/fmt_t_5.f90 b/Fortran/gfortran/regression/fmt_t_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_t_5.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! PR32678 GFortan works incorrectly when writing with FORMAT Tx +! Before patch, NULLs were inserted in output. +! Test case from reporter enhanced to detect this problem. + character(25) :: output + character(1) :: c + output = "" + open (unit=10, file="pr32678testfile", status="replace") + write (10,10) '12','a','b' + close (10, status="keep") + open (unit=10, file="pr32678testfile", access="stream") + read(10, pos=1) output(1:21) + if (output(1:21).ne."ab x") STOP 1 + read(10) c + if ((c.ne.achar(10)) .and. (c.ne.achar(13))) STOP 2 + close (10, status="delete") + 10 format (a2,t1,a1,t2,a1,t20,' x') + end diff --git a/Fortran/gfortran/regression/fmt_t_6.f b/Fortran/gfortran/regression/fmt_t_6.f --- /dev/null +++ b/Fortran/gfortran/regression/fmt_t_6.f @@ -0,0 +1,10 @@ +! { dg-do run } +! PR34782 tab format failure to display properly (regression vs. g77) + character a(6) + character(22) :: output + data a / 'a', 'b', 'c', 'd', 'e', 'f' / + !write(*,'(a)') "123456789012345678901234567890" + write(output,'(T20,A3, T1,A4, T5,A2, T7,A2, T9,A4, T17,A2)') + 1 'a', 'b', 'c', 'd', 'e', 'f' + if (output .ne. " b c d e f a") STOP 1 + end diff --git a/Fortran/gfortran/regression/fmt_t_7.f b/Fortran/gfortran/regression/fmt_t_7.f --- /dev/null +++ b/Fortran/gfortran/regression/fmt_t_7.f @@ -0,0 +1,16 @@ +! { dg-do run { target fd_truncate } } +! PR34974 null bytes when reverse-tabbing long records +! Test case prepared by Jerry DeLisle + program test + character(1) :: a, b, c + write (10,'(t50000,a,t1,a)') 'b', 'a' + close (10) + open (10, access="stream") + read (10, pos=1) a + read (10, pos=50000) b + read (10, pos=25474) c + close (10, status="delete") + if (a /= "a") STOP 1 + if (b /= "b") STOP 2 + if (c /= " ") STOP 3 + end diff --git a/Fortran/gfortran/regression/fmt_t_8.f90 b/Fortran/gfortran/regression/fmt_t_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_t_8.f90 @@ -0,0 +1,6 @@ +! { dg-do run } +! PR52251 Tabs with advance = 'no' +write( *, '( t25 )', advance = 'no' ) +write( *, '( "hello" )' ) ! { dg-output " hello(\n|\r\n|\r)" } +end + diff --git a/Fortran/gfortran/regression/fmt_t_9.f b/Fortran/gfortran/regression/fmt_t_9.f --- /dev/null +++ b/Fortran/gfortran/regression/fmt_t_9.f @@ -0,0 +1,41 @@ +! { dg-options "-ffixed-line-length-none -std=gnu" } +! { dg-do run } +! PR78123 Short reads with T edit descriptor not padding correctly + PROGRAM tformat +C + INTEGER MXFLTL + PARAMETER (MXFLTL = 99999) + INTEGER IFLGHT, NFLCYC, IFLTSQ(MXFLTL), IDXBLK, LMAX, LMIN, I +C + OPEN(29, status='scratch') + WRITE(29, '(a)') " 1 1 1 TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT 72 122 4" + WRITE(29, '(a)') "" + WRITE(29, '(a)') " 451 402012011201120112011200120112011201120112011201120111971201120112011201120112011201" + WRITE(29, '(a)') " 451 4020 866 866 866 866 866 866 866 866 865 866 865 866 866 866 866 866 866 866 865 866" + REWIND(29) +C The error occurs in the following loop: + 10 CONTINUE + READ(29,1010 ) IDXBLK, LMAX, LMIN +1010 FORMAT(8X,I4,T51,2I5) ! wrong if this format is used +c write(6,fmt='("IDXBLK,LMAX,LMIN=",3I5)')IDXBLK,LMAX,LMIN + IF (IDXBLK .EQ. 0) GO TO 20 + GO TO 10 +C + 20 CONTINUE + READ(29,1040,END=100) IFLGHT, NFLCYC, + & (IFLTSQ(I), I=1,NFLCYC) +1040 FORMAT(I5,I5,2X,(T13,20I4)) +c write(6,fmt='(2i6)') IFLGHT,NFLCYC +c write(6,fmt='(20I4)') (IFLTSQ(I), I=1,NFLCYC) +c write(6,*) "Program is correct" + close(29) + if (IFLGHT.ne.451) STOP 1 + if (NFLCYC.ne.40) STOP 2 + stop +C + 100 CONTINUE +C write(6,*) "End of file encountered (wrong)" + close (29) + STOP 3 + STOP + END diff --git a/Fortran/gfortran/regression/fmt_tab_1.f90 b/Fortran/gfortran/regression/fmt_tab_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_tab_1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options -Wtabs } +! PR fortran/32987 +! PR fortran/58001 + program TestFormat + write (*, 10) + ! There is a tab character before 'bug!'. This is accepted without + ! the -Wno-tabs option or a -std= option. + 10 format ('Hello ', 'bug!') ! { dg-warning "tab character in format at " } + ! { dg-warning "tab character at " "" { target "*-*-*" } .-1 } + end diff --git a/Fortran/gfortran/regression/fmt_tab_2.f90 b/Fortran/gfortran/regression/fmt_tab_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_tab_2.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! PR fortran/32987 +! PR fortran/58001 + program TestFormat + write (*, 10) + 10 format ('Hello ', 'bug!') ! { dg-warning "tab character in format" } + end ! { dg-warning "tab character at " "" { target "*-*-*" } .-1 } diff --git a/Fortran/gfortran/regression/fmt_tl.f b/Fortran/gfortran/regression/fmt_tl.f --- /dev/null +++ b/Fortran/gfortran/regression/fmt_tl.f @@ -0,0 +1,27 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR25631 Check that TL editing works for special case of no bytes written yet. +! Contributed by Jerry DeLisle + real x + character*15 line + x = 12.34 + write(line,10) x + 10 format(tr2,tl2,g11.4) + if (line.ne.' 12.34 ') STOP 1 + write(line,20) x + 20 format(tr5,tl3,g11.4) + if (line.ne.' 12.34 ') STOP 2 + write(line,30) x + 30 format(tr5,tl3,tl3,g11.4) + if (line.ne.' 12.34 ') STOP 3 + write(line,40) x + 40 format(tr25,tl35,f11.4) + if (line.ne.' 12.3400 ') STOP 4 + write(line,50) x + 50 format(tl5,tr3,f11.4) + if (line.ne.' 12.3400 ') STOP 5 + write(line,60) x + 60 format(t5,tl3,f11.4) + if (line.ne.' 12.3400 ') STOP 6 + end diff --git a/Fortran/gfortran/regression/fmt_unlimited.f90 b/Fortran/gfortran/regression/fmt_unlimited.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_unlimited.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! PR65234 Output descriptor (*(1E15.7)) not accepted +program IOtest + character(40) :: str + double precision :: d = 5.0 + write (str, '(*(2(E15.7)))') d, d + if (str /= " 0.5000000E+01 0.5000000E+01") STOP 1 + write (str, '(*(2E15.7))') d, d + if (str /= " 0.5000000E+01 0.5000000E+01") STOP 2 +end program diff --git a/Fortran/gfortran/regression/fmt_white.f b/Fortran/gfortran/regression/fmt_white.f --- /dev/null +++ b/Fortran/gfortran/regression/fmt_white.f @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR24268 Test case derived from example given by Iwan Kawrakow +! Embedded spaces in format strings should be ignored. +! Prepared by Jerry DeLisle + program pr24268 + real x + character*13 line + line = "12.34" + read(line,*) x + write(line,10) x + 10 format(g1 + * 1.4) + if (line.ne." 12.34") STOP 1 + line = "" + write(line,20) x + 20 format(t r 2 , g 1 1 . 4) + if (line.ne." 12.34") STOP 2 + end diff --git a/Fortran/gfortran/regression/fmt_with_extra.f b/Fortran/gfortran/regression/fmt_with_extra.f --- /dev/null +++ b/Fortran/gfortran/regression/fmt_with_extra.f @@ -0,0 +1,28 @@ +! { dg-do compile } +! test case contributed by tobias.burnus@physik.fu-berlin.de +! PR28039 Warn when ignoring extra characters in the format specification + implicit none + real :: r + r = 1.0 + write(*,'(a),f)') 'Hello', r ! { dg-warning "Extraneous characters in format at" } + end +! Below routine was also submitted by tobias.burnus@physik.fu-berlin.de +! It showed up some problems with the initial implementation of this +! feature. +! This routine should compile without complaint or warning. + SUBROUTINE rw_inp() + CHARACTER(len=100) :: line + integer :: i5 + character(100), parameter :: subchapter = + & '(79("-"),/,5("-")," ",A,/,79("-"),/)' + i5 = 1 + + READ(*,FMT="(4x,a)") line + 7182 FORMAT (a3) + 7130 FORMAT (i3) + + WRITE (6,'(//'' icorr is not correctly transferred. icorr='',i5) + & ') 42 + + write(*,subchapter) 'test' + END SUBROUTINE rw_inp diff --git a/Fortran/gfortran/regression/fmt_zero_check.f90 b/Fortran/gfortran/regression/fmt_zero_check.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_zero_check.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! PR fortran/32555 +! +2050 FORMAT(0PF9.4) +2050 FORMAT(0F9.4) ! { dg-error "Expected P edit descriptor" } +end diff --git a/Fortran/gfortran/regression/fmt_zero_digits.f90 b/Fortran/gfortran/regression/fmt_zero_digits.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_zero_digits.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! Verify that when decimal precision is zero, error error given except with 1P. +! Submitted by Jerry DeLisle +! Modified for fix to PR35036 +program test + implicit none + character(20) :: astr + integer :: istat + 50 FORMAT (1PD20.0) + astr = "" + write(astr,50) -8.0D0 + if (astr.ne." -8.D+00") STOP 1 + write(astr,50) 8.0D0 + if (astr.ne." 8.D+00") STOP 2 + write(astr, '(E15.0)', iostat=istat) 1e5 + if (istat /= 5006) STOP 3 + write(astr, '(D15.0)', iostat=istat) 1e5 + if (istat /= 5006) STOP 4 + write(astr, '(G15.0)', iostat=istat) 1e5 + if (istat /= 5006) STOP 5 + write(astr, '(2PE15.0)', iostat=istat) 1e5 + if (istat /= 5006) STOP 6 + write(astr, '(0PE15.0)', iostat=istat) 1e5 + if (istat /= 5006) STOP 7 + write(astr, '(1PE15.0)', iostat=istat) 1e5 + if (istat /= 0) STOP 8 + write(astr, '(F15.0)', iostat=istat) 1e5 + if (astr.ne." 100000.") STOP 9 + if (istat /= 0) STOP 10 +end program test diff --git a/Fortran/gfortran/regression/fmt_zero_precision.f90 b/Fortran/gfortran/regression/fmt_zero_precision.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_zero_precision.f90 @@ -0,0 +1,85 @@ +! { dg-do run } +! PR28354 Incorrect rounding of .99999 with f3.0 format specifier +! PR30910 ES format not quite right... +! Test case derived from PR. Submitted by Jerry DeLisle + write(*,50) 0.99999 + write(*,50) -0.99999 + write(*,50) -9.0 + write(*,50) -0.99 + write(*,50) -0.999 + write(*,50) -0.999 + write(*,50) -0.59 + write(*,50) -0.49 + write(*,100) 37.99999 + write(*,100) 10345.0 + write(*,100) 333.678 + write(*,100) 333.499 + 50 format(f3.0,"<") + 100 format(f8.0,"<") + write(6,'(es6.0)') 1.0e-1 + write(*,150) -0.99999 + write(*,150) 0.99999 + write(*,150) -9.0 + write(*,150) -0.99 + write(*,150) -0.999 + write(*,150) -0.999 + write(*,150) -0.59 + write(*,150) -0.49 + write(*,200) 37.99999 + write(*,200) 10345.0 + write(*,200) 333.678 + write(*,200) 333.499 + 150 format(es7.0,"<") + 200 format(es8.0,"<") + write(*,250) -0.99999 + write(*,250) 0.99999 + write(*,250) -9.0 + write(*,250) -0.99 + write(*,250) -0.999 + write(*,250) -0.999 + write(*,250) -0.59 + write(*,250) -0.49 + write(*,300) 37.99999 + write(*,300) 10345.0 + write(*,300) 333.678 + write(*,300) 333.499 + 250 format(1pe7.0,"<") + 300 format(1pe6.0,"<") + end +! { dg-output " 1\\.<(\r*\n+)" } +! { dg-output "-1\\.<(\r*\n+)" } +! { dg-output "-9\\.<(\r*\n+)" } +! { dg-output "-1\\.<(\r*\n+)" } +! { dg-output "-1\\.<(\r*\n+)" } +! { dg-output "-1\\.<(\r*\n+)" } +! { dg-output "-1\\.<(\r*\n+)" } +! { dg-output "-0\\.<(\r*\n+)" } +! { dg-output " 38\\.<(\r*\n+)" } +! { dg-output " 10345\\.<(\r*\n+)" } +! { dg-output " 334\\.<(\r*\n+)" } +! { dg-output " 333\\.<(\r*\n+)" } +! { dg-output "1\\.E-01(\r*\n+)" } +! { dg-output "-1\\.E\\+00<(\r*\n+)" } +! { dg-output " 1\\.E\\+00<(\r*\n+)" } +! { dg-output "-9\\.E\\+00<(\r*\n+)" } +! { dg-output "-1\\.E\\+00<(\r*\n+)" } +! { dg-output "-1\\.E\\+00<(\r*\n+)" } +! { dg-output "-1\\.E\\+00<(\r*\n+)" } +! { dg-output "-6\\.E-01<(\r*\n+)" } +! { dg-output "-5\\.E-01<(\r*\n+)" } +! { dg-output " 4\\.E\\+01<(\r*\n+)" } +! { dg-output " 1\\.E\\+04<(\r*\n+)" } +! { dg-output " 3\\.E\\+02<(\r*\n+)" } +! { dg-output " 3\\.E\\+02<(\r*\n+)" } +! { dg-output "-1\\.E\\+00<(\r*\n+)" } +! { dg-output " 1\\.E\\+00<(\r*\n+)" } +! { dg-output "-9\\.E\\+00<(\r*\n+)" } +! { dg-output "-1\\.E\\+00<(\r*\n+)" } +! { dg-output "-1\\.E\\+00<(\r*\n+)" } +! { dg-output "-1\\.E\\+00<(\r*\n+)" } +! { dg-output "-6\\.E-01<(\r*\n+)" } +! { dg-output "-5\\.E-01<(\r*\n+)" } +! { dg-output "4\\.E\\+01<(\r*\n+)" } +! { dg-output "1\\.E\\+04<(\r*\n+)" } +! { dg-output "3\\.E\\+02<(\r*\n+)" } +! { dg-output "3\\.E\\+02<(\r*\n+)" } diff --git a/Fortran/gfortran/regression/fmt_zero_width.f90 b/Fortran/gfortran/regression/fmt_zero_width.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fmt_zero_width.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +! PR90374 "5.5 d0.d, e0.d, es0.d, en0.d, g0.d and ew.d edit descriptors +program pr90374 + implicit none + real(4) :: rn + character(32) :: afmt, aresult + real(8) :: one = 1.0D0, zero = 0.0D0, pinf, minf + + rn = 0.00314_4 + afmt = "(D0.3)" + write (aresult,fmt=afmt) rn + if (aresult /= "0.314D-2") stop 12 + afmt = "(E0.10)" + write (aresult,fmt=afmt) rn + if (aresult /= "0.3139999928E-2") stop 15 + afmt = "(ES0.10)" + write (aresult,fmt=afmt) rn + if (aresult /= "3.1399999280E-3") stop 18 + afmt = "(EN0.10)" + write (aresult,fmt=afmt) rn + if (aresult /= "3.1399999280E-3") stop 21 + afmt = "(G0.10)" + write (aresult,fmt=afmt) rn + if (aresult /= "0.3139999928E-2") stop 24 + afmt = "(E0.10e0)" + write (aresult,fmt=afmt) rn + if (aresult /= "0.3139999928E-2") stop 27 + write (aresult,fmt="(D0.3)") rn + if (aresult /= "0.314D-2") stop 29 + write (aresult,fmt="(E0.10)") rn + if (aresult /= "0.3139999928E-2") stop 31 + write (aresult,fmt="(ES0.10)") rn + if (aresult /= "3.1399999280E-3") stop 33 + write (aresult,fmt="(EN0.10)") rn + if (aresult /= "3.1399999280E-3") stop 35 + write (aresult,fmt="(G0.10)") rn + if (aresult /= "0.3139999928E-2") stop 37 + write (aresult,fmt="(E0.10e0)") rn + if (aresult /= "0.3139999928E-2") stop 39 + write (aresult,fmt="(E0.10e3)") rn + if (aresult /= ".3139999928E-002") stop 41 +end diff --git a/Fortran/gfortran/regression/fold_nearest.f90 b/Fortran/gfortran/regression/fold_nearest.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fold_nearest.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! Tests for the constant folding of the NEAREST intrinsic +! We compare against the results of the runtime implementation, +! thereby making sure that they remain consistent +REAL, PARAMETER :: x(10) = (/ 1., 0.49999997, 0.5, 8388609.0, -1., & + -0.49999997, -0.5, -8388609.0, & + 0., 0. /), & + dir(10) = (/ -1., +1., -1., -1., +1., & + -1., +1., +1., & + +1.,-1./) +REAL :: a(10) + +a = x +if (nearest (x(1), dir(1)) /= nearest (a(1), dir(1))) STOP 1 +if (nearest (x(2), dir(2)) /= nearest (a(2), dir(2))) STOP 2 +if (nearest (x(3), dir(3)) /= nearest (a(3), dir(3))) STOP 3 +if (nearest (x(4), dir(4)) /= nearest (a(4), dir(4))) STOP 4 +if (nearest (x(5), dir(5)) /= nearest (a(5), dir(5))) STOP 5 +if (nearest (x(6), dir(6)) /= nearest (a(6), dir(6))) STOP 6 +if (nearest (x(7), dir(7)) /= nearest (a(7), dir(7))) STOP 7 +if (nearest (x(8), dir(8)) /= nearest (a(8), dir(8))) STOP 8 +! These last two tests are commented out because mpfr provides no support +! for denormals, and therefore we get TINY instead of the correct result. +!if (nearest (x(9), dir(9)) /= nearest (a(9), dir(9))) STOP 9 +!if (nearest (x(10), dir(10)) /= nearest (a(10), dir(10))) STOP 10 + +end diff --git a/Fortran/gfortran/regression/forall_1.f90 b/Fortran/gfortran/regression/forall_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/forall_1.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! tests FORALL statements with a mask +dimension i2(15,10), i1(15) +type a + sequence + integer k +end type a +type(a) :: a1(10), a2(5,5) + +i1 = (/ 0, 1, 2, 3, 4, 0, 6, 7, 8, 9, 10, 0, 0, 13, 14 /) +forall (i=1:15, i1(i) /= 0) + i1(i) = 0 +end forall +if (any(i1 /= 0)) STOP 1 + +a1(:)%k = i1(1:10) +forall (i=1:10, a1(i)%k == 0) + a1(i)%k = i +end forall +if (any (a1(:)%k /= (/ (i, i=1,10) /))) STOP 2 + +forall (i=1:15, j=1:10, a1(j)%k <= j) + i2(i,j) = j + i*11 +end forall +do i=1,15 + if (any (i2(i,:) /= (/ (i*11 + j, j=1,10) /))) STOP 3 +end do +end diff --git a/Fortran/gfortran/regression/forall_10.f90 b/Fortran/gfortran/regression/forall_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/forall_10.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! { dg-options "-O" } +! Tests the fix for PR30400, in which the use of ANY in the +! FORALL mask was rejected. +! +! Contributed by Dominique d'Humieres +! +program pr30400_1 + real, dimension (5, 5, 5, 5) :: a + + a (:, :, :, :) = 4 + a (:, 2, :, 4) = 10 + a (:, 2, :, 1) = 0 + + forall (i = 1:5, j = 1:5, k = 1:5, any (a (i, j, k, :) .gt. 6)) + forall (l = 1:5, any (a (:, :, :, l) .lt. 2)) + a (i, j, k, l) = i - j + k - l + end forall + end forall + if (sum (a) .ne. 2625.0) STOP 1 + + ! Check that the fix has not broken the treatment of the '==' + forall (i = 1:5, i == 3) a(i, i, i, i) = -5 + if (sum (a) .ne. 2616.0) STOP 2 +end diff --git a/Fortran/gfortran/regression/forall_11.f90 b/Fortran/gfortran/regression/forall_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/forall_11.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! PR 25076 +! We erroneously accepted it when a FORALL index was used in a triplet +! specification within the same FORALL header +INTEGER :: A(10,10) +FORALL(I=1:10,J=I:10) ! { dg-error "FORALL index 'i' may not appear in triplet specification" } + A(I,J)=I+J +ENDFORALL + +forall (i=1:10, j=1:i) ! { dg-error "FORALL index 'i' may not appear in triplet specification" } + a(i,j) = 5 +end forall + +forall (i=1:10, j=1:10:i) ! { dg-error "FORALL index 'i' may not appear in triplet specification" } + a(i,j) = i - j +end forall + +forall (i=i:10) ! { dg-error "FORALL index 'i' may not appear in triplet specification" } + forall (j=1:j:i) ! { dg-error "FORALL index 'j' may not appear in triplet specification" } + a(i,j) = i*j + end forall +end forall + +forall (i=1:10:i) ! { dg-error "FORALL index 'i' may not appear in triplet specification" } + a(1,i) = 2 +end forall + +forall (i=1:10) + forall (j=i:10) + a(i,j) = i*j + end forall +end forall +END diff --git a/Fortran/gfortran/regression/forall_12.f90 b/Fortran/gfortran/regression/forall_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/forall_12.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! Tests the fix for PR31217 and PR33811 , in which dependencies were not +! correctly handled for the assignments below and, when this was fixed, +! the last two ICEd on trying to create the temorary. +! +! Contributed by Joost VandeVondele +! Dominique d'Humieres +! and Paul Thomas +! + character(len=1) :: a = "1" + character(len=1) :: b(4) = (/"1","2","3","4"/), c(4) + c = b + forall(i=1:1) a(i:i) = a(i:i) ! This was the original PR31217 + forall(i=1:1) b(i:i) = b(i:i) ! The rest were found to be broken + forall(i=1:1) b(:)(i:i) = b(:)(i:i) + forall(i=1:1) b(1:3)(i:i) = b(2:4)(i:i) + if (any (b .ne. (/"2","3","4","4"/))) STOP 1 + b = c + forall(i=1:1) b(2:4)(i:i) = b(1:3)(i:i) + if (any (b .ne. (/"1","1","2","3"/))) STOP 2 + b = c + do i = 1, 1 + b(2:4)(i:i) = b(1:3)(i:i) ! This was PR33811 and Paul's bit + end do + if (any (b .ne. (/"1","1","2","3"/))) STOP 3 + call foo +contains + subroutine foo + character(LEN=12) :: a(2) = "123456789012" + character(LEN=12) :: b = "123456789012" +! These are Dominique's + forall (i = 3:10) a(:)(i:i+2) = a(:)(i-2:i) + IF (a(1) .ne. "121234567890") STOP 4 + forall (i = 3:10) a(2)(i:i+2) = a(1)(i-2:i) + IF (a(2) .ne. "121212345678") STOP 5 + forall (i = 3:10) b(i:i+2) = b(i-2:i) + IF (b .ne. "121234567890") STOP 6 + end subroutine +end + diff --git a/Fortran/gfortran/regression/forall_13.f90 b/Fortran/gfortran/regression/forall_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/forall_13.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! Tests the fix for PR33686, in which dependencies were not +! correctly handled for the assignments below. +! +! Contributed by Dick Hendrickson on comp.lang.fortran, +! " Most elegant syntax for inverting a permutation?" 20071006 +! +! Test the fix for PR36091 as well... +! { dg-options "-fbounds-check" } +! + integer :: p(4) = (/2,4,1,3/) + forall (i = 1:4) p(p(i)) = i ! This was the original + if (any (p .ne. (/3,1,4,2/))) STOP 1 + + forall (i = 1:4) p(5 - p(i)) = p(5 - i) ! This is a more complicated version + if (any (p .ne. (/1,2,3,4/))) STOP 2 +end diff --git a/Fortran/gfortran/regression/forall_14.f90 b/Fortran/gfortran/regression/forall_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/forall_14.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! +! PR fortran/46205 +! +! Contributed by Jonathan Stott +! + +program forallBug + logical :: valid(4) = (/ .true., .true., .false., .true. /) + real :: vec(4) + integer :: j + + ! This is an illegal statement. It should read valid(j), not valid. + forall (j = 1:4, valid) ! { dg-error "requires a scalar LOGICAL expression" } + vec(j) = sin(2*3.14159/j) + end forall +end program forallBug diff --git a/Fortran/gfortran/regression/forall_15.f90 b/Fortran/gfortran/regression/forall_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/forall_15.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize -fdump-tree-original" } +! PR 50564 - this used to ICE with front end optimization. +! Original test case by Andrew Benson. +program test + implicit none + double precision, dimension(2) :: timeSteps, control + integer :: iTime + double precision :: ratio + double precision :: a + + ratio = 0.7d0 + control(1) = ratio**(dble(1)-0.5d0)-ratio**(dble(1)-1.5d0) + control(2) = ratio**(dble(2)-0.5d0)-ratio**(dble(2)-1.5d0) + forall(iTime=1:2) + timeSteps(iTime)=ratio**(dble(iTime)-0.5d0)-ratio**(dble(iTime)-1.5d0) + end forall + if (any(abs(timesteps - control) > 1d-10)) STOP 1 + + ! Make sure we still do the front-end optimization after a forall + a = cos(ratio)*cos(ratio) + sin(ratio)*sin(ratio) + if (abs(a-1.d0) > 1d-10) STOP 2 +end program test +! { dg-final { scan-tree-dump-times "__builtin_cos" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_sin" 1 "original" } } diff --git a/Fortran/gfortran/regression/forall_16.f90 b/Fortran/gfortran/regression/forall_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/forall_16.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR fortran/50540 +! + implicit none + integer i,dest(10) + forall (i=2:ix) dest(i)=i ! { dg-error "has no IMPLICIT type" } +end ! { dg-error "Cannot convert UNKNOWN to INTEGER" "" { target "*-*-*" } .-1 } diff --git a/Fortran/gfortran/regression/forall_17.f90 b/Fortran/gfortran/regression/forall_17.f90 --- /dev/null +++ b/Fortran/gfortran/regression/forall_17.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-ffrontend-optimize" } +! PR fortran/66385 - this used to ICE +! Original test case by Mianzhi Wang +program test + double precision::aa(30) + double precision::a(3,3),b + b=1d0 + forall(i=1:3) + a(:,i)=b*[1d0,2d0,3d0] + end forall + + forall(i=1:10) + aa(10*[0,1,2]+i)=1d0 + end forall + +end program diff --git a/Fortran/gfortran/regression/forall_18.f90 b/Fortran/gfortran/regression/forall_18.f90 --- /dev/null +++ b/Fortran/gfortran/regression/forall_18.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! PR fortran/69741 - improve error message for nonscalar FORALL index variables +! +subroutine check + integer :: ii(2), i + real :: a(3,2) + + forall (ii(1)=1:3, i=1:2) ! { dg-error "scalar variable of type integer" } + a(ii(1),i) = ii(1) * i + end forall + + forall (j=1:3, ii(2)=1:2) ! { dg-error "scalar variable of type integer" } + a(j,ii(2)) = j * ii(2) + end forall + +end subroutine check diff --git a/Fortran/gfortran/regression/forall_19.f90 b/Fortran/gfortran/regression/forall_19.f90 --- /dev/null +++ b/Fortran/gfortran/regression/forall_19.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! PR fortran/98307 - Dependency check fails when using "allocatable" + +program forall_deps + implicit none + type t + logical :: valid = .true. + integer :: s = 0 + integer, allocatable :: p(:) + end type + type(t) :: v(2) + integer :: i + + allocate (v(1)%p(8)) + allocate (v(2)%p(8)) + v(1)%s = 8 + v(2)%s = 6 + + v(1)%p(:) = [1, 2, 3, 4, 5, 6, 7, 8] + v(2)%p(:) = [13, 14, 15, 16, 17, 18, 19, 20] + forall (i=1:2) + v(i)%p(1:v(i)%s) = v(3-i)%p(1:v(i)%s) + end forall + if (any(v(2)%p(:) /= [1, 2, 3, 4, 5, 6, 19, 20])) stop 1 + + v(1)%p(:) = [1, 2, 3, 4, 5, 6, 7, 8] + v(2)%p(:) = [13, 14, 15, 16, 17, 18, 19, 20] + forall (i=1:2, v(i)%valid) + v(i)%p(1:v(i)%s) = v(3-i)%p(1:v(i)%s) + end forall + if (any(v(2)%p(:) /= [1, 2, 3, 4, 5, 6, 19, 20])) stop 2 +end diff --git a/Fortran/gfortran/regression/forall_2.f90 b/Fortran/gfortran/regression/forall_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/forall_2.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR fortran/25101 -- Stride must be nonzero. +program forall_2 + integer :: a(10),j(2),i + forall(i=1:2:0) ! { dg-error "stride expression at" } + a(i)=1 + end forall +end program forall_2 + diff --git a/Fortran/gfortran/regression/forall_3.f90 b/Fortran/gfortran/regression/forall_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/forall_3.f90 @@ -0,0 +1,18 @@ +! the problem here was that we had forgot to call +! fold_convert in gfc_trans_pointer_assign_need_temp +! so that we got a pointer to char instead of a +! pointer to an array +! we really don't need a temp here. +! { dg-do compile } + + program test_forall + type element + character(32), pointer :: name + end type element + type(element) :: charts(50) + character(32), target :: names(50) + forall(i=1:50) + charts(i)%name => names(i) + end forall + end + diff --git a/Fortran/gfortran/regression/forall_4.f90 b/Fortran/gfortran/regression/forall_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/forall_4.f90 @@ -0,0 +1,66 @@ +! { dg-do run } +! Tests the fix for PR25072, in which mask expressions +! that start with an internal or intrinsic function +! reference would give a syntax error. +! +! The fix for PR28119 is tested as well; here, the forall +! statement could not be followed by another statement on +! the same line. +! +! Contributed by Paul Thomas +! +module foo + integer, parameter :: n = 4 +contains + pure logical function foot (i) + integer, intent(in) :: i + foot = (i == 2) .or. (i == 3) + end function foot +end module foo + + use foo + integer :: i, a(n) + logical :: s(n) + s = (/(foot (i), i=1, n)/) + +! Check that non-mask case is still OK and the fix for PR28119 + a = 0 + forall (i=1:n) a(i) = i ; if (any (a .ne. (/1,2,3,4/))) STOP 1 + +! Now a mask using a function with an explicit interface +! via use association. + a = 0 + forall (i=1:n, foot (i)) a(i) = i + if (any (a .ne. (/0,2,3,0/))) STOP 2 + +! Now an array variable mask + a = 0 + forall (i=1:n, .not. s(i)) a(i) = i + if (any (a .ne. (/1,0,0,4/))) STOP 3 + +! This was the PR - an internal function mask + a = 0 + forall (i=1:n, t (i)) a(i) = i + if (any (a .ne. (/0,2,0,4/))) STOP 4 + +! Check that an expression is OK - this also gave a syntax +! error + a = 0 + forall (i=1:n, mod (i, 2) == 0) a(i) = i + if (any (a .ne. (/0,2,0,4/))) STOP 5 + +! And that an expression that used to work is OK + a = 0 + forall (i=1:n, s (i) .or. t(i)) a(i) = w (i) + if (any (a .ne. (/0,3,2,1/))) STOP 6 + +contains + pure logical function t(i) + integer, intent(in) :: i + t = (mod (i, 2) == 0) + end function t + pure integer function w(i) + integer, intent(in) :: i + w = 5 - i + end function w +end diff --git a/Fortran/gfortran/regression/forall_5.f90 b/Fortran/gfortran/regression/forall_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/forall_5.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! Tests the fix for PR25072, in which non-PURE functions could +! be referenced inside a FORALL mask. +! +! Contributed by Paul Thomas +! +module foo + integer, parameter :: n = 4 +contains + logical function foot (i) + integer, intent(in) :: i + foot = (i == 2) .or. (i == 3) + end function foot +end module foo + + use foo + integer :: i, a(n) + logical :: s(n) + + a = 0 + forall (i=1:n, foot (i)) a(i) = i ! { dg-error "impure" } + if (any (a .ne. (/0,2,3,0/))) STOP 1 + + forall (i=1:n, s (i) .or. t(i)) a(i) = i ! { dg-error "impure|LOGICAL" } + if (any (a .ne. (/0,3,2,1/))) STOP 2 + + a = 0 + forall (i=1:n, mod (i, 2) == 0) a(i) = w (i) ! { dg-error "impure" } + if (any (a .ne. (/0,2,0,4/))) STOP 3 + +contains + logical function t(i) + integer, intent(in) :: i + t = (mod (i, 2) == 0) + end function t + integer function w(i) + integer, intent(in) :: i + w = 5 - i + end function w +end diff --git a/Fortran/gfortran/regression/forall_6.f90 b/Fortran/gfortran/regression/forall_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/forall_6.f90 @@ -0,0 +1,18 @@ +! PR fortran/30404 +! Checks that we correctly handle nested masks in nested FORALL blocks. +! Contributed by Paul Thomas +! +! { dg-do run } + logical :: l1(2,2) + integer :: it(2,2) + l1(:,:) = reshape ((/.false.,.true.,.true.,.false./), (/2,2/)) + it(:,:) = reshape ((/1,2,3,4/), (/2,2/)) + forall (i = 1:2, i < 3) + forall (j = 1:2, l1(i,j)) + it(i, j) = 0 + end forall + end forall +! print *, l1 +! print '(4i2)', it + if (any (it .ne. reshape ((/1, 0, 0, 4/), (/2, 2/)))) STOP 1 +end diff --git a/Fortran/gfortran/regression/forall_7.f90 b/Fortran/gfortran/regression/forall_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/forall_7.f90 @@ -0,0 +1,16 @@ +! { dg-do run } + integer :: a(10,10) + integer :: tot + a(:,:) = 0 + forall (i = 1:10) + forall (j = 1:10) + a(i,j) = 1 + end forall + forall (k = 1:10) + a(i,k) = a(i,k) + 1 + end forall + end forall + tot = sum(a(:,:)) +! print *, tot + if (tot .ne. 200) STOP 1 +end diff --git a/Fortran/gfortran/regression/forall_8.f90 b/Fortran/gfortran/regression/forall_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/forall_8.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } + integer a(100) + forall (i=1:100,.true.) + a(i) = 0 + end forall + end +! { dg-final { scan-tree-dump-times "temp" 0 "original" } } diff --git a/Fortran/gfortran/regression/forall_9.f90 b/Fortran/gfortran/regression/forall_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/forall_9.f90 @@ -0,0 +1,8 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } + integer a(100) + forall (i=1:100,.false.) + a(i) = 0 + end forall + end +! { dg-final { scan-tree-dump-times "temp" 0 "original" } } diff --git a/Fortran/gfortran/regression/forall_char_dependencies_1.f90 b/Fortran/gfortran/regression/forall_char_dependencies_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/forall_char_dependencies_1.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! Tests fix for PR29211, in which an ICE would be produced by FORALL assignments +! with dependencies. +! +! Contributed by Paul Thomas +! + character(12), dimension(2) :: a, b + a= (/"abcdefghijkl","mnopqrstuvwx"/) +! OK because it uses gfc_trans_assignment + forall (i=1:2) b(i) = a(i) +! Was broken - gfc_trans_assign_need_temp had no handling of string lengths + forall (i=1:2) a(3-i) = a(i) +end diff --git a/Fortran/gfortran/regression/format_string.f b/Fortran/gfortran/regression/format_string.f --- /dev/null +++ b/Fortran/gfortran/regression/format_string.f @@ -0,0 +1,31 @@ +c { dg-do compile } +c PR fortran/50407 +c + program bar + + interface operator (.ip.) + function mul (i1, i2) + character(20) mul + intent(in) :: i1,i2 + end function + end interface + + character(20) foo + i=3 + j=4 + print 2.ip.8 ! compiles fine + print i.ip.2 ! compiles fine + print i.ip.j ! compiles fine + foo = 1_'(I0,I4.4)' + print foo, i,j + print 1_'(I0,1X,I4.4)', i, j + end + + function mul (i1, i2) + character(20) mul + intent(in) :: i1,i2 + integer prod + prod=i1*i2 + write(mul,100) prod +100 format("('ok ",i2,"')") + end function diff --git a/Fortran/gfortran/regression/fraction.f90 b/Fortran/gfortran/regression/fraction.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fraction.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! +! Test for pr52413 +! + +program test_frac + + real :: y + y=fraction (-2.0) + if (fraction (-2.0) /= -0.5) STOP 1 + if (fraction (-0.0) /= 0.0) STOP 2 + if (sign(1.0, fraction(-0.0)) /= -1.0) STOP 3 + if (fraction (-2.0_8) /= -0.5) STOP 4 + +end program test_frac diff --git a/Fortran/gfortran/regression/fseek.f90 b/Fortran/gfortran/regression/fseek.f90 --- /dev/null +++ b/Fortran/gfortran/regression/fseek.f90 @@ -0,0 +1,52 @@ +! { dg-do run } + +PROGRAM test_fseek + INTEGER, PARAMETER :: SEEK_SET = 0, SEEK_CUR = 1, SEEK_END = 2, fd=10 + INTEGER :: ierr = 0 + INTEGER :: newline_length + + ! We first need to determine if a newline is one or two characters + open (911,status="scratch") + write(911,"()") + newline_length = ftell(911) + close (911) + if (newline_length < 1 .or. newline_length > 2) STOP 1 + + open(fd, status="scratch") + ! expected position: one leading blank + 10 + newline + WRITE(fd, *) "1234567890" + IF (FTELL(fd) /= 11 + newline_length) STOP 2 + + ! move backward from current position + CALL FSEEK(fd, -11 - newline_length, SEEK_CUR, ierr) + IF (ierr /= 0 .OR. FTELL(fd) /= 0) STOP 3 + + ! move to negative position (error) + CALL FSEEK(fd, -1, SEEK_SET, ierr) + IF (ierr == 0 .OR. FTELL(fd) /= 0) STOP 4 + + ! move forward from end (11 + 10 + newline) + CALL FSEEK(fd, 10, SEEK_END, ierr) + IF (ierr /= 0 .OR. FTELL(fd) /= 21 + newline_length) STOP 5 + + ! set position (0) + CALL FSEEK(fd, 0, SEEK_SET, ierr) + IF (ierr /= 0 .OR. FTELL(fd) /= 0) STOP 6 + + ! move forward from current position + CALL FSEEK(fd, 5, SEEK_CUR, ierr) + IF (ierr /= 0 .OR. FTELL(fd) /= 5) STOP 7 + + CALL FSEEK(fd, HUGE(0_1), SEEK_SET, ierr) + IF (ierr /= 0 .OR. FTELL(fd) /= HUGE(0_1)) STOP 8 + + CALL FSEEK(fd, HUGE(0_2), SEEK_SET, ierr) + IF (ierr /= 0 .OR. FTELL(fd) /= HUGE(0_2)) STOP 9 + + CALL FSEEK(fd, HUGE(0_4), SEEK_SET, ierr) + IF (ierr /= 0 .OR. FTELL(fd) /= HUGE(0_4)) STOP 10 + + CALL FSEEK(fd, -HUGE(0_4), SEEK_CUR, ierr) + IF (ierr /= 0 .OR. FTELL(fd) /= 0) STOP 11 +END PROGRAM + diff --git a/Fortran/gfortran/regression/ftell_1.f90 b/Fortran/gfortran/regression/ftell_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/ftell_1.f90 @@ -0,0 +1,16 @@ +! { dg-do run } + integer(kind=8) o, o2 + + open (10, status="scratch") + call ftell (10, o) + if (o /= 0) STOP 1 + write (10,"(A)") "1234567" + call ftell (10, o) + if (o /= 8 .and. o /= 9) STOP 2 + write (10,"(A)") "1234567" + call ftell (10, o2) + if (o2 /= 2 * o) STOP 3 + close (10) + call ftell (10, o) + if (o /= -1) STOP 4 + end diff --git a/Fortran/gfortran/regression/ftell_2.f90 b/Fortran/gfortran/regression/ftell_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/ftell_2.f90 @@ -0,0 +1,12 @@ +! { dg-do run } + integer(kind=8) o + open (10, status="scratch") + if (ftell(10) /= 0) STOP 1 + write (10,"(A)") "1234567" + if (ftell(10) /= 8 .and. ftell(10) /= 9) STOP 2 + o = ftell(10) + write (10,"(A)") "1234567" + if (ftell(10) /= 2 * o) STOP 3 + close (10) + if (ftell(10) /= -1) STOP 4 + end diff --git a/Fortran/gfortran/regression/ftell_3.f90 b/Fortran/gfortran/regression/ftell_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/ftell_3.f90 @@ -0,0 +1,42 @@ +! { dg-do run { target fd_truncate } } +! PR43605 FTELL intrinsic returns incorrect position +! Contributed by Janne Blomqvist, Manfred Schwarb +! and Dominique d'Humieres. +program ftell_3 + integer :: i, j + character(1) :: ch + character(len=99) :: buffer + open(10, form='formatted', position='rewind') + write(10, '(a)') '123456' + write(10, '(a)') '789' + write(10, '(a)') 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC' + write(10, '(a)') 'DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD' + rewind(10) + read(10, '(a)') buffer + call ftell(10, i) +! Expected: On '\n' systems: 7, on \r\n systems: 8 + if(i /= 7 .and. i /= 8) then + STOP 1 + end if + read(10,'(a)') buffer + if (trim(buffer) /= "789") then + STOP 1 + end if + call ftell(10,j) + close(10) + open(10, access="stream") +! Expected: On '\n' systems: 11, on \r\n systems: 13 + if (i == 7) then + read(10, pos=7) ch + if (ch /= char(10)) STOP 2 + if (j /= 11) STOP 3 + end if + if (i == 8) then + read(10, pos=7) ch + if (ch /= char(13)) STOP 4 + read(10) ch + if (ch /= char(10)) STOP 5 + if (j /= 13) STOP 6 + end if + close(10, status="delete") +end program ftell_3 diff --git a/Fortran/gfortran/regression/func_assign.f90 b/Fortran/gfortran/regression/func_assign.f90 --- /dev/null +++ b/Fortran/gfortran/regression/func_assign.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! +! PR fortran/31559 +! Do not allow assigning to external functions +! +! Contributed by Steve Kargl +! +module mod + implicit none +contains + integer function bar() + bar = 4 + end function bar + + subroutine a() + implicit none + real :: fun + external fun + interface + function funget(a) + integer :: a + end function + subroutine sub() + end subroutine sub + end interface + sub = 'a' ! { dg-error "is not a variable" } + fun = 4.4 ! { dg-error "is not a variable" } + funget = 4 ! { dg-error "is not a variable" } + bar = 5 ! { dg-error "is not a variable" } + end subroutine a +end module mod + +end diff --git a/Fortran/gfortran/regression/func_assign_2.f90 b/Fortran/gfortran/regression/func_assign_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/func_assign_2.f90 @@ -0,0 +1,33 @@ +! { dg-do run } +! Test the fix for PR40551 in which the assignment +! was not dealing correctly with non-contiguous lhs +! references; eg. a(1,:) +! +! Reported by by Maciej Zwierzycki +! at http://gcc.gnu.org/ml/fortran/2009-06/msg00254.html +! and by Tobias Burnus on Bugzilla +! +integer :: a(2,2) +a = -42 +a(1,:) = func() +if (any (reshape (a, [4]) /= [1, -42, 2, -42])) STOP 1 +a = -42 +a(2,:) = func() +if (any (reshape (a, [4]) /= [-42, 1, -42, 2])) STOP 2 +a = -42 +a(:,1) = func() +if (any (reshape (a, [4]) /= [1, 2, -42, -42])) STOP 3 +a = -42 +a(:,2) = func() +if (any (reshape (a, [4]) /= [-42, -42, 1, 2])) STOP 4 +contains + function func() + integer :: func(2) + call sub(func) + end function func + subroutine sub(a) + integer :: a(2) + a = [1,2] + end subroutine +end + diff --git a/Fortran/gfortran/regression/func_assign_3.f90 b/Fortran/gfortran/regression/func_assign_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/func_assign_3.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! Tests the fix for PR40646 in which the assignment would cause an ICE. +! +! Contributed by Charlie Sharpsteen +! http://gcc.gnu.org/ml/fortran/2009-07/msg00010.html +! and reported by Tobias Burnus +! +module bugTestMod + implicit none + type:: boundTest + contains + procedure, nopass:: test => returnMat + end type boundTest +contains + function returnMat( a, b ) result( mat ) + integer:: a, b, i + double precision, dimension(a,b):: mat + mat = dble (reshape ([(i, i = 1, a * b)],[a,b])) + return + end function returnMat +end module bugTestMod + +program bugTest + use bugTestMod + implicit none + integer i + double precision, dimension(2,2):: testCatch + type( boundTest ):: testObj + testCatch = testObj%test(2,2) ! This would cause an ICE + if (any (testCatch .ne. dble (reshape ([(i, i = 1, 4)],[2,2])))) STOP 1 +end program bugTest diff --git a/Fortran/gfortran/regression/func_decl_1.f90 b/Fortran/gfortran/regression/func_decl_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/func_decl_1.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! we didn't correctly reject function declarations without argument lists +! note that there are no end statements for syntactically wrong function +! declarations + interface + function f1 ! { dg-error "Expected formal argument list" } + function f3() + end function f3 + function f4 result (x) ! { dg-error "Expected formal argument list" } + function f5() result (x) + end function f5 + end interface + f1 = 1. +end + +FUNCTION f1 ! { dg-error "Expected formal argument list" } + +function f2() + f2 = 1. +end function f2 + +function f3 result (x) ! { dg-error "Expected formal argument list" } + +function f4 () result (x) + x = 4. +end function f4 diff --git a/Fortran/gfortran/regression/func_decl_2.f90 b/Fortran/gfortran/regression/func_decl_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/func_decl_2.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! Test fix for PR16943 in which the double typing of +! N caused an error. +! +! Contributed by Paul Thomas +! + program bug8 + implicit none + stop " OK. " + + contains + + integer function bugf(M) result (N) + integer, intent (in) :: M + integer :: N ! { dg-error "already has basic type of INTEGER" } + N = M + return + end function bugf + end program bug8 diff --git a/Fortran/gfortran/regression/func_decl_3.f90 b/Fortran/gfortran/regression/func_decl_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/func_decl_3.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! Tests the fix for PR24325 in which the lack of any declaration +! that foo is a function or even a procedure was not detected. +! +! Contributed by Jakub Jelinek +! + integer foo + call test +contains + subroutine test + integer :: i + i = foo () ! { dg-error "is not a function" } + end subroutine test +end + diff --git a/Fortran/gfortran/regression/func_decl_4.f90 b/Fortran/gfortran/regression/func_decl_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/func_decl_4.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-c" } +! +! Functions shall not have an initializer. +! +! Due to -fwhole-file, the function declaration +! warnings come before the init warnings; thus +! the warning for the WRONG lines have been moved to +! func_decl_5.f90 +! + +function f1() + integer :: f1 = 42 ! WRONG, see func_decl_5.f90 +end function + +function f2() RESULT (r) + integer :: r = 42 ! WRONG, see func_decl_5.f90 +end function + +function f3() RESULT (f3) ! { dg-error "must be different than function name" } + integer :: f3 = 42 +end function ! { dg-error "Expecting END PROGRAM" } +! { dg-error "Unexpected end of file" "" { target "*-*-*" } 0 } diff --git a/Fortran/gfortran/regression/func_decl_5.f90 b/Fortran/gfortran/regression/func_decl_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/func_decl_5.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-c" } +! +! Functions shall not have an initializer. +! +! Some tests were moved from func_decl_4.f90 to here. +! + +function f1() ! { dg-error "cannot have an initializer" } + integer :: f1 = 42 +end function + +function f2() RESULT (r) ! { dg-error "cannot have an initializer" } + integer :: r = 42 +end function diff --git a/Fortran/gfortran/regression/func_derived_1.f90 b/Fortran/gfortran/regression/func_derived_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/func_derived_1.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR 17244 +! verifies that functions returning derived type work +module m + type t + integer i + real x + character*5 c + integer arr(5,5) + end type t +end module m + +use m +type(t) :: r +integer arr(5,5), vect(25), vect2(25) +do i=1,25 + vect = 0 + vect(i) = i + arr = reshape (vect, shape(arr)) + r = f(i,real(i),"HALLO",arr) + + if (r%i .ne. i) STOP 1 + if (r%x .ne. real(i)) STOP 2 + if (r%c .ne. "HALLO") STOP 3 + vect2 = reshape (r%arr, shape(vect2)) + if (any(vect2.ne.vect)) STOP 4 +end do +contains + +function f(i,x,c,arr) + type(t) :: f + character*5 c + integer arr(5,5) + + f = t(i,x,c,arr) +end function f + +end diff --git a/Fortran/gfortran/regression/func_derived_2.f90 b/Fortran/gfortran/regression/func_derived_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/func_derived_2.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! This tests the "virtual fix" for PR19561, where functions returning +! pointers to derived types were not generating correct code. This +! testcase is based on a simplified example in the PR discussion. +! +! Submitted by Paul Thomas pault@gcc.gnu.org +! Slightly extended by Tobias Schlüter +module mpoint + type :: mytype + integer :: i + end type mytype + +contains + + function get (a) result (b) + type (mytype), target :: a + type (mytype), pointer :: b + b => a + end function get + + function get2 (a) + type (mytype), target :: a + type (mytype), pointer :: get2 + get2 => a + end function get2 + +end module mpoint + +program func_derived_2 + use mpoint + type (mytype), target :: x + type (mytype), pointer :: y + x = mytype (42) + y => get (x) + if (y%i.ne.42) STOP 1 + + x = mytype (112) + y => get2 (x) + if (y%i.ne.112) STOP 2 +end program func_derived_2 diff --git a/Fortran/gfortran/regression/func_derived_3.f90 b/Fortran/gfortran/regression/func_derived_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/func_derived_3.f90 @@ -0,0 +1,125 @@ +! { dg-do run } +! This tests the "virtual fix" for PR19561, where pointers to derived +! types were not generating correct code. This testcase is based on +! the original PR example. This example not only tests the +! original problem but throughly tests derived types in modules, +! module interfaces and compound derived types. +! +! Original by Martin Reinecke martin@mpa-garching.mpg.de +! Submitted by Paul Thomas pault@gcc.gnu.org +! Slightly modified by Tobias Schlüter +module func_derived_3 + implicit none + type objA + private + integer :: i + end type objA + + interface new + module procedure oaInit + end interface + + interface print + module procedure oaPrint + end interface + + private + public objA,new,print + +contains + + subroutine oaInit(oa,i) + integer :: i + type(objA) :: oa + oa%i=i + end subroutine oaInit + + subroutine oaPrint (oa) + type (objA) :: oa + write (10, '("simple = ",i5)') oa%i + end subroutine oaPrint + +end module func_derived_3 + +module func_derived_3a + use func_derived_3 + implicit none + + type objB + private + integer :: i + type(objA), pointer :: oa + end type objB + + interface new + module procedure obInit + end interface + + interface print + module procedure obPrint + end interface + + private + public objB, new, print, getOa, getOa2 + +contains + + subroutine obInit (ob,oa,i) + integer :: i + type(objA), target :: oa + type(objB) :: ob + + ob%i=i + ob%oa=>oa + end subroutine obInit + + subroutine obPrint (ob) + type (objB) :: ob + write (10, '("derived = ",i5)') ob%i + call print (ob%oa) + end subroutine obPrint + + function getOa (ob) result (oa) + type (objB),target :: ob + type (objA), pointer :: oa + + oa=>ob%oa + end function getOa + +! without a result clause + function getOa2 (ob) + type (objB),target :: ob + type (objA), pointer :: getOa2 + + getOa2=>ob%oa + end function getOa2 + +end module func_derived_3a + + use func_derived_3 + use func_derived_3a + implicit none + type (objA),target :: oa + type (objB),target :: ob + character (len=80) :: line + + open (10, status='scratch') + + call new (oa,1) + call new (ob, oa, 2) + + call print (ob) + call print (getOa (ob)) + call print (getOa2 (ob)) + + rewind (10) + read (10, '(80a)') line + if (trim (line).ne."derived = 2") STOP 1 + read (10, '(80a)') line + if (trim (line).ne."simple = 1") STOP 2 + read (10, '(80a)') line + if (trim (line).ne."simple = 1") STOP 3 + read (10, '(80a)') line + if (trim (line).ne."simple = 1") STOP 4 + close (10) +end program diff --git a/Fortran/gfortran/regression/func_derived_4.f90 b/Fortran/gfortran/regression/func_derived_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/func_derived_4.f90 @@ -0,0 +1,103 @@ +! { dg-do run } +! PR fortran/30793 +! Check that pointer-returing functions +! work derived types. +! +! Contributed by Salvatore Filippone. +! +module class_mesh + type mesh + real(kind(1.d0)), allocatable :: area(:) + end type mesh +contains + subroutine create_mesh(msh) + type(mesh), intent(out) :: msh + allocate(msh%area(10)) + return + end subroutine create_mesh +end module class_mesh + +module class_field + use class_mesh + implicit none + private ! Default + public :: create_field, field + public :: msh_ + + type field + private + type(mesh), pointer :: msh => null() + integer :: isize(2) + end type field + + interface msh_ + module procedure msh_ + end interface + interface create_field + module procedure create_field + end interface +contains + subroutine create_field(fld,msh) + type(field), intent(out) :: fld + type(mesh), intent(in), target :: msh + fld%msh => msh + fld%isize = 1 + end subroutine create_field + + function msh_(fld) + type(mesh), pointer :: msh_ + type(field), intent(in) :: fld + msh_ => fld%msh + end function msh_ +end module class_field + +module class_scalar_field + use class_field + implicit none + private + public :: create_field, scalar_field + public :: msh_ + + type scalar_field + private + type(field) :: base + real(kind(1.d0)), allocatable :: x(:) + real(kind(1.d0)), allocatable :: bx(:) + real(kind(1.d0)), allocatable :: x_old(:) + end type scalar_field + + interface create_field + module procedure create_scalar_field + end interface + interface msh_ + module procedure get_scalar_field_msh + end interface +contains + subroutine create_scalar_field(fld,msh) + use class_mesh + type(scalar_field), intent(out) :: fld + type(mesh), intent(in), target :: msh + call create_field(fld%base,msh) + allocate(fld%x(10),fld%bx(20)) + end subroutine create_scalar_field + + function get_scalar_field_msh(fld) + use class_mesh + type(mesh), pointer :: get_scalar_field_msh + type(scalar_field), intent(in), target :: fld + + get_scalar_field_msh => msh_(fld%base) + end function get_scalar_field_msh +end module class_scalar_field + +program test_pnt + use class_mesh + use class_scalar_field + implicit none + type(mesh) :: msh + type(mesh), pointer :: mshp + type(scalar_field) :: quality + call create_mesh(msh) + call create_field(quality,msh) + mshp => msh_(quality) +end program test_pnt diff --git a/Fortran/gfortran/regression/func_derived_5.f90 b/Fortran/gfortran/regression/func_derived_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/func_derived_5.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! PR fortran/41369 - rejected empty type in function return values + +module m + type t + end type t +end module + +type(t) function foo() + use m + foo = t() +end function foo diff --git a/Fortran/gfortran/regression/func_result_1.f90 b/Fortran/gfortran/regression/func_result_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/func_result_1.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! From PR 19673 : We didn't dereference the result from POINTER +! functions with a RESULT clause +program ret_ptr + if (foo(99) /= bar(99)) STOP 1 +contains + function foo (arg) result(ptr) + integer :: arg + integer, pointer :: ptr + allocate (ptr) + ptr = arg + end function foo + function bar (arg) + integer :: arg + integer, pointer :: bar + allocate (bar) + bar = arg + end function bar +end program ret_ptr diff --git a/Fortran/gfortran/regression/func_result_2.f90 b/Fortran/gfortran/regression/func_result_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/func_result_2.f90 @@ -0,0 +1,10 @@ +! { dg-do run } +! Character functions with a result clause were broken +program testch + if (ch().ne."hello ") STOP 1 +contains + function ch () result(str) + character(len = 10) :: str + str ="hello" + end function ch +end program testch diff --git a/Fortran/gfortran/regression/func_result_3.f90 b/Fortran/gfortran/regression/func_result_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/func_result_3.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! PR fortran/32088 +! +! Test implicitly defined result variables +! +subroutine dummy +contains + function quadric(a,b) result(c) + intent(in) a,b; dimension a(0:3),b(0:3),c(0:9) + c(0)=a(0)*b(0); c(1:3)=a(1:)*b(0)+a(0)*b(1:); c(4:6)=a(1:)*b(1:) + c(7:9)=(/a(1)*b(2)+b(1)*a(2),a(1)*b(3)+b(1)*a(3),a(2)*b(3)+b(2)*a(3)/) + end function +end subroutine dummy + +subroutine dummy2 +implicit none +contains + function quadric(a,b) result(c) ! { dg-error "no IMPLICIT type" } + real :: a, b + intent(in) a,b; dimension a(0:3),b(0:3),c(0:9) + c(0)=a(0)*b(0); c(1:3)=a(1:)*b(0)+a(0)*b(1:); c(4:6)=a(1:)*b(1:) + c(7:9)=(/a(1)*b(2)+b(1)*a(2),a(1)*b(3)+b(1)*a(3),a(2)*b(3)+b(2)*a(3)/) + end function +end subroutine dummy2 +end diff --git a/Fortran/gfortran/regression/func_result_4.f90 b/Fortran/gfortran/regression/func_result_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/func_result_4.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-c" } +! +! Do not apply the SAVE attribute to function results. +! +FUNCTION f() RESULT (g) + INTEGER :: g + SAVE + g = 42 +END FUNCTION diff --git a/Fortran/gfortran/regression/func_result_5.f90 b/Fortran/gfortran/regression/func_result_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/func_result_5.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! PR fortran/42650 +! +! Result type was not working +! + +type(t) function func2() result(res) + type t + sequence + integer :: i = 5 + end type t + res%i = 2 +end function func2 diff --git a/Fortran/gfortran/regression/func_result_6.f90 b/Fortran/gfortran/regression/func_result_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/func_result_6.f90 @@ -0,0 +1,71 @@ +! { dg-do run } +! +! PR fortran/47775 +! +! Contributed by Fran Martinez Fadrique +! +! Before, a temporary was missing for generic procedured (cf. test()) +! as the allocatable attribute was ignored for the check whether a +! temporary is required +! +module m +type t +contains + procedure, NOPASS :: foo => foo + generic :: gen => foo +end type t +contains + function foo(i) + integer, allocatable :: foo(:) + integer :: i + allocate(foo(2)) + foo(1) = i + foo(2) = i + 10 + end function foo +end module m + +use m +type(t) :: x +integer, pointer :: ptr1, ptr2 +integer, target :: bar1(2) +integer, target, allocatable :: bar2(:) + +allocate(bar2(2)) +ptr1 => bar1(2) +ptr2 => bar2(2) + +bar1 = x%gen(1) +if (ptr1 /= 11) STOP 1 +bar1 = x%foo(2) +if (ptr1 /= 12) STOP 2 +bar2 = x%gen(3) +if (ptr2 /= 13) STOP 3 +bar2 = x%foo(4) +if (ptr2 /= 14) STOP 4 +bar2(:) = x%gen(5) +if (ptr2 /= 15) STOP 5 +bar2(:) = x%foo(6) +if (ptr2 /= 16) STOP 6 + +call test() +end + +subroutine test +interface gen + procedure foo +end interface gen + +integer, target :: bar(2) +integer, pointer :: ptr +bar = [1,2] +ptr => bar(2) +if (ptr /= 2) STOP 7 +bar = gen() +if (ptr /= 77) STOP 8 +contains + function foo() + integer, allocatable :: foo(:) + allocate(foo(2)) + foo = [33, 77] + end function foo +end subroutine test diff --git a/Fortran/gfortran/regression/func_result_7.f90 b/Fortran/gfortran/regression/func_result_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/func_result_7.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! PR 50073: gfortran must not accept function name when result name is present +! +! Contributed by Vittorio Zecca + +function fun() result(f) ! { dg-error "RESULT variable" } + pointer fun ! { dg-error "RESULT variable" } + dimension fun(1) ! { dg-error "RESULT variable" } + f=0 +end diff --git a/Fortran/gfortran/regression/function_charlen_1.f90 b/Fortran/gfortran/regression/function_charlen_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/function_charlen_1.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! Tests the fix for PR34429 in which function charlens that were +! USE associated would cause an error. +! +! Contributed by Tobias Burnus +! +module m + integer, parameter :: strlen = 5 +end module m + +character(strlen) function test() + use m + test = 'A' +end function test + + interface + character(strlen) function test() + use m + end function test + end interface + print *, test() +end diff --git a/Fortran/gfortran/regression/function_charlen_2.f90 b/Fortran/gfortran/regression/function_charlen_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/function_charlen_2.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! Tests the fix for PR34429 in which function charlens that were +! USE associated would cause an error. +! +! Contributed by Tobias Burnus +! +module m + integer, parameter :: l = 2 + character(2) :: cl +end module m + +program test + implicit none + integer, parameter :: l = 5 + character(len = 10) :: c + character(4) :: cl + c = f () + if (g () /= "2") STOP 1 +contains + character(len = l) function f () + use m + if (len (f) /= 2) STOP 2 + f = "a" + end function f + character(len = len (cl)) function g () + use m + g = "4" + if (len (g) == 2) g= "2" + end function g +end program test diff --git a/Fortran/gfortran/regression/function_charlen_3.f b/Fortran/gfortran/regression/function_charlen_3.f --- /dev/null +++ b/Fortran/gfortran/regression/function_charlen_3.f @@ -0,0 +1,18 @@ +C { dg-do compile } +C Tests the fix for the regression PR34872, in which the re-matching of +C the function declaration made a mess if the first executable statement +C had a label. + CHARACTER FUNCTION s() + 10 CONTINUE + GOTO 10 + s = ' ' + END FUNCTION s + + CHARACTER FUNCTION t() + 10 format ("q") + write (t, 10) + END FUNCTION t + + character t + if (t() .ne. "q") STOP 1 + end diff --git a/Fortran/gfortran/regression/function_kinds_1.f90 b/Fortran/gfortran/regression/function_kinds_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/function_kinds_1.f90 @@ -0,0 +1,53 @@ +! { dg-do run } +! Tests the fix for PR31229, PR31154 and PR33334, in which +! the KIND and TYPE parameters in the function declarations +! would cause errors. +! +! Contributed by Brooks Moses +! and Tobias Burnus +! +module kinds + implicit none + integer, parameter :: dp = selected_real_kind(6) + type t + integer :: i + end type t + interface + real(dp) function y() + import + end function + end interface +end module kinds + +type(t) function func() ! The legal bit of PR33334 + use kinds + func%i = 5 +end function func + +real(dp) function another_dp_before_defined () + use kinds + another_dp_before_defined = real (kind (4.0_DP)) +end function + +module mymodule; +contains + REAL(2*DP) function declared_dp_before_defined() + use kinds, only: dp + real (dp) :: x + declared_dp_before_defined = 1.0_dp + x = 1.0_dp + declared_dp_before_defined = real (kind (x)) + end function +end module mymodule + + use kinds + use mymodule + type(t), external :: func + type(t) :: z + if (kind (y ()) .ne. 4) STOP 1 + if (kind (declared_dp_before_defined ()) .ne. 8) STOP 2 + if (int (declared_dp_before_defined ()) .ne. 4) STOP 3 + if (int (another_dp_before_defined ()) .ne. 4) STOP 4 + z = func() + if (z%i .ne. 5) STOP 5 +end diff --git a/Fortran/gfortran/regression/function_kinds_2.f90 b/Fortran/gfortran/regression/function_kinds_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/function_kinds_2.f90 @@ -0,0 +1,19 @@ +! Tests the fix for PR33334, in which the TYPE in the function +! declaration cannot be legally accessed. +! +! Contributed by Tobias Burnus +! +module types + implicit none + type t + integer :: i = 99 + end type t +end module + +module x + use types + interface + type(t) function bar() ! { dg-error "is not accessible" } + end function + end interface +end module diff --git a/Fortran/gfortran/regression/function_kinds_3.f90 b/Fortran/gfortran/regression/function_kinds_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/function_kinds_3.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! +! PR fortran/34254 +! +! The character-kind parameter was not accepted. +! +module m + integer, parameter :: char_t = kind('a') +end module m + +character(1,char_t) function test1() + use m + test1 = 'A' +end function test1 + +character(len=1,kind=char_t) function test2() + use m + test2 = 'A' +end function test2 + +character(kind=char_t,len=1) function test3() + use m + test3 = 'A' +end function test3 + +character(1,kind=char_t) function test4() + use m + test4 = 'A' +end function test4 diff --git a/Fortran/gfortran/regression/function_kinds_4.f90 b/Fortran/gfortran/regression/function_kinds_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/function_kinds_4.f90 @@ -0,0 +1,55 @@ +! { dg-do run } +! Tests the fix for PR34471 in which function KINDs that were +! USE associated would cause an error. +! +! This only needs to be run once. +! { dg-options "-O2" } +! +! Contributed by Tobias Burnus +! +module m1 + integer, parameter :: i1 = 1, i2 = 2 +end module m1 + +module m2 + integer, parameter :: i1 = 8 +end module m2 + +integer(i1) function three() + use m1, only: i2 + use m2 ! This provides the function kind + three = i1 + if(three /= kind(three)) STOP 1 +end function three + +! At one stage during the development of the patch, this started failing +! but was not tested in gfortran.dg. */ +real (kind(0d0)) function foo () + foo = real (kind (foo)) +end function + +program main +implicit none + interface + integer(8) function three() + end function three + end interface + integer, parameter :: i1 = 4 + integer :: i + real (kind(0d0)) foo + i = one() + i = two() + if(three() /= 8) STOP 2 + if (int(foo()) /= 8) STOP 3 +contains + integer(i1) function one() ! Host associated kind + if (kind(one) /= 4) STOP 4 + one = 1 + end function one + integer(i1) function two() ! Use associated kind + use m1, only: i2 + use m2 + if (kind(two) /= 8) STOP 5 + two = 1 + end function two +end program main diff --git a/Fortran/gfortran/regression/function_kinds_5.f90 b/Fortran/gfortran/regression/function_kinds_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/function_kinds_5.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! Tests the fix for PR34471 in which function KINDs that were +! USE associated would cause an error. This checks a regression +! caused by an intermediate version of the patch. +! +! Contributed by Tobias Burnus +! +real (bad_kind(0d0)) function foo () ! { dg-error "must be an intrinsic function" } + foo = real (kind (foo)) +end function +! { dg-prune-output "Bad kind expression for function" } diff --git a/Fortran/gfortran/regression/function_optimize_1.f90 b/Fortran/gfortran/regression/function_optimize_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/function_optimize_1.f90 @@ -0,0 +1,46 @@ +! { dg-do compile } +! { dg-options "-O -fdump-tree-original -finline-matmul-limit=0 -Warray-temporaries" } +program main + implicit none + real, dimension(2,2) :: a, b, c, d + integer :: i + real :: x, z + character(60) :: line + real, external :: ext_func + interface + elemental function element(x) + real, intent(in) :: x + real :: elem + end function element + pure function mypure(x) + real, intent(in) :: x + integer :: mypure + end function mypure + elemental impure function elem_impure(x) + real, intent(in) :: x + real :: elem_impure + end function elem_impure + end interface + + data a /2., 3., 5., 7./ + data b /11., 13., 17., 23./ + write (unit=line, fmt='(4F7.2)') matmul(a,b) & + & + matmul(a,b) ! { dg-warning "Creating array temporary" } + z = sin(x) + cos(x) + sin(x) + cos(x) + print *,z + x = ext_func(a) + 23 + ext_func(a) + print *,d,x + z = element(x) + element(x) + print *,z + i = mypure(x) - mypure(x) + print *,i + z = elem_impure(x) - elem_impure(x) + print *,z +end program main +! { dg-final { scan-tree-dump-times "matmul_r4" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_sinf" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_cosf" 1 "original" } } +! { dg-final { scan-tree-dump-times "ext_func" 2 "original" } } +! { dg-final { scan-tree-dump-times "element" 1 "original" } } +! { dg-final { scan-tree-dump-times "mypure" 1 "original" } } +! { dg-final { scan-tree-dump-times "elem_impure" 2 "original" } } diff --git a/Fortran/gfortran/regression/function_optimize_10.f90 b/Fortran/gfortran/regression/function_optimize_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/function_optimize_10.f90 @@ -0,0 +1,57 @@ +! { dg-do run } +! PR 51858 - this used to generate wrong code. +! Original test case by Don Simons. + +program main + implicit none + logical :: test1_ok + logical :: test2_ok + logical :: test3_ok + character(len=1):: charq + + charq = 'c' + + test1_ok = .true. + test2_ok = .false. + if (charq .eq. ' ') then + test1_ok = .false. + else if ((my_ichar(charq).ge.97 .and. my_ichar(charq).le.103)) then + test2_OK = .true. + end if + if ((.not. test1_ok) .or. (.not. test2_ok)) STOP 1 + + test1_ok = .true. + test2_ok = .true. + test3_ok = .false. + + if (charq .eq. ' ') then + test1_ok = .false. + else if ((my_ichar(charq).lt.97 .or. my_ichar(charq).gt.103)) then + test2_ok = .false. + else if ((my_ichar(charq).ge.97 .and. my_ichar(charq).le.103)) then + test3_ok = .true. + end if + if ((.not. test1_ok) .or. (.not. test2_ok) .or. (.not. test3_ok)) STOP 2 + + test1_ok = .true. + test2_ok = .true. + test3_ok = .false. + + if (charq .eq. ' ') then + test1_ok = .false. + else if ((my_ichar(charq).lt.97 .or. my_ichar(charq).gt.103)) then + test2_ok = .false. + else + test3_ok = .true. + end if + + if ((.not. test1_ok) .or. (.not. test2_ok) .or. (.not. test3_ok)) STOP 3 + +contains + pure function my_ichar(c) + integer :: my_ichar + character(len=1), intent(in) :: c + my_ichar = ichar(c) + end function my_ichar +end program main + diff --git a/Fortran/gfortran/regression/function_optimize_11.f90 b/Fortran/gfortran/regression/function_optimize_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/function_optimize_11.f90 @@ -0,0 +1,17 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize" } +! Do not move common functions out of implicit DO loop constructors. +program test + integer, parameter :: N = 4 + integer, parameter :: dp=kind(1.d0) + real(kind=dp), parameter :: pi=4*atan(1._dp) + real(kind=dp), parameter :: eps = 1.e-14_dp + real(kind=dp) :: h1(0:N-1), h2(0:N-1) + integer i + + i = 1 + h1 = [(cos(2*pi*mod(i*k,N)/N),k=0,N/2), & + & (sin(2*pi*mod(i*k,N)/N),k=1,N/2-1)] + h2 = (/ 1._dp, 0._dp, -1._dp, 1._dp /) + if (any(abs(h1 - h2) > eps)) STOP 1 +end program test diff --git a/Fortran/gfortran/regression/function_optimize_12.f90 b/Fortran/gfortran/regression/function_optimize_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/function_optimize_12.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! { dg-options "-ffrontend-optimize" } +! PR 53148 - this used to cause wrong code because the label was +! placed after the statement assigning the new variables. +program main + integer :: n + double precision x + n = 3 + goto 100 +100 x = dble(n) + dble(n) + if (x /= 6.d0) STOP 1 +end program main diff --git a/Fortran/gfortran/regression/function_optimize_2.f90 b/Fortran/gfortran/regression/function_optimize_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/function_optimize_2.f90 @@ -0,0 +1,46 @@ +! { dg-do compile } +! { dg-options "-O -finline-matmul-limit=0 -faggressive-function-elimination -fdump-tree-original" } +program main + implicit none + real, dimension(2,2) :: a, b, c, d + real :: x, z + integer :: i + character(60) :: line + real, external :: ext_func + interface + elemental function element(x) + real, intent(in) :: x + real :: elem + end function element + pure function mypure(x) + real, intent(in) :: x + integer :: mypure + end function mypure + elemental impure function elem_impure(x) + real, intent(in) :: x + real :: elem_impure + end function elem_impure + end interface + + data a /2., 3., 5., 7./ + data b /11., 13., 17., 23./ + write (unit=line, fmt='(4F7.2)') matmul(a,b) + matmul(a,b) + x = 1.2 + z = sin(x) + cos(x) + sin(x) + cos(x) + print *,z + x = ext_func(a) + 23 + ext_func(a) + print *,d,x + z = element(x) + element(x) + print *,z + i = mypure(x) - mypure(x) + print *,i + z = elem_impure(x) - elem_impure(x) + print *,z +end program main +! { dg-final { scan-tree-dump-times "matmul_r4" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_sinf" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_cosf" 1 "original" } } +! { dg-final { scan-tree-dump-times "ext_func" 1 "original" } } +! { dg-final { scan-tree-dump-times "element" 1 "original" } } +! { dg-final { scan-tree-dump-times "mypure" 1 "original" } } +! { dg-final { scan-tree-dump-times "elem_impure" 1 "original" } } diff --git a/Fortran/gfortran/regression/function_optimize_3.f90 b/Fortran/gfortran/regression/function_optimize_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/function_optimize_3.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! { dg-options "-O" } +! PR 48352 - variable elimination in a DO loop caused segfaults. +! Test case contributed by Joost VandeVondele +program main + INTEGER, DIMENSION(:), POINTER :: a + DO I=1,MIN(SIZE(a),SIZE(a)) + ENDDO +END program main diff --git a/Fortran/gfortran/regression/function_optimize_4.f90 b/Fortran/gfortran/regression/function_optimize_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/function_optimize_4.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-options "-O" } +! PR 48412 - function elimination got temporary varibles in the wrong order. +! Test case contributed by Joost VandeVondele. + +INTEGER FUNCTION S1(m,ma,lx) +INTEGER :: m,ma,lx + +IF (((m < 0).AND.(MODULO(ABS(ma-lx),2) == 1)).OR.& + ((m > 0).AND.(MODULO(ABS(ma-lx),2) == 0))) THEN + S1=1 +ELSE + S1=0 +ENDIF + +END FUNCTION + +INTEGER :: s1 +IF (S1(1,2,1).NE.0) STOP 1 +END diff --git a/Fortran/gfortran/regression/function_optimize_5.f90 b/Fortran/gfortran/regression/function_optimize_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/function_optimize_5.f90 @@ -0,0 +1,41 @@ +! { dg-do compile } +! { dg-options "-ffrontend-optimize -faggressive-function-elimination -finline-matmul-limit=0 -Wfunction-elimination" } +! Check the -ffrontend-optimize (in the absence of -O) and +! -Wfunction-elimination options. +program main + implicit none + real, dimension(2,2) :: a, b, c, d + integer :: i + real :: x, z + character(60) :: line + real, external :: ext_func + interface + elemental function element(x) + real, intent(in) :: x + real :: elem + end function element + pure function mypure(x) + real, intent(in) :: x + integer :: mypure + end function mypure + elemental impure function elem_impure(x) + real, intent(in) :: x + real :: elem_impure + end function elem_impure + end interface + + data a /2., 3., 5., 7./ + data b /11., 13., 17., 23./ + write (unit=line, fmt='(4F7.2)') matmul(a,b) & + & + matmul(a,b) + z = sin(x) + 2.0 + sin(x) + print *,z + x = ext_func(a) + 23 + ext_func(a) ! { dg-warning "Removing call to impure function" } + print *,d,x + z = element(x) + element(x) + print *,z + i = mypure(x) - mypure(x) + print *,i + z = elem_impure(x) - elem_impure(x) ! { dg-warning "Removing call to impure function" } + print *,z +end program main diff --git a/Fortran/gfortran/regression/function_optimize_6.f90 b/Fortran/gfortran/regression/function_optimize_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/function_optimize_6.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-O -fdump-tree-original" } +! PR 48405 - function elimnination in a DO loop should work. +program main + interface + pure function mypure() + integer :: mypure + end function mypure + end interface + DO I=1,mypure() + mypure() + ENDDO +END program main +! { dg-final { scan-tree-dump-times "mypure" 1 "original" } } + + diff --git a/Fortran/gfortran/regression/function_optimize_7.f90 b/Fortran/gfortran/regression/function_optimize_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/function_optimize_7.f90 @@ -0,0 +1,46 @@ +! { dg-do compile } +! { dg-options "-O -fdump-tree-original -Warray-temporaries -finline-matmul-limit=0" } +subroutine xx(n, m, a, b, c, d, x, z, i, s_in, s_out) + implicit none + integer, intent(in) :: n, m + real, intent(in), dimension(n,n) :: a, b, c + real, intent(out), dimension(n,n) :: d + real, intent(in), dimension(n,m) :: s_in + real, intent(out), dimension(m) :: s_out + integer, intent(out) :: i + real, intent(inout) :: x + real, intent(out) :: z + character(60) :: line + real, external :: ext_func + integer :: one = 1 + interface + elemental function element(x) + real, intent(in) :: x + real :: elem + end function element + pure function mypure(x) + real, intent(in) :: x + integer :: mypure + end function mypure + elemental impure function elem_impure(x) + real, intent(in) :: x + real :: elem_impure + end function elem_impure + end interface + + d = matmul(a,b) + matmul(a,b) ! { dg-warning "Creating array temporary" } + z = sin(x) + cos(x) + sin(x) + cos(x) + x = ext_func(a) + 23 + ext_func(a) + z = element(x) + element(x) + i = mypure(x) - mypure(x) + z = elem_impure(x) - elem_impure(x) + s_out = sum(s_in,one) + 3.14 / sum(s_in,one) ! { dg-warning "Creating array temporary" } +end subroutine xx +! { dg-final { scan-tree-dump-times "matmul_r4" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_sinf" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_cosf" 1 "original" } } +! { dg-final { scan-tree-dump-times "ext_func" 2 "original" } } +! { dg-final { scan-tree-dump-times "element" 1 "original" } } +! { dg-final { scan-tree-dump-times "mypure" 1 "original" } } +! { dg-final { scan-tree-dump-times "elem_impure" 2 "original" } } +! { dg-final { scan-tree-dump-times "sum_r4" 1 "original" } } diff --git a/Fortran/gfortran/regression/function_optimize_8.f90 b/Fortran/gfortran/regression/function_optimize_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/function_optimize_8.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! { dg-options "-O -fdump-tree-original" } +module x + implicit none +contains + pure function myfunc(x) result(y) + integer, intent(in) :: x + integer, dimension(:), allocatable :: y + allocate (y(3)) + y(1) = x + y(2) = 2*x + y(3) = 3*x + end function myfunc + + pure function mychar(x) result(r) + integer, intent(in) :: x + character(len=2) :: r + r = achar(x + iachar('0')) // achar(x + iachar('1')) + end function mychar +end module x + +program main + use x + implicit none + integer :: n + character(len=20) :: line + n = 3 + write (unit=line,fmt='(3I2)') myfunc(n) + myfunc(n) + if (line /= ' 61218') STOP 1 + write (unit=line,fmt='(A)') mychar(2) // mychar(2) + if (line /= '2323') STOP 2 +end program main +! { dg-final { scan-tree-dump-times "myfunc" 2 "original" } } +! { dg-final { scan-tree-dump-times "mychar" 2 "original" } } diff --git a/Fortran/gfortran/regression/function_optimize_9.f90 b/Fortran/gfortran/regression/function_optimize_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/function_optimize_9.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-O -fdump-tree-original" } +program main + integer, parameter :: n=100 + real, parameter :: pi=4*atan(1.) + real, parameter :: tmax=20. + real, parameter :: dt = tmax/(2*pi)/real(n) + real, parameter :: t0 = dt/30. + integer :: i + interface + pure function purefunc(x) + real :: purefunc + real, intent(in) :: x + end function purefunc + end interface + real :: a(n) + do i=1,n + a(i) = purefunc(dt*i + t0) * 3. + 2 * purefunc(t0 + i*dt) + end do + print *,a +end program main +! { dg-final { scan-tree-dump-times "purefunc" 1 "original" } } diff --git a/Fortran/gfortran/regression/function_reference_1.f90 b/Fortran/gfortran/regression/function_reference_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/function_reference_1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR 44960 - this was erroneusly accepted. +! Original test case by Daniel Franke. + +type t + integer :: a +end type t +type(t) :: foo +print *, foo(1)%a ! { dg-error "Unexpected junk" } +end + diff --git a/Fortran/gfortran/regression/function_reference_2.f90 b/Fortran/gfortran/regression/function_reference_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/function_reference_2.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! PR 44960 - improve the error message +program main + type t + integer :: a +end type t +type(t) :: foo +external foo +i = foo(1)%1 ! { dg-error "leftmost part-ref in a data-ref cannot be a function reference" } +end diff --git a/Fortran/gfortran/regression/function_types_1.f90 b/Fortran/gfortran/regression/function_types_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/function_types_1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! Tests the fix for PR34431 in which function TYPEs that were +! USE associated would cause an error. +! +! Contributed by Tobias Burnus +! +module bar +contains + type(non_exist) function func2() ! { dg-error "not accessible" } + end function func2 +end module bar diff --git a/Fortran/gfortran/regression/function_types_2.f90 b/Fortran/gfortran/regression/function_types_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/function_types_2.f90 @@ -0,0 +1,103 @@ +! { dg-do compile } +! Tests the fix for PR34431 in which function TYPEs that were +! USE associated would cause an error. +! +! Contributed by Tobias Burnus +! +module m1 + integer :: hh + type t + real :: r + end type t +end module m1 + +module m2 + type t + integer :: k + end type t +end module m2 + +module m3 +contains + type(t) function func() + use m2 + func%k = 77 + end function func +end module m3 + +type(t) function a() + use m1, only: hh + type t2 + integer :: j + end type t2 + type t + logical :: b + end type t + + a%b = .true. +end function a + +type(t) function b() + use m1, only: hh + use m2 + use m3 + b = func () + b%k = 5 +end function b + +type(t) function c() + use m1, only: hh + type t2 + integer :: j + end type t2 + type t + logical :: b + end type t + + c%b = .true. +end function c + +program main + type t + integer :: m + end type t +contains + type(t) function a1() + use m1, only: hh + type t2 + integer :: j + end type t2 + type t + logical :: b + end type t + + a1%b = .true. + end function a1 + + type(t) function b1() + use m1, only: hh + use m2, only: t +! NAG f95 believes that the host-associated type(t) +! should be used: +! b1%m = 5 +! However, I (Tobias Burnus) believe that the use-associated one should +! be used: + b1%k = 5 + end function b1 + + type(t) function c1() + use m1, only: hh + type t2 + integer :: j + end type t2 + type t + logical :: b + end type t + + c1%b = .true. + end function c1 + + type(t) function d1() + d1%m = 55 + end function d1 +end program main diff --git a/Fortran/gfortran/regression/function_types_3.f90 b/Fortran/gfortran/regression/function_types_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/function_types_3.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! Contributed by Vittorio Zecca +! +! PR 50401: SIGSEGV in resolve_transfer + + interface + function f() ! { dg-error "must be a dummy argument|Interface mismatch in global procedure" } + dimension f(*) + end function + end interface + print *,f() +end + +! PR 50403: SIGSEGV in gfc_use_derived + +type(f) function f() ! { dg-error "Type name 'f' at .1. conflicts with previously declared entity|The type for function 'f' at .1. is not accessible" } + f=110 ! { dg-error "Type inaccessible in variable definition context" } +end diff --git a/Fortran/gfortran/regression/g77_intrinsics_funcs.f b/Fortran/gfortran/regression/g77_intrinsics_funcs.f --- /dev/null +++ b/Fortran/gfortran/regression/g77_intrinsics_funcs.f @@ -0,0 +1,53 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +! Testing g77 intrinsics as subroutines + integer(kind=8) i8 + integer i4 + integer i + character*80 c + + i8 = time () + i4 = time () + i8 = time8 () + i4 = time8 () + + i8 = hostnm (c) + i4 = hostnm (c) + i = hostnm (c) + + i8 = ierrno () + i4 = ierrno () + i = ierrno () + + i8 = kill (i8, i8) + i8 = kill (i8, i4) + i8 = kill (i4, i8) + i8 = kill (i4, i4) + i4 = kill (i8, i8) + i4 = kill (i8, i4) + i4 = kill (i4, i8) + i4 = kill (i4, i4) + + i8 = link ('foo', 'bar') + i4 = link ('foo', 'bar') + i = link ('foo', 'bar') + + i8 = rename ('foo', 'bar') + i4 = rename ('foo', 'bar') + i = rename ('foo', 'bar') + + i8 = symlnk ('foo', 'bar') + i4 = symlnk ('foo', 'bar') + i = symlnk ('foo', 'bar') + +! Cleaning our mess + call unlink ('bar') + +! This should be the last test, unless you want garbage everywhere in +! your filesystem. + i8 = chdir ('..') + i4 = chdir ('..') + i = chdir ('..') + + end diff --git a/Fortran/gfortran/regression/g77_intrinsics_sub.f b/Fortran/gfortran/regression/g77_intrinsics_sub.f --- /dev/null +++ b/Fortran/gfortran/regression/g77_intrinsics_sub.f @@ -0,0 +1,84 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +! Testing g77 intrinsics as subroutines + integer(kind=8) i8, j8 + integer i4, j4 + integer i, j + character*80 c + + call gerror (c) + call getlog (c) + + call hostnm (c, status = i8) + call hostnm (c, i8) + call hostnm (c, status = i4) + call hostnm (c, i4) + call hostnm (c, status = i) + call hostnm (c, i) + call hostnm (c) + + call kill (i8, i8, status = i8) + call kill (i8, i8, i8) + call kill (i4, i8, i8) + call kill (i8, i4, i8) + call kill (i8, i8, i4) + call kill (i4, i4, i8) + call kill (i4, i8, i4) + call kill (i8, i4, i4) + call kill (i4, i4, i4) + call kill (i, i, i) + call kill (i8, i8) + call kill (i4, i8) + call kill (i8, i4) + call kill (i4, i4) + call kill (i, i) + + call link ('foo', 'bar', status = i8) + call link ('foo', 'bar', status = i4) + call link ('foo', 'bar', status = i) + call link ('foo', 'bar', i8) + call link ('foo', 'bar', i4) + call link ('foo', 'bar', i) + call link ('foo', 'bar') + + call perror (c) + + call rename ('foo', 'bar', status = i8) + call rename ('foo', 'bar', status = i4) + call rename ('foo', 'bar', status = i) + call rename ('foo', 'bar', i8) + call rename ('foo', 'bar', i4) + call rename ('foo', 'bar', i) + call rename ('foo', 'bar') + + i = 1 + i4 = 1 + i8 = 1 + call sleep (i) + call sleep (i4) + call sleep (i8) + call sleep (-1) + + call symlnk ('foo', 'bar', status = i8) + call symlnk ('foo', 'bar', status = i4) + call symlnk ('foo', 'bar', status = i) + call symlnk ('foo', 'bar', i8) + call symlnk ('foo', 'bar', i4) + call symlnk ('foo', 'bar', i) + call symlnk ('foo', 'bar') + +! Cleaning our mess + call unlink ('bar') + +! This should be the last test, unless you want garbage everywhere in +! your filesystem. + call chdir ('..', status = i8) + call chdir ('..', i8) + call chdir ('..', status = i4) + call chdir ('..', i4) + call chdir ('..', status = i) + call chdir ('..', i) + call chdir ('..') + + end diff --git a/Fortran/gfortran/regression/gamma_1.f90 b/Fortran/gfortran/regression/gamma_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/gamma_1.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! +! Test the vendor intrinsic (d)gamma, lgamma and algama/dlgama +! gamma is also part of the Fortran 2008 draft; lgamma is called +! log_gamma in the Fortran 2008 draft. +! +! PR fortran/32980 +! +program gamma_test +implicit none +intrinsic :: gamma, lgamma, log_gamma +integer, parameter :: sp = kind(1.0) +integer, parameter :: dp = kind(1.0d0) + +real(sp) :: rsp +real(dp) :: rdp + +if (abs(gamma(1.0_sp) - 1.0_sp) > tiny(1.0_sp)) STOP 1 +if (abs(gamma(1.0_dp) - 1.0_dp) > tiny(1.0_dp)) STOP 2 +if (abs(dgamma(1.0_dp) - 1.0_dp) > tiny(1.0_dp)) STOP 3 + +if (abs(lgamma(1.0_sp)) > tiny(1.0_sp)) STOP 4 +if (abs(lgamma(1.0_dp)) > tiny(1.0_dp)) STOP 5 +if (abs(log_gamma(1.0_sp)) > tiny(1.0_sp)) STOP 6 +if (abs(log_gamma(1.0_dp)) > tiny(1.0_dp)) STOP 7 +if (abs(algama(1.0_sp)) > tiny(1.0_sp)) STOP 8 +if (abs(dlgama(1.0_dp)) > tiny(1.0_dp)) STOP 9 +end program gamma_test + diff --git a/Fortran/gfortran/regression/gamma_2.f90 b/Fortran/gfortran/regression/gamma_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/gamma_2.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! { dg-options "-std=f2003 -Wall" } +! +! Test the vendor intrinsic (d)gamma, lgamma and algama/dlgama +! gamma is also part of the Fortran 2008 draft; lgamma is called +! log_gamma in the Fortran 2008 draft. +! +! PR fortran/32980 +! +subroutine foo() +intrinsic :: gamma ! { dg-error "Fortran 2008" } +intrinsic :: dgamma ! { dg-error "extension" } +intrinsic :: lgamma ! { dg-error "extension" } +intrinsic :: algama ! { dg-error "extension" } +intrinsic :: dlgama ! { dg-error "extension" } + +integer, parameter :: sp = kind(1.0) +integer, parameter :: dp = kind(1.0d0) + +real(sp) :: rsp = 1.0_sp +real(dp) :: rdp = 1.0_dp + +rsp = gamma(rsp) +rdp = gamma(rdp) +rdp = dgamma(rdp) + +rsp = lgamma(rsp) +rdp = lgamma(rdp) +rsp = algama(rsp) +rdp = dlgama(rdp) +end subroutine foo +end diff --git a/Fortran/gfortran/regression/gamma_3.f90 b/Fortran/gfortran/regression/gamma_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/gamma_3.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! Test the vendor intrinsic (d)gamma, lgamma and algama/dlgama +! gamma is also part of the Fortran 2008 draft; lgamma is called +! log_gamma in the Fortran 2008 draft. +! +! PR fortran/32980 +! +program gamma_test +implicit none +intrinsic :: gamma, lgamma +real :: x + +x = gamma(cmplx(1.0,0.0)) ! { dg-error "is not consistent with a specific intrinsic interface" } +x = dgamma(cmplx(1.0,0.0,kind(0d0))) ! { dg-error "must be REAL" } +x = gamma(int(1)) ! { dg-error "is not consistent with a specific intrinsic interface" } +x = dgamma(int(1)) ! { dg-error "must be REAL" } + +x = lgamma(cmplx(1.0,0.0)) ! { dg-error "must be REAL" } +x = algama(cmplx(1.0,0.0)) ! { dg-error "must be REAL" } +x = dlgama(cmplx(1.0,0.0,kind(0d0))) ! { dg-error "must be REAL" } + +x = lgamma(int(1)) ! { dg-error "must be REAL" } +x = algama(int(1)) ! { dg-error "must be REAL" } +x = dlgama(int(1)) ! { dg-error "must be REAL" } +end program gamma_test + diff --git a/Fortran/gfortran/regression/gamma_4.f90 b/Fortran/gfortran/regression/gamma_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/gamma_4.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-require-effective-target fortran_large_real } +! +! Test the Fortran 2008 intrinsics gamma and log_gamma +! +! PR fortran/32980 +! +program gamma_test +implicit none +intrinsic :: gamma, log_gamma +integer, parameter :: qp = selected_real_kind(precision (0.0_8) + 1) + +real(qp) :: rqp + +if (abs(gamma(1.0_qp) - 1.0_qp) > tiny(1.0_qp)) STOP 1 +if (abs(log_gamma(1.0_qp)) > tiny(1.0_qp)) STOP 2 +end program gamma_test + diff --git a/Fortran/gfortran/regression/gamma_5.f90 b/Fortran/gfortran/regression/gamma_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/gamma_5.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +! PR 33683 - we used to pick up the wrong gamma function +! from the library on some systems. +program main + implicit none + integer, parameter :: n_max = 20 + double precision, dimension(0:n_max) :: c + double precision :: pi + integer :: n + double precision :: td, xd + real :: ts,xs + + pi = 4 * atan(1.d0) + c(0) = 1. + do n=1, n_max + c(n) = (2*n-1)*c(n-1)*0.5d0 + end do + + do n=1, n_max + xs = n + 0.5 + xd = n + 0.5d0 + td = c(n)*sqrt(pi) + ts = c(n)*sqrt(pi) + if (abs(gamma(xs)-ts)/ts > 9e-6) STOP 1 + if (abs(gamma(xd)-td)/td > 5e-14) STOP 2 + end do + call tst_s(2.3, gamma(2.3)) + call tst_s(3.7, gamma(3.7)) + call tst_s(5.5, gamma(5.5)) + call tst_d(4.2d0, gamma(4.2d0)) + call tst_d(8.1d0, gamma(8.1d0)) +contains + subroutine tst_s(a, b) + real :: a, b + if (abs(gamma(a) - b)/b > 1e-6) STOP 3 + end subroutine tst_s + + subroutine tst_d(a, b) + double precision :: a,b + if (abs(gamma(a) - b)/b > 5e-14) STOP 4 + end subroutine tst_d +end program main diff --git a/Fortran/gfortran/regression/generic_1.f90 b/Fortran/gfortran/regression/generic_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_1.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! reduced testcase from PR 17535 +module FOO + interface BAR + + subroutine BAR1(X) + integer :: X + end subroutine + + subroutine BAR2(X) + real :: X + end subroutine + + end interface +end module + +subroutine BAZ(X) + use FOO +end subroutine diff --git a/Fortran/gfortran/regression/generic_10.f90 b/Fortran/gfortran/regression/generic_10.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_10.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! Test the patch for PR30081 in which non-generic intrinsic +! procedures could not be overloaded by generic interfaces. +! +! Contributed by Harald Anlauf +! +module gfcbug46 + interface random_seed + module procedure put_seed + end interface + interface random_number + module procedure random_vector + end interface + type t_t + real :: x(2) + end type t_t +contains + subroutine put_seed (n, seed) + integer, intent(inout) :: n + integer, intent(in) :: seed + call random_seed (size=n) + end subroutine put_seed + subroutine random_vector (t) + type(t_t) :: t + call random_number (t% x) + end subroutine random_vector +end module gfcbug46 + + use gfcbug46 + type(t_t) :: z + integer :: n = 2, seed = 1 + call put_seed (n, seed) + call random_number (z) + print *, z +end diff --git a/Fortran/gfortran/regression/generic_11.f90 b/Fortran/gfortran/regression/generic_11.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_11.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! Test the fix for PR25135 in which the ambiguity between subroutine +! foo in m_foo and interface foo in m_bar was not recognised. +! +!Contributed by Yusuke IGUCHI +! +module m_foo +contains + subroutine foo + print *, "foo" + end subroutine +end module + +module m_bar + interface foo + module procedure bar + end interface +contains + subroutine bar + print *, "bar" + end subroutine +end module + +use m_foo +use m_bar + +call foo ! { dg-error "is an ambiguous reference" } +end diff --git a/Fortran/gfortran/regression/generic_12.f90 b/Fortran/gfortran/regression/generic_12.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_12.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! Test the fix for PR30476 in which the generic interface hello +! was found incorrectly to be ambiguous. +! +!Contributed by Tobias Burnus +! +SUBROUTINE hello_x(dum) + IMPLICIT NONE + INTEGER :: dum + WRITE(0,*) "Hello world: ", dum +END SUBROUTINE hello_x + +MODULE interfaces +IMPLICIT NONE +INTERFACE hello + SUBROUTINE hello_x(dum) + IMPLICIT NONE + INTEGER :: dum + END SUBROUTINE hello_x +END INTERFACE +END MODULE interfaces + +MODULE global_module + USE interfaces +END MODULE global_module + +PROGRAM main + USE global_module + IMPLICIT NONE + CALL hello(10) +END PROGRAM main diff --git a/Fortran/gfortran/regression/generic_13.f90 b/Fortran/gfortran/regression/generic_13.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_13.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! tests the patch for PR30870, in which the generic XX was rejected +! because the specific with the same name was not looked for. +! +! Contributed by Joost VandeVondele +! +MODULE TEST + INTERFACE xx + MODULE PROCEDURE xx + END INTERFACE + public :: xx +CONTAINS + SUBROUTINE xx(i) + INTEGER :: I + I=7 + END SUBROUTINE +END +MODULE TOO +CONTAINS + SUBROUTINE SUB(xx,I) + INTERFACE + SUBROUTINE XX(I) + INTEGER :: I + END SUBROUTINE + END INTERFACE + CALL XX(I) + END SUBROUTINE +END MODULE TOO +PROGRAM TT + USE TEST + USE TOO + INTEGER :: I + CALL SUB(xx,I) + IF (I.NE.7) STOP 1 +END PROGRAM diff --git a/Fortran/gfortran/regression/generic_14.f90 b/Fortran/gfortran/regression/generic_14.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_14.f90 @@ -0,0 +1,103 @@ +! { dg-do compile } +! +! Check whether MODULE PROCEDUREs are properly treated +! They need to be contained in a procedure, i.e. an +! interface in another procedure is invalid; they may, however, +! come from a use-associated procedure. +! (The PROCEDURE statement allows also for non-module procedures +! if there is an explicit interface.) +! +! PR fortran/33228 +! +module inclmod + implicit none + interface + subroutine wrong1(a) + integer :: a + end subroutine wrong1 + end interface + interface gen_incl + module procedure ok1 + end interface gen_incl + external wrong2 + external wrong3 + real wrong3 +contains + subroutine ok1(f) + character :: f + end subroutine ok1 +end module inclmod + +module a + use inclmod + implicit none + interface gen + subroutine ok1_a(a,b) + integer :: a,b + end subroutine ok1_a + module procedure ok1, ok2_a + end interface gen +contains + subroutine ok2_a(a,b,c) + integer :: a,b,c + end subroutine ok2_a +end module a + +module b + use inclmod + interface gen_wrong_0 + module procedure gen_incl ! { dg-error "Cannot change attributes" } + end interface gen_wrong_0 +end module b + +module c + use inclmod + interface gen_wrong_1 + module procedure wrong1 ! { dg-error "is not a module procedure" } + end interface gen_wrong_1 +end module c + +module d + use inclmod + interface gen_wrong_2 + module procedure wrong2 ! { dg-error "Cannot change attributes" } + end interface gen_wrong_2 +end module d + +module e + use inclmod + interface gen_wrong_3 + module procedure wrong3 ! { dg-error "Cannot change attributes" } + end interface gen_wrong_3 +end module e + +module f + implicit none + interface + subroutine wrong_a(a) + integer :: a + end subroutine wrong_a + end interface + interface gen_wrong_4 + module procedure wrong_a ! { dg-error "is not a module procedure" } + end interface gen_wrong_4 +end module f + +module g + implicit none + external wrong_b + interface gen_wrong_5 + module procedure wrong_b ! { dg-error "has no explicit interface" } + end interface gen_wrong_5 +end module g + +module h + implicit none + external wrong_c + real wrong_c + interface gen_wrong_6 + module procedure wrong_c ! { dg-error "has no explicit interface" } + end interface gen_wrong_6 +end module h + +end diff --git a/Fortran/gfortran/regression/generic_15.f90 b/Fortran/gfortran/regression/generic_15.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_15.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! Test the fix for PR34231, in which the assumed size 'cnames' +! would be wrongly associated with the scalar argument. +! +! Contributed by +! +MODULE test + + TYPE odbase ; INTEGER :: value ; END TYPE + + INTERFACE odfname + MODULE PROCEDURE odfamilycname,odfamilycnames + END INTERFACE + + CONTAINS + + SUBROUTINE odfamilycnames(base,nfam,cnames) + TYPE(odbase),INTENT(in) :: base + INTEGER ,INTENT(out) :: nfam + CHARACTER(*),INTENT(out) :: cnames(*) + cnames(1:nfam)='odfamilycnames' + END SUBROUTINE + + SUBROUTINE odfamilycname(base,pos,cname) + TYPE(odbase),INTENT(in) :: base + INTEGER ,INTENT(in) :: pos + CHARACTER(*),INTENT(out) :: cname + cname='odfamilycname' + END SUBROUTINE + +END MODULE + +PROGRAM main + USE test + TYPE(odbase) :: base + INTEGER :: i=1 + CHARACTER(14) :: cname + CHARACTER(14) :: cnames(1) + CALL odfname(base,i,cname) + if (trim (cname) .ne. "odfamilycname") STOP 1 + CALL odfname(base,i,cnames) + if (trim (cnames(1)) .ne. "odfamilycnames") STOP 2 +END PROGRAM diff --git a/Fortran/gfortran/regression/generic_16.f90 b/Fortran/gfortran/regression/generic_16.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_16.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! PR35478 internal compiler error: Segmentation fault +MODULE auxiliary + IMPLICIT NONE + INTEGER, PARAMETER, PRIVATE :: dp = SELECTED_REAL_KIND(15) + INTERFACE median + MODULE PROCEDURE R_valmed, I_valmed, D_valmed + END INTERFACE + PUBLIC :: median + PRIVATE :: R_valmed, I_valmed, D_valmed +CONTAINS + RECURSIVE FUNCTION D_valmed (XDONT) RESULT (res_med) + Real (kind=dp), Dimension (:), Intent (In) :: XDONT + Real (kind=dp) :: res_med + res_med = 0.0d0 + END FUNCTION D_valmed + RECURSIVE FUNCTION R_valmed (XDONT) RESULT (res_med) + Real, Dimension (:), Intent (In) :: XDONT + Real :: res_med + res_med = 0.0 + END FUNCTION R_valmed + RECURSIVE FUNCTION I_valmed (XDONT) RESULT (res_med) + Integer, Dimension (:), Intent (In) :: XDONT + Integer :: res_med + res_med = 0 + END FUNCTION I_valmed +END MODULE auxiliary +PROGRAM main + USE auxiliary + IMPLICIT NONE + INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(15) + REAL(kind=dp) :: rawData(2), data, work(3) + data = median(rawData, work) ! { dg-error "no specific function" } +END PROGRAM main diff --git a/Fortran/gfortran/regression/generic_17.f90 b/Fortran/gfortran/regression/generic_17.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_17.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! Test the patch for PR36374 in which the different +! symbols for 'foobar' would be incorrectly flagged as +! ambiguous in foo_mod. +! +! Contributed by Salvatore Filippone +! +module s_foo_mod + type s_foo_type + real(kind(1.e0)) :: v + end type s_foo_type + interface foobar + subroutine s_foobar(x) + import + type(s_foo_type), intent (inout) :: x + end subroutine s_foobar + end interface +end module s_foo_mod + +module d_foo_mod + type d_foo_type + real(kind(1.d0)) :: v + end type d_foo_type + interface foobar + subroutine d_foobar(x) + import + type(d_foo_type), intent (inout) :: x + end subroutine d_foobar + end interface +end module d_foo_mod + +module foo_mod + use s_foo_mod + use d_foo_mod +end module foo_mod + +subroutine s_foobar2(x) + use foo_mod +end subroutine s_foobar2 diff --git a/Fortran/gfortran/regression/generic_18.f90 b/Fortran/gfortran/regression/generic_18.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_18.f90 @@ -0,0 +1,52 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +! Test the fix for PR40443 in which the final call to the generic +! 'SpecElem' was resolved to the elemental rather than the specific +! procedure, which is required by the second part of 12.4.4.1. +! +! Contributed by Ian Harvey +! +MODULE SomeOptions + IMPLICIT NONE + INTERFACE ElemSpec + MODULE PROCEDURE ElemProc + MODULE PROCEDURE SpecProc + END INTERFACE ElemSpec + INTERFACE SpecElem + MODULE PROCEDURE SpecProc + MODULE PROCEDURE ElemProc + END INTERFACE SpecElem +CONTAINS + ELEMENTAL SUBROUTINE ElemProc(a) + CHARACTER, INTENT(OUT) :: a + !**** + a = 'E' + END SUBROUTINE ElemProc + + SUBROUTINE SpecProc(a) + CHARACTER, INTENT(OUT) :: a(:) + !**** + a = 'S' + END SUBROUTINE SpecProc +END MODULE SomeOptions + +PROGRAM MakeAChoice + USE SomeOptions + IMPLICIT NONE + CHARACTER scalar, array(2) + !**** + CALL ElemSpec(scalar) ! Should choose the elemental (and does) + WRITE (*, 100) scalar + CALL ElemSpec(array) ! Should choose the specific (and does) + WRITE (*, 100) array + !---- + CALL SpecElem(scalar) ! Should choose the elemental (and does) + WRITE (*, 100) scalar + CALL SpecElem(array) ! Should choose the specific (but didn't) + WRITE (*, 100) array + !---- + 100 FORMAT(A,:,', ',A) +END PROGRAM MakeAChoice +! { dg-final { scan-tree-dump-times "specproc" 3 "original" } } +! { dg-final { scan-tree-dump-times "elemproc" 3 "original" } } diff --git a/Fortran/gfortran/regression/generic_19.f90 b/Fortran/gfortran/regression/generic_19.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_19.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! Test the fix for PR42481, in which 'sub' was not recognised as +! a generic interface. +! +! Contributed by William Mitchell < william.mitchell@nist.gov> +! +module mod1 +contains + subroutine sub(x, chr) + real x + character(8) chr + if (trim (chr) .ne. "real") STOP 1 + if (int (x) .ne. 1) STOP 2 + end subroutine sub +end module mod1 + +module mod2 + use mod1 + interface sub + module procedure sub, sub_int + end interface sub +contains + subroutine sub_int(i, chr) + character(8) chr + integer i + if (trim (chr) .ne. "integer") STOP 3 + if (i .ne. 1) STOP 4 + end subroutine sub_int +end module mod2 + +program prog + use mod1 + use mod2 + call sub(1, "integer ") + call sub(1.0, "real ") +end program prog diff --git a/Fortran/gfortran/regression/generic_2.f90 b/Fortran/gfortran/regression/generic_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_2.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! testcase from PR 17583 +module bidon + + interface + subroutine drivexc(nspden,rho_updn) + integer, intent(in) :: nspden + integer, intent(in) :: rho_updn(nspden) + end subroutine drivexc + end interface + +end module bidon + + subroutine nonlinear(nspden) + + use bidon + + integer,intent(in) :: nspden + + end subroutine nonlinear diff --git a/Fortran/gfortran/regression/generic_20.f90 b/Fortran/gfortran/regression/generic_20.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_20.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! +! PR fortran/39304 +! +! matmul checking was checking the wrong specific function +! ("one" instead of "two") +! +module m + implicit none + interface one + module procedure one, two + end interface one +contains + function one() + real :: one(1) + one = 0.0 + end function one + function two(x) + real :: x + real :: two(1,1) + two = reshape ( (/ x /), (/ 1, 1 /) ) + end function two +end module m + +use m +real :: res(1) +res = matmul (one(2.0), (/ 2.0/)) +if (abs (res(1)-4.0) > epsilon (res)) STOP 1 +end diff --git a/Fortran/gfortran/regression/generic_21.f90 b/Fortran/gfortran/regression/generic_21.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_21.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! +! PR fortran/42858 +! +! Contributed by Harald Anlauf +! +module gfcbug102 + implicit none + type t_vector_segm + real ,pointer :: x(:) => NULL() + end type t_vector_segm + + type t_vector + integer :: n_s = 0 + type (t_vector_segm) ,pointer :: s (:) => NULL() + end type t_vector + + interface sqrt + module procedure sqrt_vector + end interface sqrt + +contains + function sqrt_vector (x) result (y) + type (t_vector) :: y + type (t_vector) ,intent(in) :: x + integer :: i + do i = 1, y% n_s + y% s(i)% x = sqrt (x% s(i)% x) + end do + end function sqrt_vector +end module gfcbug102 diff --git a/Fortran/gfortran/regression/generic_22.f03 b/Fortran/gfortran/regression/generic_22.f03 --- /dev/null +++ b/Fortran/gfortran/regression/generic_22.f03 @@ -0,0 +1,37 @@ +! { dg-do compile } +! Test the fix for PR43492, in which the generic call caused and ICE. +! +! Contributed by Salvatore Filippone +! +module base_mod + + type :: base_mat + integer, private :: m, n + contains + procedure, pass(a) :: transp1 => base_transp1 + generic, public :: transp => transp1 + procedure, pass(a) :: transc1 => base_transc1 + generic, public :: transc => transc1 + end type base_mat + +contains + + subroutine base_transp1(a) + implicit none + + class(base_mat), intent(inout) :: a + integer :: itmp + itmp = a%m + a%m = a%n + a%n = itmp + end subroutine base_transp1 + subroutine base_transc1(a) + implicit none + class(base_mat), intent(inout) :: a + + call a%transp() +!!$ call a%transp1() + end subroutine base_transc1 + + +end module base_mod diff --git a/Fortran/gfortran/regression/generic_23.f03 b/Fortran/gfortran/regression/generic_23.f03 --- /dev/null +++ b/Fortran/gfortran/regression/generic_23.f03 @@ -0,0 +1,65 @@ +! { dg-do run } +! Test the fix for PR43945 in which the over-ridding of 'doit' and +! 'getit' in type 'foo2' was missed in the specific binding to 'do' and 'get'. +! +! Contributed by Tobias Burnus +! and reported to clf by Salvatore Filippone +! +module foo_mod + type foo + integer :: i + contains + procedure, pass(a) :: doit + procedure, pass(a) :: getit + generic, public :: do => doit + generic, public :: get => getit + end type foo + private doit,getit +contains + subroutine doit(a) + class(foo) :: a + a%i = 1 + write(*,*) 'FOO%DOIT base version' + end subroutine doit + function getit(a) result(res) + class(foo) :: a + integer :: res + res = a%i + end function getit +end module foo_mod + +module foo2_mod + use foo_mod + type, extends(foo) :: foo2 + integer :: j + contains + procedure, pass(a) :: doit => doit2 + procedure, pass(a) :: getit => getit2 +!!$ generic, public :: do => doit +!!$ generic, public :: get => getit + end type foo2 + private doit2, getit2 + +contains + + subroutine doit2(a) + class(foo2) :: a + a%i = 2 + a%j = 3 + end subroutine doit2 + function getit2(a) result(res) + class(foo2) :: a + integer :: res + res = a%j + end function getit2 +end module foo2_mod + +program testd15 + use foo2_mod + type(foo2) :: af2 + + call af2%do() + if (af2%i .ne. 2) STOP 1 + if (af2%get() .ne. 3) STOP 2 + +end program testd15 diff --git a/Fortran/gfortran/regression/generic_24.f90 b/Fortran/gfortran/regression/generic_24.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_24.f90 @@ -0,0 +1,98 @@ +! { dg-do compile } +! +! PR fortran/48889 +! +! Thanks for +! reporting to Lawrence Mitchell +! for the test case to David Ham +! +module sparse_tools + implicit none + private + + type csr_foo + integer, dimension(:), pointer :: colm=>null() + end type csr_foo + + type block_csr_matrix + type(csr_foo) :: sparsity + end type block_csr_matrix + + interface attach_block + module procedure block_csr_attach_block + end interface + + interface size + module procedure sparsity_size + end interface + + public :: size, attach_block +contains + subroutine block_csr_attach_block(matrix, val) + type(block_csr_matrix), intent(inout) :: matrix + real, dimension(size(matrix%sparsity%colm)), intent(in), target :: val + end subroutine block_csr_attach_block + + pure function sparsity_size(sparsity, dim) + integer :: sparsity_size + type(csr_foo), intent(in) :: sparsity + integer, optional, intent(in) :: dim + end function sparsity_size +end module sparse_tools + +module global_numbering + use sparse_tools + implicit none + + type ele_numbering_type + integer :: boundaries + end type ele_numbering_type + + type element_type + integer :: loc + type(ele_numbering_type), pointer :: numbering=>null() + end type element_type + + type csr_sparsity + end type csr_sparsity + + interface size + module procedure sparsity_size + end interface size +contains + pure function sparsity_size(sparsity, dim) + integer :: sparsity_size + type(csr_sparsity), intent(in) :: sparsity + integer, optional, intent(in) :: dim + end function sparsity_size + + subroutine make_boundary_numbering(EEList, xndglno, ele_n) + type(csr_sparsity), intent(in) :: EEList + type(element_type), intent(in) :: ele_n + integer, dimension(size(EEList,1)*ele_n%loc), intent(in), target ::& + & xndglno + integer, dimension(ele_n%numbering%boundaries) :: neigh + integer :: j + j=size(neigh) + end subroutine make_boundary_numbering +end module global_numbering + +module sparse_matrices_fields + use sparse_tools +implicit none + type scalar_field + real, dimension(:), pointer :: val + end type scalar_field +contains + subroutine csr_mult_T_scalar(x) + type(scalar_field), intent(inout) :: x + real, dimension(:), allocatable :: tmp + integer :: i + i=size(x%val) + end subroutine csr_mult_T_scalar +end module sparse_matrices_fields + +program test + use sparse_matrices_fields + use global_numbering +end program test diff --git a/Fortran/gfortran/regression/generic_25.f90 b/Fortran/gfortran/regression/generic_25.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_25.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! +! PR 45521: [F08] GENERIC resolution with ALLOCATABLE/POINTER and PROCEDURE +! +! Contributed by + + interface test + procedure testAlloc + procedure testPtr + end interface + + integer, allocatable :: a1 + integer, pointer :: a2 + + if (.not.test(a1)) STOP 1 + if (test(a2)) STOP 2 + +contains + + logical function testAlloc(obj) + integer, allocatable :: obj + testAlloc = .true. + end function + + logical function testPtr(obj) + integer, pointer :: obj + testPtr = .false. + end function + +end diff --git a/Fortran/gfortran/regression/generic_26.f90 b/Fortran/gfortran/regression/generic_26.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_26.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! PR 45521: [F08] GENERIC resolution with ALLOCATABLE/POINTER and PROCEDURE +! +! Contributed by + +module a + + interface test + procedure testAlloc + procedure testPtr + end interface + +contains + + logical function testAlloc(obj) ! { dg-error "Ambiguous interfaces" } + integer, allocatable :: obj + testAlloc = .true. + end function + + logical function testPtr(obj) ! { dg-error "Ambiguous interfaces" } + integer, pointer :: obj + testPtr = .false. + end function + +end diff --git a/Fortran/gfortran/regression/generic_27.f90 b/Fortran/gfortran/regression/generic_27.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_27.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! +! PR 45521: [F08] GENERIC resolution with ALLOCATABLE/POINTER and PROCEDURE +! +! Contributed by Janus Weil + +module m + implicit none + interface testIF + module procedure test1 + module procedure test2 + end interface +contains + real function test1 (obj) + real :: obj + test1 = obj + end function + real function test2 (pr) + procedure(real) :: pr + test2 = pr(0.) + end function +end module + +program test + use m + implicit none + intrinsic :: cos + + if (testIF(2.0)/=2.0) STOP 1 + if (testIF(cos)/=1.0) STOP 2 + +end program diff --git a/Fortran/gfortran/regression/generic_28.f90 b/Fortran/gfortran/regression/generic_28.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_28.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! +! PR 58998: [4.8/4.9 Regression] Generic interface problem with gfortran +! +! Contributed by Paul van Delst + + interface iargc + procedure iargc_8 + end interface + +contains + + integer(8) function iargc_8() + integer(4) iargc + iargc_8 = iargc() + end function + +end diff --git a/Fortran/gfortran/regression/generic_29.f90 b/Fortran/gfortran/regression/generic_29.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_29.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR fortran/66057 +! +! Original code from Gerhard Steinmetz +! +program p + type t + contains + generic :: ! { dg-error "Malformed GENERIC" } + end type +end diff --git a/Fortran/gfortran/regression/generic_3.f90 b/Fortran/gfortran/regression/generic_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_3.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! Testcase from PR 17713 +module fit_functions + implicit none +contains + subroutine gauss( x, a, y, dy, ma ) + double precision, intent(in) :: x + double precision, intent(in) :: a(:) + double precision, intent(out) :: y + double precision, intent(out) :: dy(:) + integer, intent(in) :: ma + end subroutine gauss +end module fit_functions + +subroutine mrqcof( x, y, sig, ndata, a, ia, ma ) + use fit_functions + + implicit none + double precision, intent(in) :: x(:), y(:), sig(:) + integer, intent(in) :: ndata + double precision, intent(in) :: a(:) + integer, intent(in) :: ia(:), ma + + integer i + double precision yan, dyda(ma) + + do i = 1, ndata + call gauss( x(i), a, yan, dyda, ma ) + end do +end subroutine mrqcof diff --git a/Fortran/gfortran/regression/generic_30.f90 b/Fortran/gfortran/regression/generic_30.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_30.f90 @@ -0,0 +1,41 @@ +! { dg-do compile } +! +! PR fortran/66929 +! Generic procedures as actual argument used to lead to +! a NULL pointer dereference in gfc_get_proc_ifc_for_expr +! because the generic symbol was used as procedure symbol, +! instead of the specific one. + +module iso_varying_string + type, public :: varying_string + character(LEN=1), dimension(:), allocatable :: chars + end type varying_string + interface operator(/=) + module procedure op_ne_VS_CH + end interface operator (/=) + interface trim + module procedure trim_ + end interface +contains + elemental function op_ne_VS_CH (string_a, string_b) result (op_ne) + type(varying_string), intent(in) :: string_a + character(LEN=*), intent(in) :: string_b + logical :: op_ne + op_ne = .true. + end function op_ne_VS_CH + elemental function trim_ (string) result (trim_string) + type(varying_string), intent(in) :: string + type(varying_string) :: trim_string + trim_string = varying_string(["t", "r", "i", "m", "m", "e", "d"]) + end function trim_ +end module iso_varying_string +module syntax_rules + use iso_varying_string, string_t => varying_string +contains + subroutine set_rule_type_and_key + type(string_t) :: key + if (trim (key) /= "") then + print *, "non-empty" + end if + end subroutine set_rule_type_and_key +end module syntax_rules diff --git a/Fortran/gfortran/regression/generic_31.f90 b/Fortran/gfortran/regression/generic_31.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_31.f90 @@ -0,0 +1,35 @@ +! { dg-do run } +! +! PR fortran/66929 +! Check that the specific FIRST symbol is used for the call to FOO, +! so that the J argument is not assumed to be present + +module m + interface foo + module procedure first + end interface foo +contains + elemental function bar(j) result(r) + integer, intent(in), optional :: j + integer :: r, s(2) + ! We used to have NULL dereference here, in case of a missing J argument + s = foo(j, [3, 7]) + r = sum(s) + end function bar + elemental function first(i, j) result(r) + integer, intent(in), optional :: i + integer, intent(in) :: j + integer :: r + if (present(i)) then + r = i + else + r = -5 + end if + end function first +end module m +program p + use m + integer :: i + i = bar() + if (i /= -10) STOP 1 +end program p diff --git a/Fortran/gfortran/regression/generic_32.f90 b/Fortran/gfortran/regression/generic_32.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_32.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! +! PR 45521: [F08] GENERIC resolution with ALLOCATABLE/POINTER and PROCEDURE +! +! Contributed by Janus Weil + + + INTERFACE gen + SUBROUTINE suba(a) ! { dg-error "Ambiguous interfaces" } + REAL,ALLOCATABLE :: a(:) + END SUBROUTINE + SUBROUTINE subp(p) ! { dg-error "Ambiguous interfaces" } + REAL,POINTER,INTENT(IN) :: p(:) + END SUBROUTINE + END INTERFACE +end diff --git a/Fortran/gfortran/regression/generic_33.f90 b/Fortran/gfortran/regression/generic_33.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_33.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! PR 45521: [F08] GENERIC resolution with ALLOCATABLE/POINTER and PROCEDURE +! +! Contributed by Janus Weil + + type :: t + end type + + interface test + procedure testAlloc + procedure testPtr + end interface + +contains + + logical function testAlloc(obj) + class(t), allocatable :: obj + testAlloc = .true. + end function + + logical function testPtr(obj) + class(t), pointer :: obj + testPtr = .false. + end function + +end diff --git a/Fortran/gfortran/regression/generic_34.f90 b/Fortran/gfortran/regression/generic_34.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_34.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! PR 86116: [6/7/8/9 Regression] Ambiguous generic interface not recognised +! +! Contributed by martin + +module mod + + type :: t + end type t + + interface sub + module procedure s1 + module procedure s2 + end interface + +contains + + subroutine s1(x) ! { dg-error "Ambiguous interfaces in generic interface" } + type(t) :: x + end subroutine + + subroutine s2(x) ! { dg-error "Ambiguous interfaces in generic interface" } + class(*), allocatable :: x + end subroutine + +end diff --git a/Fortran/gfortran/regression/generic_35.f90 b/Fortran/gfortran/regression/generic_35.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_35.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! +! PR 86545: ICE in transfer_expr on invalid WRITE statement +! +! Contributed by Janus Weil + +module m + + type tString + character(len=:), allocatable :: cs + end type + + interface my_trim + module procedure trim_string + end interface + +contains + + elemental function trim_string(self) result(str) + type(tString) :: str + class(tString), intent(in) :: self + end function + +end module + + +program p + use m + type(tString) :: s + write(*,*) my_trim(s) ! { dg-error "cannot have ALLOCATABLE components" } +end diff --git a/Fortran/gfortran/regression/generic_4.f90 b/Fortran/gfortran/regression/generic_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_4.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! reduced testcase from PR 17740 +module FOO + + interface BAR + module procedure BAR2 + end interface + +contains + + elemental integer function BAR2(X) + integer, intent(in) :: X + BAR2 = X + end function + + subroutine BAZ(y,z) + integer :: Y(3), Z(3) + Z = BAR(Y) + end subroutine + +end module + +use foo +integer :: y(3), z(3) +y = (/1,2,3/) +call baz(y,z) +if (any (y /= z)) STOP 1 +end diff --git a/Fortran/gfortran/regression/generic_5.f90 b/Fortran/gfortran/regression/generic_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_5.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! Tests the patch for PR28201, in which the call to ice would cause an ICE +! because resolve.c(resolve_generic_s) would try to look in the parent +! namespace to see if the subroutine was part of a legal generic interface. +! In this case, there is nothing to test, hence the ICE. +! +! Contributed by Daniel Franke +! +! +MODULE ice_gfortran + INTERFACE ice + MODULE PROCEDURE ice_i + END INTERFACE + +CONTAINS + SUBROUTINE ice_i(i) + INTEGER, INTENT(IN) :: i + ! do nothing + END SUBROUTINE +END MODULE + +MODULE provoke_ice +CONTAINS + SUBROUTINE provoke + USE ice_gfortran + CALL ice(23.0) ! { dg-error "no specific subroutine" } + END SUBROUTINE +END MODULE diff --git a/Fortran/gfortran/regression/generic_6.f90 b/Fortran/gfortran/regression/generic_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_6.f90 @@ -0,0 +1,48 @@ +! { dg-do compile } +! Tests the patch for PR28873, in which the call create () would cause an +! error because resolve.c(resolve_generic_s) was failing to look in the +! parent namespace for a matching specific subroutine. This, in fact, was +! a regression due to the fix for PR28201. +! +! Contributed by Drew McCormack +! +module A + private + interface create + module procedure create1 + end interface + public :: create +contains + subroutine create1 + print *, "module A" + end subroutine +end module + +module B + private + interface create + module procedure create1 + end interface + public :: create +contains + subroutine create1(a) + integer a + print *, "module B" + end subroutine +end module + +module C + use A + private + public useCreate +contains + subroutine useCreate + use B + call create() + call create(1) + end subroutine +end module + + use c + call useCreate +end diff --git a/Fortran/gfortran/regression/generic_7.f90 b/Fortran/gfortran/regression/generic_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_7.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! Tests the fix for PR29652, in which ambiguous interfaces were not detected +! with more than two specific procedures in the interface. +! +! Contributed by Daniel Franke +! +MODULE global +INTERFACE iface + MODULE PROCEDURE sub_a + MODULE PROCEDURE sub_b + MODULE PROCEDURE sub_c +END INTERFACE +CONTAINS + SUBROUTINE sub_a(x) ! { dg-error "Ambiguous interfaces" } + INTEGER, INTENT(in) :: x + WRITE (*,*) 'A: ', x + END SUBROUTINE + SUBROUTINE sub_b(y) ! { dg-error "Ambiguous interfaces" } + INTEGER, INTENT(in) :: y + WRITE (*,*) 'B: ', y + END SUBROUTINE + SUBROUTINE sub_c(x, y) + REAL, INTENT(in) :: x, y + WRITE(*,*) x, y + END SUBROUTINE +END MODULE diff --git a/Fortran/gfortran/regression/generic_8.f90 b/Fortran/gfortran/regression/generic_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_8.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! Tests the fix for PR29837, in which the following valid code +! would emit an error because of mistaken INTENT; the wrong +! specific interface would be used for the comparison. +! +! Contributed by +! +MODULE M + IMPLICIT NONE + INTERFACE A + MODULE PROCEDURE A1,A2 + END INTERFACE +CONTAINS + + SUBROUTINE A2(X) + INTEGER, INTENT(INOUT) :: X + END SUBROUTINE A2 + + SUBROUTINE A1(X,Y) + INTEGER, INTENT(IN) :: X + INTEGER, INTENT(OUT) :: Y + Y=X + END SUBROUTINE A1 + + SUBROUTINE T(X) + INTEGER, INTENT(IN) :: X(:) + INTEGER Y + CALL A(MAXVAL(X),Y) + END SUBROUTINE T +END MODULE M diff --git a/Fortran/gfortran/regression/generic_9.f90 b/Fortran/gfortran/regression/generic_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_9.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! Test the patch for PR29992. The standard requires that a +! module procedure be contained in the same scope as the +! interface or is use associated to it(12.3.2.1). +! +! Contributed by Daniel Franke +! +MODULE class_foo_type + TYPE :: foo + INTEGER :: dummy + END TYPE +contains + SUBROUTINE bar_init_set_int(this, value) + TYPE(foo), INTENT(out) :: this + integer, intent(in) :: value + this%dummy = value + END SUBROUTINE +END MODULE + +MODULE class_foo +USE class_foo_type, ONLY: foo, bar_init_set_int + +INTERFACE foo_init + MODULE PROCEDURE foo_init_default ! { dg-error "is not a module procedure" } +END INTERFACE + +INTERFACE bar_init + MODULE PROCEDURE bar_init_default, bar_init_set_int ! These are OK +END INTERFACE + +INTERFACE + SUBROUTINE foo_init_default(this) + USE class_foo_type, ONLY: foo + TYPE(foo), INTENT(out) :: this + END SUBROUTINE +END INTERFACE + +contains + SUBROUTINE bar_init_default(this) + TYPE(foo), INTENT(out) :: this + this%dummy = 42 + END SUBROUTINE + +END MODULE diff --git a/Fortran/gfortran/regression/generic_actual_arg.f90 b/Fortran/gfortran/regression/generic_actual_arg.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_actual_arg.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! Tests fix for PR20886 in which the passing of a generic procedure as +! an actual argument was not detected. +! +! The second module and the check that CALCULATION2 is a good actual +! argument was added following the fix for PR26374. +! +! Contributed by Joost VandeVondele +! +MODULE TEST +INTERFACE CALCULATION + MODULE PROCEDURE C1, C2 +END INTERFACE +CONTAINS +SUBROUTINE C1(r) + INTEGER :: r +END SUBROUTINE +SUBROUTINE C2(r) + REAL :: r +END SUBROUTINE +END MODULE TEST + +MODULE TEST2 +INTERFACE CALCULATION2 + MODULE PROCEDURE CALCULATION2, C3 +END INTERFACE +CONTAINS +SUBROUTINE CALCULATION2(r) + INTEGER :: r +END SUBROUTINE +SUBROUTINE C3(r) + REAL :: r +END SUBROUTINE +END MODULE TEST2 + +USE TEST +USE TEST2 +CALL F(CALCULATION) ! { dg-error "GENERIC procedure" } + +CALL F(CALCULATION2) ! OK because there is a same name specific, but: ! { dg-error "More actual than formal arguments" } +END + +SUBROUTINE F() +END SUBROUTINE diff --git a/Fortran/gfortran/regression/generic_typebound_operator_1.f90 b/Fortran/gfortran/regression/generic_typebound_operator_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/generic_typebound_operator_1.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! PR fortran/45916 +! ICE with generic type-bound operator + +module m_sort + implicit none + type, abstract :: sort_t + contains + generic :: operator(.gt.) => gt_cmp + procedure(gt_cmp), deferred :: gt_cmp + end type sort_t + interface + logical function gt_cmp(a,b) + import + class(sort_t), intent(in) :: a, b + end function gt_cmp + end interface +end module m_sort diff --git a/Fortran/gfortran/regression/getenv_1.f90 b/Fortran/gfortran/regression/getenv_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/getenv_1.f90 @@ -0,0 +1,12 @@ +! { dg-do run } +! Test the getenv and get_environment_variable intrinsics. +! Ignore the return value because it's not supported/meaningful on all targets +program getenv_1 + implicit none + character(len=101) :: var + character(len=*), parameter :: home = 'HOME' + integer :: len, stat + call getenv(name=home, value=var) + call get_environment_variable(name=home, value=var, & + length=len, status=stat) +end program getenv_1 diff --git a/Fortran/gfortran/regression/global_references_1.f90 b/Fortran/gfortran/regression/global_references_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/global_references_1.f90 @@ -0,0 +1,98 @@ +! { dg-do compile } +! This program tests the patch for PRs 20881, 23308, 25538 & 25710 +! Assembled from PRs by Paul Thomas +module m +contains + subroutine g(x) ! Local entity + REAL :: x + x = 1.0 + end subroutine g +end module m +! Error only appears once but testsuite associates with both lines. +function f(x) ! { dg-error "is already being used as a FUNCTION" } + REAL :: f, x + f = x +end function f + +function g(x) ! Global entity + REAL :: g, x + g = x + +! PR25710========================================================== +! Lahey -2607-S: "SOURCE.F90", line 26: +! Function 'f' cannot be referenced as a subroutine. The previous +! definition is in 'line 12'. + + call f(g) ! { dg-error "is already being used as a FUNCTION|Interface mismatch in global procedure" } +end function g +! Error only appears once but testsuite associates with both lines. +function h(x) ! { dg-error "is already being used as a FUNCTION" } + REAL :: h, x + h = x +end function h + +SUBROUTINE TT() + CHARACTER(LEN=10), EXTERNAL :: j ! { dg-error "Return type mismatch" } + CHARACTER(LEN=10) :: T +! PR20881=========================================================== +! Error only appears once but testsuite associates with both lines. + T = j (1.0) ! { dg-error "is already being used as a SUBROUTINE" } + print *, T +END SUBROUTINE TT + + use m ! Main program + real x + integer a(10) + +! PR23308=========================================================== +! Lahey - 2604-S: "SOURCE.F90", line 52: +! The name 'foo' cannot be specified as both external procedure name +! and common block name. The previous appearance is in 'line 68'. +! Error only appears once but testsuite associates with both lines. + common /foo/ a ! { dg-error "is already being used as a COMMON" } + + call f (x) ! OK - reference to local entity + call g (x) ! -ditto- + +! PR25710=========================================================== +! Lahey - 2607-S: "SOURCE.F90", line 62: +! Function 'h' cannot be referenced as a subroutine. The previous +! definition is in 'line 29'. + + call h (x) ! { dg-error "is already being used as a FUNCTION|Interface mismatch in global procedure" } + +! PR23308=========================================================== +! Lahey - 2521-S: "SOURCE.F90", line 68: Intrinsic procedure name or +! external procedure name same as common block name 'foo'. + + call foo () ! { dg-error "is already being used as a COMMON" } + +contains + SUBROUTINE f (x) ! Local entity + real x + x = 2 + end SUBROUTINE f +end + +! PR20881=========================================================== +! Lahey - 2636-S: "SOURCE.F90", line 81: +! Subroutine 'j' is previously referenced as a function in 'line 39'. + +SUBROUTINE j (x) ! { dg-error "is already being used as a SUBROUTINE" } + integer a(10) + common /bar/ a ! Global entity foo + real x + x = bar(1.0) ! OK for local procedure to have common block name +contains + function bar (x) + real bar, x + bar = 2.0*x + end function bar +END SUBROUTINE j + +! PR25538=========================================================== +! would ICE with entry and procedure having same names. + subroutine link2 (namef) ! { dg-error "is already being used as a SUBROUTINE" } + entry link2 (nameg) ! { dg-error "is already being used as a SUBROUTINE" } + return + end diff --git a/Fortran/gfortran/regression/global_references_2.f90 b/Fortran/gfortran/regression/global_references_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/global_references_2.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! +! This program tests the patch for PR25964. This is a +! regression that would not allow a common block and a statement +! to share the same name. +! +! Contributed by Paul Thomas + common /foo/ a, b, c + foo (x) = x + 1.0 + print *, foo (0.0) + end + diff --git a/Fortran/gfortran/regression/global_vars_c_init.f90 b/Fortran/gfortran/regression/global_vars_c_init.f90 --- /dev/null +++ b/Fortran/gfortran/regression/global_vars_c_init.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-additional-sources global_vars_c_init_driver.c } +module global_vars_c_init + use, intrinsic :: iso_c_binding, only: c_int + implicit none + + integer(c_int), bind(c, name='i') :: I + +contains + subroutine test_globals() bind(c) + ! the value of I is initialized above + if(I .ne. 2) then + STOP 1 + endif + end subroutine test_globals +end module global_vars_c_init diff --git a/Fortran/gfortran/regression/global_vars_c_init_driver.c b/Fortran/gfortran/regression/global_vars_c_init_driver.c --- /dev/null +++ b/Fortran/gfortran/regression/global_vars_c_init_driver.c @@ -0,0 +1,13 @@ +int i = 2; +void test_globals(void); + +extern void abort(void); + +int main(int argc, char **argv) +{ + /* verify that i has been initialized by f90 */ + if(i != 2) + abort(); + test_globals(); + return 0; +}/* end main() */ diff --git a/Fortran/gfortran/regression/global_vars_f90_init.f90 b/Fortran/gfortran/regression/global_vars_f90_init.f90 --- /dev/null +++ b/Fortran/gfortran/regression/global_vars_f90_init.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-additional-sources global_vars_f90_init_driver.c } +module global_vars_f90_init + use, intrinsic :: iso_c_binding, only: c_int + implicit none + + integer(c_int), bind(c, name='i') :: I = 2 + +contains + subroutine test_globals() bind(c) + ! the value of I is initialized above + if(I .ne. 2) then + STOP 1 + endif + end subroutine test_globals +end module global_vars_f90_init diff --git a/Fortran/gfortran/regression/global_vars_f90_init_driver.c b/Fortran/gfortran/regression/global_vars_f90_init_driver.c --- /dev/null +++ b/Fortran/gfortran/regression/global_vars_f90_init_driver.c @@ -0,0 +1,14 @@ +/* initialized by fortran */ +extern int i; +void test_globals(void); + +extern void abort(void); + +int main(int argc, char **argv) +{ + /* verify that i has been initialized by f90 */ + if(i != 2) + abort(); + test_globals(); + return 0; +}/* end main() */ diff --git a/Fortran/gfortran/regression/gnu_logical_2.f90 b/Fortran/gfortran/regression/gnu_logical_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/gnu_logical_2.f90 @@ -0,0 +1,29 @@ +! Testcases for the AND, OR and XOR functions (GNU intrinsics). +! { dg-do compile } + integer i + logical l + real r + complex c + + print *, and(i,i) + print *, and(l,l) + print *, and(i,r) ! { dg-error "must be INTEGER, LOGICAL, or a BOZ" } + print *, and(c,l) ! { dg-error "must be INTEGER, LOGICAL, or a BOZ" } + print *, and(i,l) ! { dg-error "must be the same type" } + print *, and(l,i) ! { dg-error "must be the same type" } + + print *, or(i,i) + print *, or(l,l) + print *, or(i,r) ! { dg-error "must be INTEGER, LOGICAL, or a BOZ" } + print *, or(c,l) ! { dg-error "must be INTEGER, LOGICAL, or a BOZ" } + print *, or(i,l) ! { dg-error "must be the same type" } + print *, or(l,i) ! { dg-error "must be the same type" } + + print *, xor(i,i) + print *, xor(l,l) + print *, xor(i,r) ! { dg-error "must be INTEGER, LOGICAL, or a BOZ" } + print *, xor(c,l) ! { dg-error "must be INTEGER, LOGICAL, or a BOZ" } + print *, xor(i,l) ! { dg-error "must be the same type" } + print *, xor(l,i) ! { dg-error "must be the same type" } + + end diff --git a/Fortran/gfortran/regression/goto_1.f b/Fortran/gfortran/regression/goto_1.f --- /dev/null +++ b/Fortran/gfortran/regression/goto_1.f @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! PR 18540 +! Verify that old-style cross-block GOTOs work + I = 1 + GO TO 2 + IF (I .EQ. 0) THEN + 2 IF (I .NE. 1) STOP 1 + I = 0 + GOTO 3 + ELSE + 3 I = 2 + END IF + IF (I .NE. 2) STOP 2 + END diff --git a/Fortran/gfortran/regression/goto_2.f90 b/Fortran/gfortran/regression/goto_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/goto_2.f90 @@ -0,0 +1,59 @@ +! { dg-do run } +! Checks for corrects warnings if branching to then end of a +! construct at various nesting levels + subroutine check_if(i) + goto 10 ! { dg-warning "Label at ... is not in the same block" } + if (i > 0) goto 40 + if (i < 0) then + goto 40 +10 end if ! { dg-warning "Label at ... is not in the same block" } + if (i == 0) then + i = i+1 + goto 20 + goto 40 +20 end if + if (i == 1) then + i = i+1 + if (i == 2) then + goto 30 + end if + goto 40 +30 end if + return +40 i = -1 + end subroutine check_if + + subroutine check_select(i) + goto 10 ! { dg-warning "Label at ... is not in the same block" } + select case (i) + case default + goto 999 +10 end select ! { dg-warning "Label at ... is not in the same block" } + select case (i) + case (2) + i = 1 + goto 20 + goto 999 + case default + goto 999 +20 end select + j = i + select case (j) + case default + select case (i) + case (1) + i = 2 + goto 30 + end select + goto 999 +30 end select + return +999 i = -1 + end subroutine check_select + + i = 0 + call check_if (i) + if (i /= 2) STOP 1 + call check_select (i) + if (i /= 2) STOP 2 +end diff --git a/Fortran/gfortran/regression/goto_3.f90 b/Fortran/gfortran/regression/goto_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/goto_3.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! Verify that various cases of invalid branches are rejected + dimension a(10) + if (i>0) then + goto 10 ! { dg-error "not a valid branch target statement" } +10 else ! { dg-error "not a valid branch target statement" } + i = -i + end if + + goto 20 ! { dg-error "not a valid branch target statement" } + forall (i=1:10) + a(i) = 2*i +20 end forall ! { dg-error "not a valid branch target statement" } + + goto 30 ! { dg-error "not a valid branch target statement" } + goto 40 ! { dg-error "not a valid branch target statement" } + where (a>0) + a = 2*a +30 elsewhere ! { dg-error "not a valid branch target statement" } + a = a/2 +40 end where ! { dg-error "not a valid branch target statement" } + end + diff --git a/Fortran/gfortran/regression/goto_4.f90 b/Fortran/gfortran/regression/goto_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/goto_4.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! PR 17708: Jumping to END DO statements didn't do the right thing +! PR 38507: The warning we used to give was wrong + program test + j = 0 + do 10 i=1,3 + if(i == 2) goto 10 + j = j+1 +10 enddo + if (j/=2) STOP 1 + end diff --git a/Fortran/gfortran/regression/goto_5.f90 b/Fortran/gfortran/regression/goto_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/goto_5.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! PR 38507 +! Verify that we correctly flag invalid gotos, while not flagging valid gotos. +integer i,j + +do i=1,10 + goto 20 +20 end do ! { dg-warning "is not in the same block" } + +goto 20 ! { dg-warning "is not in the same block" } +goto 25 ! { dg-warning "is not in the same block" } +goto 40 ! { dg-warning "is not in the same block" } +goto 50 ! { dg-warning "is not in the same block" } + +goto 222 +goto 333 +goto 444 + +222 if (i < 0) then +25 end if ! { dg-warning "is not in the same block" } + +333 if (i > 0) then + do j = 1,20 + goto 30 + end do +else if (i == 0) then + goto 30 +else + goto 30 +30 end if + +444 select case(i) +case(0) + goto 50 + goto 60 ! { dg-warning "is not in the same block" } +case(1) + goto 40 + goto 50 + 40 continue ! { dg-warning "is not in the same block" } + 60 continue ! { dg-warning "is not in the same block" } +50 end select ! { dg-warning "is not in the same block" } +continue + +end diff --git a/Fortran/gfortran/regression/goto_6.f b/Fortran/gfortran/regression/goto_6.f --- /dev/null +++ b/Fortran/gfortran/regression/goto_6.f @@ -0,0 +1,24 @@ +! { dg-do run } +! { dg-options "-w" } + +! PR fortran/41403 +! Assigned-goto with label list used to compare label addresses which +! failed with optimization. Check this works correctly now. +! This is the most reduced Fortran code from the PR. + + IVFAIL=0 + ASSIGN 1263 TO I + GO TO I, (1262,1263,1264) + 1262 ICON01 = 1262 + GO TO 1265 + 1263 ICON01 = 1263 + GO TO 1265 + 1264 ICON01 = 1264 + 1265 CONTINUE +41260 IF ( ICON01 - 1263 ) 21260, 11260, 21260 +11260 IVPASS = IVPASS + 1 + GO TO 1271 +21260 IVFAIL = IVFAIL + 1 + 1271 CONTINUE + IF (IVFAIL /= 0) STOP 1 + END diff --git a/Fortran/gfortran/regression/goto_7.f b/Fortran/gfortran/regression/goto_7.f --- /dev/null +++ b/Fortran/gfortran/regression/goto_7.f @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } + +! Check for error message when computed and assigned gotos reference +! illegal label numbers. + + ASSIGN 1 TO I + GOTO (1, 2, 3, 42), 2 ! { dg-error "is never defined" } + GOTO I, (1, 2, 3, 43) ! { dg-error "is never defined" } + 1 CONTINUE + 2 CONTINUE + 3 CONTINUE +c No label 42 or 43. + END diff --git a/Fortran/gfortran/regression/goto_8.f90 b/Fortran/gfortran/regression/goto_8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/goto_8.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! +! PR 41781: [OOP] bogus undefined label error with SELECT TYPE. +! +! Contributed by Salvatore Filippone +! and Tobias Burnus >burnus@gcc.gnu.org> + +! 1st example: jumping out of SELECT TYPE (valid) +type bar + integer :: i +end type bar +class(bar), pointer :: var +select type(var) +class default + goto 9999 +end select +9999 continue + +! 2nd example: jumping out of BLOCK (valid) +block + goto 88 +end block +88 continue + +! 3rd example: jumping into BLOCK (invalid) +goto 99 ! { dg-warning "is not in the same block" } +block + 99 continue ! { dg-warning "is not in the same block" } +end block + +end diff --git a/Fortran/gfortran/regression/goto_9.f90 b/Fortran/gfortran/regression/goto_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/goto_9.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-std=legacy" } +! PR fortran/102113 - parsing error in assigned goto + +program p + assign 10 to i + goto i,(10,20 ) +10 continue +20 continue +end diff --git a/Fortran/gfortran/regression/hollerith.f90 b/Fortran/gfortran/regression/hollerith.f90 --- /dev/null +++ b/Fortran/gfortran/regression/hollerith.f90 @@ -0,0 +1,102 @@ +! { dg-do run } +! PR15966, PR18781 & PR16531 +implicit none +complex(kind=8) x(2) +complex a(2,2) +character(4) z +character z1(4) +character(4) z2(2,2) +character(80) line +integer i +integer j +real 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 +j = 4Ho wo +r = 4Hrld! +write (line, '(3A4)') i, j, r +if (line .ne. 'Hello world!') STOP 1 +i = 2Hab +j = 2Hab +r = 2Hab +c = 2Hab +write (line, '(3A4, 8A)') i, j, r, c +if (line .ne. 'ab ab ab ab ') STOP 2 + +write(line, '(4A8, "!")' ) x +if (line .ne. 'abcdefghijklmnopqrstuvwxyz012345!') STOP 3 + +write (line, a) 3 +if (line .ne. ' 3') STOP 4 +write (line, a (1,2)) 4 +if (line .ne. ' 4') STOP 5 +write (line, z) 5 +if (line .ne. ' 5') STOP 6 +write (line, z1) 6 +if (line .ne. ' 6') STOP 7 +write (line, z2) 7 +if (line .ne. ' 7') STOP 8 +write (line, z2 (1,2)) 8 +if (line .ne. ' 8') STOP 9 +write (line, '(16A)') z2 +if (line .ne. '(i7)xxxx(i8)xxxx') STOP 10 +call test (8h hello) +end + +subroutine test (h) +integer(kind=8) h +character(80) line + +write (line, '(8a)') h +if (line .ne. ' hello') STOP 11 +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 "Hollerith constant" "" { target *-*-* } 51 } diff --git a/Fortran/gfortran/regression/hollerith2.f90 b/Fortran/gfortran/regression/hollerith2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/hollerith2.f90 @@ -0,0 +1,26 @@ + ! { dg-do run } + ! Program to test Hollerith constant. + Program test + implicit none + integer 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/Fortran/gfortran/regression/hollerith3.f90 b/Fortran/gfortran/regression/hollerith3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/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/Fortran/gfortran/regression/hollerith4.f90 b/Fortran/gfortran/regression/hollerith4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/hollerith4.f90 @@ -0,0 +1,38 @@ +! { dg-do run } +! Test Hollerith constants assigned to allocatable array +! and used in I/O list. + +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)") STOP 1 +write (ch, c) 'Hello' +if (ch .ne. "Hell") STOP 2 +write (ch, c (1,2)) 'Hello' +if (ch .ne. "Hello") STOP 3 + +write (ch, *) 5Hhello +if (ch .ne. " hello") STOP 4 +write (ch, "(A5)") 5Hhello +if (ch .ne. "hello") STOP 5 + +end + +! { dg-warning "Hollerith constant" "const" { target *-*-* } 9 } +! { dg-warning "Conversion" "conversion" { target *-*-* } 9 } + +! { dg-warning "Hollerith constant" "const" { target *-*-* } 10 } +! { dg-warning "Conversion" "conversion" { target *-*-* } 10 } + +! { dg-warning "Non-character in FORMAT tag" "" { target *-*-* } 14 } + +! { dg-warning "Non-character in FORMAT tag" "" { target *-*-* } 16 } + +! { dg-warning "Hollerith constant" "const" { target *-*-* } 19 } +! { dg-warning "Hollerith constant" "const" { target *-*-* } 21 } + diff --git a/Fortran/gfortran/regression/hollerith5.f90 b/Fortran/gfortran/regression/hollerith5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/hollerith5.f90 @@ -0,0 +1,9 @@ + ! { dg-do compile } + ! { dg-options "-Wsurprising" } + implicit none + logical b + b = 4Habcd ! { dg-warning "has undefined result" } + end + +! { dg-warning "Hollerith constant" "const" { target *-*-* } 5 } +! { dg-warning "Conversion" "conversion" { target *-*-* } 5 } diff --git a/Fortran/gfortran/regression/hollerith6.f90 b/Fortran/gfortran/regression/hollerith6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/hollerith6.f90 @@ -0,0 +1,35 @@ +! PR fortran/39865 +! { dg-do run } + +subroutine foo (a) + integer(kind=4) :: a(1, 3) + character(len=40) :: t + write (t, fmt=a(1,2)) 1, 2, 3, 4, 5, 6, 7, 8 + if (t .ne. ' 1 2 3 4 5 6 7 8') STOP 1 +end subroutine foo + interface + subroutine foo (a) + integer(kind=4) :: a(1, 3) + end subroutine foo + end interface + integer(kind=4) :: b(1,3) + character(len=40) :: t + b(1,1) = 4HXXXX + b(1,2) = 4H (8I + b(1,3) = 2H4) + write (t, fmt=b(1,2)) 1, 2, 3, 4, 5, 6, 7, 8 + if (t .ne. ' 1 2 3 4 5 6 7 8') STOP 2 + call foo (b) +end + +! { dg-warning "Non-character in FORMAT tag" "FMT" { target *-*-* } 7 } +! { dg-warning "Non-character in FORMAT tag" "FMT" { target *-*-* } 20 } + +! { dg-warning "Hollerith constant" "const" { target *-*-* } 17 } +! { dg-warning "Conversion" "conversion" { target *-*-* } 17 } + +! { dg-warning "Hollerith constant" "const" { target *-*-* } 18 } +! { dg-warning "Conversion" "conversion" { target *-*-* } 18 } + +! { dg-warning "Hollerith constant" "const" { target *-*-* } 19 } +! { dg-warning "Conversion" "conversion" { target *-*-* } 19 } diff --git a/Fortran/gfortran/regression/hollerith7.f90 b/Fortran/gfortran/regression/hollerith7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/hollerith7.f90 @@ -0,0 +1,52 @@ +! PR fortran/39865 +! { dg-do compile } + +subroutine foo (a) + integer(kind=4), target :: a(1:, 1:) + integer(kind=4), pointer :: b(:, :) + b => a + write (*, fmt=a(1,2)) 1, 2, 3, 4, 5, 6, 7, 8 + write (*, fmt=b(1,2)) 1, 2, 3, 4, 5, 6, 7, 8 +end subroutine foo +subroutine bar (a, b) + character :: b(2,*) + integer :: a(*) + write (*, fmt=b) 1, 2, 3 + write (*, fmt=a) 1, 2, 3 + write (*, fmt=a(2)) 1, 2, 3 +end subroutine + interface + subroutine foo (a) + integer(kind=4), target :: a(:, :) + end subroutine foo + end interface + integer(kind=4) :: a(2, 3) + a = 4HXXXX + a(2,2) = 4H (8I + a(1,3) = 2H4) + a(2,3) = 1H + call foo (a(2:2,:)) +end + +! { dg-warning "Non-character in FORMAT tag" "FMT" { target *-*-* } 8 } +! { dg-error "Non-character assumed shape array element in FORMAT tag" "element" { target *-*-* } 8 } + +! { dg-warning "Non-character in FORMAT tag" "FMT" { target *-*-* } 9 } +! { dg-error "Non-character pointer array element in FORMAT tag" "element" { target *-*-* } 9 } + +! { dg-error "reference to the assumed size array" "assumed-size" { target *-*-* } 14 } +! { dg-error "reference to the assumed size array" "assumed-size" { target *-*-* } 15 } +! { dg-warning "Non-character in FORMAT tag" "FMT" { target *-*-* } 16 } +! { dg-error "Non-character assumed size array element in FORMAT tag" "element" { target *-*-* } 16 } + +! { dg-warning "Hollerith constant" "const" { target *-*-* } 24 } +! { dg-warning "Conversion" "conversion" { target *-*-* } 24 } + +! { dg-warning "Hollerith constant" "const" { target *-*-* } 25 } +! { dg-warning "Conversion" "conversion" { target *-*-* } 25 } + +! { dg-warning "Hollerith constant" "const" { target *-*-* } 26 } +! { dg-warning "Conversion" "conversion" { target *-*-* } 26 } + +! { dg-warning "Hollerith constant" "const" { target *-*-* } 27 } +! { dg-warning "Conversion" "conversion" { target *-*-* } 27 } diff --git a/Fortran/gfortran/regression/hollerith8.f90 b/Fortran/gfortran/regression/hollerith8.f90 --- /dev/null +++ b/Fortran/gfortran/regression/hollerith8.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! PR43217 Output of Hollerith constants which are not a multiple of 4 bytes +! Test case prepared from OP by Jerry DeLisle +program hello2 + call wrtout (9hHELLO YOU, 9) ! { dg-warning "Rank mismatch" } + stop +end + +subroutine wrtout (iarray, nchrs) + integer iarray(1) + integer nchrs + + integer icpw + data icpw/4/ + integer i, nwrds + character(len=33) outstr + + nwrds = (nchrs + icpw - 1) /icpw + write(outstr,'(4(z8," "))') (iarray(i), i=1,nwrds) + if (outstr.ne."4C4C4548 4F59204F 20202055" .and. & + & outstr.ne."48454C4C 4F20594F 55202020") STOP 1 + return +end diff --git a/Fortran/gfortran/regression/hollerith_1.f90 b/Fortran/gfortran/regression/hollerith_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/hollerith_1.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! { dg-options "-std=legacy" } +! +! PR 21260 +! We wrongly interpreted the '!' as the beginning of a comment. +! Also verifies the functioning of hollerith formatting. + character*72 c + write(c,8000) +8000 format(36(2H!))) + do i = 1,72,2 + if (c(i:i+1) /= '!)') STOP 1 + end do + end diff --git a/Fortran/gfortran/regression/hollerith_9.f90 b/Fortran/gfortran/regression/hollerith_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/hollerith_9.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +! PR 91800 - this used to cause an ICE. +module m + type t(n) ! { dg-error "does not have a component corresponding to parameter" } + integer, len :: n = 4habcd ! { dg-error "Initialization of structure component with a HOLLERITH constant" } + end type +end diff --git a/Fortran/gfortran/regression/hollerith_character_array_constructor.f90 b/Fortran/gfortran/regression/hollerith_character_array_constructor.f90 --- /dev/null +++ b/Fortran/gfortran/regression/hollerith_character_array_constructor.f90 @@ -0,0 +1,11 @@ +! { dg-do run } +! { dg-options "-w" } +! PR fortran/82884 +! Original code contributed by Gerhard Steinmetz +program p + character :: c(4) = [1h(, 1hi, 1h4, 1h)] + if (c(1) /= '(') STOP 1 + if (c(2) /= 'i') STOP 2 + if (c(3) /= '4') STOP 3 + if (c(4) /= ')') STOP 4 +end diff --git a/Fortran/gfortran/regression/hollerith_f95.f90 b/Fortran/gfortran/regression/hollerith_f95.f90 --- /dev/null +++ b/Fortran/gfortran/regression/hollerith_f95.f90 @@ -0,0 +1,93 @@ +! { dg-do compile } +! { dg-options " -std=f95" } +! PR15966, PR18781 & PR16531 +implicit none +complex(kind=8) x(2) +complex a(2,2) +character(4) z +character z1(4) +character(4) z2(2,2) +character(80) line +integer i +logical l +real 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!') STOP 1 +i = 2Hab +r = 2Hab +l = 2Hab +c = 2Hab +write (line, '(3A4, 8A)') i, l, r, c +if (line .ne. 'ab ab ab ab ') STOP 2 + +write(line, '(4A8, "!")' ) x +if (line .ne. 'abcdefghijklmnopqrstuvwxyz012345!') STOP 3 + +write (line, a) 3 +if (line .ne. ' 3') STOP 4 +write (line, a (1,2)) 4 +if (line .ne. ' 4') STOP 5 +write (line, z) 5 +if (line .ne. ' 5') STOP 6 +write (line, z1) 6 +if (line .ne. ' 6') STOP 7 +write (line, z2) 7 +if (line .ne. ' 7') STOP 8 +write (line, z2 (1,2)) 8 +if (line .ne. ' 8') STOP 9 +write (line, '(16A)') z2 +if (line .ne. '(i7)xxxx(i8)xxxx') STOP 10 +call test (8h hello) +end + +subroutine test (h) +integer(kind=8) h +character(80) line + +write (line, '(8a)') h +if (line .ne. ' hello') STOP 11 +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 } diff --git a/Fortran/gfortran/regression/hollerith_legacy.f90 b/Fortran/gfortran/regression/hollerith_legacy.f90 --- /dev/null +++ b/Fortran/gfortran/regression/hollerith_legacy.f90 @@ -0,0 +1,61 @@ +! { dg-do compile } +! { dg-options "-std=legacy -Wsurprising" } +! PR15966, PR18781 & PR16531 +implicit none +complex(kind=8) x(2) +complex a(2,2) +character*4 z +character z1(4) +character*4 z2(2,2) +character*80 line +integer i +logical l +real 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 ! { dg-warning "has undefined result" } +r = 4Hrld! +write (line, '(3A4)') i, l, r +if (line .ne. 'Hello world!') STOP 1 +i = 2Hab +r = 2Hab +l = 2Hab ! { dg-warning "has undefined result" } +c = 2Hab +write (line, '(3A4, 8A)') i, l, r, c +if (line .ne. 'ab ab ab ab ') STOP 2 + +write(line, '(4A8, "!")' ) x +if (line .ne. 'abcdefghijklmnopqrstuvwxyz012345!') STOP 3 + +write (line, a) 3 +if (line .ne. ' 3') STOP 4 +write (line, a (1,2)) 4 +if (line .ne. ' 4') STOP 5 +write (line, z) 5 +if (line .ne. ' 5') STOP 6 +write (line, z1) 6 +if (line .ne. ' 6') STOP 7 +write (line, z2) 7 +if (line .ne. ' 7') STOP 8 +write (line, z2 (1,2)) 8 +if (line .ne. ' 8') STOP 9 +write (line, '(16A)') z2 +if (line .ne. '(i7)xxxx(i8)xxxx') STOP 10 +call test (8h hello) +end + +subroutine test (h) +integer(kind=8) h +character*80 line + +write (line, '(8a)') h +if (line .ne. ' hello') STOP 11 +end subroutine diff --git a/Fortran/gfortran/regression/hollerith_to_char_parameter_1.f90 b/Fortran/gfortran/regression/hollerith_to_char_parameter_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/hollerith_to_char_parameter_1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-Wconversion -std=legacy" } +! +! Test case contributed by Mark Eggleston + +program test + character(*), parameter :: h = 5hABCDE ! { dg-warning "HOLLERITH to CHARACTER\\(\\*\\)" } + + write(*,*) h +end program + diff --git a/Fortran/gfortran/regression/hollerith_to_char_parameter_2.f90 b/Fortran/gfortran/regression/hollerith_to_char_parameter_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/hollerith_to_char_parameter_2.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! +! Test case contributed by Mark Eggleston + +program test + character(*), parameter :: h = 5hABCDE ! { dg-warning "HOLLERITH to CHARACTER\\(\\*\\)" } + + write(*,*) h +end program + +! { dg-warning "Legacy Extension" "extension" { target \*-\*-\* } 6 } + diff --git a/Fortran/gfortran/regression/host_assoc_blockdata_1.f90 b/Fortran/gfortran/regression/host_assoc_blockdata_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/host_assoc_blockdata_1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR 38672 - this used to ICE. +MODULE globals + TYPE :: type1 + integer :: x + END TYPE type1 + TYPE (type1) :: pdm_bps +END module globals +BLOCK DATA + use globals +END BLOCK DATA diff --git a/Fortran/gfortran/regression/host_assoc_blockdata_2.f90 b/Fortran/gfortran/regression/host_assoc_blockdata_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/host_assoc_blockdata_2.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +MODULE globals + TYPE :: type1 + sequence + integer :: x + END TYPE type1 + TYPE (type1) :: pdm_bps + common /co/ pdm_bps +END module globals +BLOCK DATA + use globals +END BLOCK DATA + +program main + use globals + common /co/ pdm_bps ! { dg-error "already in a COMMON block" } +end program main diff --git a/Fortran/gfortran/regression/host_assoc_call_1.f90 b/Fortran/gfortran/regression/host_assoc_call_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/host_assoc_call_1.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! Tests the fix for PR31494, where the call of sub2 would reference +! the variable, rather than the contained subroutine. +! +! Contributed by Michael Richmond +! +MODULE ksbin2_aux_mod +REAL, DIMENSION(1) :: sub2 +CONTAINS + SUBROUTINE sub1 + CALL sub2 + CONTAINS + SUBROUTINE sub2 + END SUBROUTINE sub2 + END SUBROUTINE sub1 +END MODULE ksbin2_aux_mod diff --git a/Fortran/gfortran/regression/host_assoc_call_2.f90 b/Fortran/gfortran/regression/host_assoc_call_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/host_assoc_call_2.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! Tests the fix for PR36700, in which the call to the function would +! cause an ICE. +! +! Contributed by +! +module Diatoms + implicit none +contains + function InitialDiatomicX () result(v4) ! { dg-error "has a type" } + real(kind = 8), dimension(4) :: v4 + v4 = 1 + end function InitialDiatomicX + subroutine FindDiatomicPeriod + call InitialDiatomicX () ! { dg-error "which is not consistent with the CALL" } + end subroutine FindDiatomicPeriod +end module Diatoms diff --git a/Fortran/gfortran/regression/host_assoc_call_3.f90 b/Fortran/gfortran/regression/host_assoc_call_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/host_assoc_call_3.f90 @@ -0,0 +1,54 @@ +! { dg-do compile } +! +! PR fortran/37445, in which the contained 'putaline' would be +! ignored and no specific interface found in the generic version. +! +! Contributed by Norman S Clerman < clerman@fuse.net> +! +MODULE M1 + INTERFACE putaline + MODULE PROCEDURE S1,S2 + END INTERFACE +CONTAINS + SUBROUTINE S1(I) + i = 3 + END SUBROUTINE + SUBROUTINE S2(F) + f = 4.0 + END SUBROUTINE +END MODULE + +MODULE M2 + USE M1 +CONTAINS + SUBROUTINE S3 + integer :: check = 0 + CALL putaline() + if (check .ne. 1) STOP 1 + CALL putaline("xx") + if (check .ne. 2) STOP 2 +! CALL putaline(1.0) ! => this now causes an error, as it should + CONTAINS + SUBROUTINE putaline(x) + character, optional :: x + if (present(x)) then + check = 2 + else + check = 1 + end if + END SUBROUTINE + END SUBROUTINE + subroutine S4 + integer :: check = 0 + REAL :: rcheck = 0.0 + call putaline(check) + if (check .ne. 3) STOP 3 + call putaline(rcheck) + if (rcheck .ne. 4.0) STOP 4 + end subroutine s4 +END MODULE + + USE M2 + CALL S3 + call S4 +END diff --git a/Fortran/gfortran/regression/host_assoc_call_4.f90 b/Fortran/gfortran/regression/host_assoc_call_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/host_assoc_call_4.f90 @@ -0,0 +1,47 @@ +! { dg-do compile } +! +! PR fortran/37445, in which the first version of the fix regressed on the +! calls to GetBasicElementData; picking up the local GetBasicElementData instead. +! +! Contributed by Norman S Clerman < clerman@fuse.net> +! and reduced by Tobias Burnus +! +MODULE ErrElmnt + IMPLICIT NONE + TYPE :: TErrorElement + integer :: i + end type TErrorElement +contains + subroutine GetBasicData ( AnElement, ProcedureName, ErrorNumber, & + Level, Message, ReturnStat) + type (TErrorElement) :: AnElement + character (*, 1), optional :: & + ProcedureName + integer (4), optional :: ErrorNumber + character (*, 1), optional :: Level + character (*, 1), optional :: Message + integer (4), optional :: ReturnStat + end subroutine GetBasicData +end module ErrElmnt + +MODULE ErrorMod + USE ErrElmnt, only: GetBasicElementData => GetBasicData , TErrorElement + IMPLICIT NONE +contains + subroutine GetBasicData () + integer (4) :: CallingStat, LocalErrorNum + character (20, 1) :: LocalErrorMessage + character (20, 1) :: LocalProcName + character (20, 1) :: Locallevel + type (TErrorElement) :: AnElement + call GetBasicElementData (AnElement, LocalProcName, LocalErrorNum, LocalLevel, LocalErrorMessage, CallingStat) + end subroutine GetBasicData + SUBROUTINE WH_ERR () + integer (4) :: ErrorNumber, CallingStat + character (20, 1) :: ProcedureName + character (20, 1) :: ErrorLevel + character (20, 1) :: ErrorMessage + type (TErrorElement) :: TargetElement + call GetBasicElementData (TargetElement, ProcedureName, ErrorNumber, ErrorLevel, ErrorMessage, CallingStat) + end subroutine WH_ERR +end module ErrorMod diff --git a/Fortran/gfortran/regression/host_assoc_call_5.f90 b/Fortran/gfortran/regression/host_assoc_call_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/host_assoc_call_5.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! Tests the fix for PR37597, where the reference to other_sub would generate +! Error: Symbol 'other_sub' at (1) has no IMPLICIT type. +! +! Contributed by Tobias Burnus +! from a report on clf by Rich Townsend +! +module foo + implicit none +contains + subroutine main_sub () + call internal_sub() + contains + subroutine internal_sub() + call QAG(other_sub) + end subroutine internal_sub + end subroutine main_sub + subroutine other_sub () + end subroutine other_sub +end module foo diff --git a/Fortran/gfortran/regression/host_assoc_call_6.f90 b/Fortran/gfortran/regression/host_assoc_call_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/host_assoc_call_6.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! +! PR fortran/38594, in which the symtree for the first +! 'g' was being attached to the second. This is necessary +! for generic interfaces(eg. hosts_call_3.f90) but makes +! a mess otherwise. +! +! Contributed by Daniel Franke +! +MODULE m +CONTAINS + SUBROUTINE g() + END SUBROUTINE + SUBROUTINE f() + CALL g() + CONTAINS + SUBROUTINE g() + END SUBROUTINE + END SUBROUTINE +END MODULE + + USE m + CALL g() +END diff --git a/Fortran/gfortran/regression/host_assoc_function_1.f90 b/Fortran/gfortran/regression/host_assoc_function_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/host_assoc_function_1.f90 @@ -0,0 +1,42 @@ +! { dg-do run } +! Tests the fix for the bug PR30746, in which the reference to 'x' +! in 'inner' wrongly host-associated with the variable 'x' rather +! than the function. +! +! Testcase is due to Malcolm Cohen, NAG. +! +real function z (i) + integer :: i + z = real (i)**i +end function + +MODULE m + REAL :: x(3) = (/ 1.5, 2.5, 3.5 /) + interface + real function z (i) + integer :: i + end function + end interface +CONTAINS + SUBROUTINE s + if (x(2, 3) .ne. real (2)**3) STOP 1 + if (z(3, 3) .ne. real (3)**3) STOP 2 + CALL inner + CONTAINS + SUBROUTINE inner + i = 7 + if (x(i, 7) .ne. real (7)**7) STOP 3 + if (z(i, 7) .ne. real (7)**7) STOP 4 + END SUBROUTINE + FUNCTION x(n, m) + x = REAL(n)**m + END FUNCTION + FUNCTION z(n, m) + z = REAL(n)**m + END FUNCTION + + END SUBROUTINE +END MODULE + use m + call s() +end diff --git a/Fortran/gfortran/regression/host_assoc_function_2.f90 b/Fortran/gfortran/regression/host_assoc_function_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/host_assoc_function_2.f90 @@ -0,0 +1,47 @@ +! { dg-do compile } +! Tests the fix for PR32464, where the use associated procedure would +! mess up the check for "grandparent" host association. +! +! Contributed by Harald Anlauf +! + +module gfcbug64_mod1 + implicit none + + public :: inverse + + interface inverse + module procedure copy + end interface + +contains + + function copy (d) result (y) + real, intent(in) :: d(:) + real :: y(size (d)) ! <- this version kills gfortran +! real, intent(in) :: d +! real :: y + y = d + end function copy + +end module gfcbug64_mod1 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +module gfcbug64_mod2 + implicit none +contains + + subroutine foo (x_o) + real, intent(in) :: x_o(:) + + integer :: s(size (x_o)) ! <- this line kills gfortran + + contains + + subroutine bar () + use gfcbug64_mod1, only: inverse ! <- this line kills gfortran + end subroutine bar + + end subroutine foo +end module gfcbug64_mod2 diff --git a/Fortran/gfortran/regression/host_assoc_function_3.f90 b/Fortran/gfortran/regression/host_assoc_function_3.f90 --- /dev/null +++ b/Fortran/gfortran/regression/host_assoc_function_3.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! Tests the fix for the bug PR33233, in which the reference to 'x' +! in 'inner' wrongly host-associated with the variable 'x' rather +! than the function. +! +! Contributed by Tobias Burnus +! +MODULE m + REAL :: x(3) = (/ 1.5, 2.5, 3.5 /) +CONTAINS + SUBROUTINE s + if (x(2) .eq. 2.5) STOP 1 + CONTAINS + FUNCTION x(n, m) + integer, optional :: m + if (present(m)) then + x = REAL(n)**m + else + x = 0.0 + end if + END FUNCTION + END SUBROUTINE s +END MODULE m + use m + call s +end diff --git a/Fortran/gfortran/regression/host_assoc_function_4.f90 b/Fortran/gfortran/regression/host_assoc_function_4.f90 --- /dev/null +++ b/Fortran/gfortran/regression/host_assoc_function_4.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! +! PR fortran/37445, in which the contained 's1' would be +! ignored and the use+host associated version used. +! +! Contributed by Norman S Clerman < clerman@fuse.net> +! +MODULE M1 +CONTAINS + integer function S1 () + s1 = 0 + END function +END MODULE + +MODULE M2 + USE M1 +CONTAINS + SUBROUTINE S2 + if (s1 () .ne. 1) STOP 1 + CONTAINS + integer function S1 () + s1 = 1 + END function + END SUBROUTINE +END MODULE + + USE M2 + CALL S2 +END diff --git a/Fortran/gfortran/regression/host_assoc_function_5.f90 b/Fortran/gfortran/regression/host_assoc_function_5.f90 --- /dev/null +++ b/Fortran/gfortran/regression/host_assoc_function_5.f90 @@ -0,0 +1,46 @@ +! { dg-do compile } +! +! PR fortran/38665, in which checking for host association +! was wrongly trying to substitute mod_symmon(mult) with +! mod_sympoly(mult) in the user operator expression on line +! 43. +! +! Contributed by Thomas Koenig +! +module mod_symmon + implicit none + + public :: t_symmon, operator(*) + private + + type t_symmon + integer :: ierr = 0 + end type t_symmon + + interface operator(*) + module procedure mult + end interface + +contains + elemental function mult(m1,m2) result(m) + type(t_symmon), intent(in) :: m1, m2 + type(t_symmon) :: m + end function mult +end module mod_symmon + +module mod_sympoly + use mod_symmon + implicit none + + type t_sympol + type(t_symmon), allocatable :: mons(:) + end type t_sympol +contains + + elemental function mult(p1,p2) result(p) + type(t_sympol), intent(in) :: p1,p2 + type(t_sympol) :: p + type(t_symmon), allocatable :: mons(:) + mons(1) = p1%mons(1)*p2%mons(2) + end function +end module diff --git a/Fortran/gfortran/regression/host_assoc_function_6.f90 b/Fortran/gfortran/regression/host_assoc_function_6.f90 --- /dev/null +++ b/Fortran/gfortran/regression/host_assoc_function_6.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! Tests the fix for PR38765 in which the use associated symbol +! 'fun' was confused with the contained function in 'mod_b' +! because the real name was being used instead of the 'use' +! name.. +! +! Contributed by Paul Thomas +! from a report by Marco Restelli. +! +module mod_a + implicit none + public :: fun + private +contains + pure function fun(x) result(mu) + real, intent(in) :: x(:,:) + real :: mu(2,2,size(x,2)) + mu = 2.0 + end function fun +end module mod_a + +module mod_b + use mod_a, only: & + a_fun => fun + implicit none + private +contains + pure function fun(x) result(mu) + real, intent(in) :: x(:,:) + real :: mu(2,2,size(x,2)) + mu = a_fun(x) + end function fun +end module mod_b diff --git a/Fortran/gfortran/regression/host_assoc_function_7.f90 b/Fortran/gfortran/regression/host_assoc_function_7.f90 --- /dev/null +++ b/Fortran/gfortran/regression/host_assoc_function_7.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! Tests the fix for PR38907, in which any expressions, including unary plus, +! in front of the call to S_REAL_SUM_I (marked) would throw the mechanism +! for correcting invalid host association. +! +! Contributed by Dick Hendrickson +! +module sa0054_stuff + REAL :: S_REAL_SUM_2(10) = [(REAL (I), I = 1, 10)] +contains + ELEMENTAL FUNCTION S_REAL_SUM_I (A) + REAL :: S_REAL_SUM_I + REAL, INTENT(IN) :: A + X = 1.0 + S_REAL_SUM_I = X + END FUNCTION S_REAL_SUM_I + SUBROUTINE SA0054 (RDA) + REAL RDA(:) + RDA = + S_REAL_SUM_I (RDA) ! Reported problem => ICE + RDA = RDA + S_REAL_SUM_2 (INT (RDA)) ! Also failed + CONTAINS + ELEMENTAL FUNCTION S_REAL_SUM_I (A) + REAL :: S_REAL_SUM_I + REAL, INTENT(IN) :: A + S_REAL_SUM_I = 2.0 * A + END FUNCTION S_REAL_SUM_I + ELEMENTAL FUNCTION S_REAL_SUM_2 (A) + REAL :: S_REAL_SUM_2 + INTEGER, INTENT(IN) :: A + S_REAL_SUM_2 = 2.0 * A + END FUNCTION S_REAL_SUM_2 + END SUBROUTINE +end module sa0054_stuff + + use sa0054_stuff + REAL :: RDA(10) = [(REAL(I), I = 1, 10)] + call SA0054 (RDA) + IF (ANY (INT (RDA) .ne. [(6 * I, I = 1, 10)])) print *, rda +END diff --git a/Fortran/gfortran/regression/host_assoc_function_9.f90 b/Fortran/gfortran/regression/host_assoc_function_9.f90 --- /dev/null +++ b/Fortran/gfortran/regression/host_assoc_function_9.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! Tests the fix for the bug PR40629, in which the reference to 'x' +! in 'upper' wrongly host-associated with the symbol 'x' at module +! leve rather than the function. +! +! Contributed by Philippe Marguinaud +! +MODULE m + REAL :: x = 0 +CONTAINS + subroutine s + call upper + call lower + CONTAINS + SUBROUTINE upper + y = x(3,1) + if (int(y) .ne. 3) STOP 1 + END SUBROUTINE + FUNCTION x(n, m) + x = m*n + END FUNCTION + SUBROUTINE lower + y = x(2,1) + if (int(y) .ne. 2) STOP 2 + END SUBROUTINE + END SUBROUTINE +END MODULE + + use m + call s +end diff --git a/Fortran/gfortran/regression/host_assoc_types_1.f90 b/Fortran/gfortran/regression/host_assoc_types_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/host_assoc_types_1.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! Tests the fix for PR29232, in which the invalid code below was not +! diagnosed. +! +! Contributed by Tobias Burnus +! +MODULE test + TYPE vertex + INTEGER :: k + END TYPE vertex +CONTAINS + SUBROUTINE S1() + TYPE(vertex) :: a ! { dg-error "cannot be host associated" } + vertex : DO i=1,2 ! { dg-error "incompatible object of the same name" } + ENDDO vertex + END SUBROUTINE +END MODULE test diff --git a/Fortran/gfortran/regression/host_assoc_types_2.f90 b/Fortran/gfortran/regression/host_assoc_types_2.f90 --- /dev/null +++ b/Fortran/gfortran/regression/host_assoc_types_2.f90 @@ -0,0 +1,68 @@ +! { dg-do compile } +! Tests the fix for PR33945, the host association of overloaded_type_s +! would be incorrectly blocked by the use associated overloaded_type. +! +! Contributed by Jonathan Hogg +! +module dtype + implicit none + + type overloaded_type + double precision :: part + end type + + interface overloaded_sub + module procedure overloaded_sub_d + end interface + +contains + subroutine overloaded_sub_d(otype) + type(overloaded_type), intent(in) :: otype + + print *, "d type = ", otype%part + end subroutine +end module + +module stype + implicit none + + type overloaded_type + real :: part + end type + + interface overloaded_sub + module procedure overloaded_sub_s + end interface + +contains + subroutine overloaded_sub_s(otype) + type(overloaded_type), intent(in) :: otype + + print *, "s type = ", otype%part + end subroutine +end module + +program test + use stype, overloaded_type_s => overloaded_type + use dtype, overloaded_type_d => overloaded_type + implicit none + + type(overloaded_type_s) :: sval + type(overloaded_type_d) :: dval + + sval%part = 1 + dval%part = 2 + + call fred(sval, dval) + +contains + subroutine fred(sval, dval) + use stype + + type(overloaded_type_s), intent(in) :: sval ! This caused an error + type(overloaded_type_d), intent(in) :: dval + + call overloaded_sub(sval) + call overloaded_sub(dval) + end subroutine +end program diff --git a/Fortran/gfortran/regression/host_assoc_variable_1.f90 b/Fortran/gfortran/regression/host_assoc_variable_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/host_assoc_variable_1.f90 @@ -0,0 +1,77 @@ +! { dg-do compile } +! { dg-require-visibility "" } +! This tests that PR32760, in its various manifestations is fixed. +! +! Contributed by Harald Anlauf +! +! This is the original bug - the frontend tried to fix the flavor of +! 'PRINT' too early so that the compile failed on the subroutine +! declaration. +! +module gfcbug68 + implicit none + public :: print +contains + subroutine foo (i) + integer, intent(in) :: i + print *, i + end subroutine foo + subroutine print (m) + integer, intent(in) :: m + end subroutine print +end module gfcbug68 + +! This version of the bug appears in comment # 21. +! +module m + public :: volatile +contains + subroutine foo + volatile :: bar + end subroutine foo + subroutine volatile + end subroutine volatile +end module + +! This was a problem with the resolution of the STAT parameter in +! ALLOCATE and DEALLOCATE that was exposed in comment #25. +! +module n + public :: integer + private :: istat +contains + subroutine foo + integer, allocatable :: s(:), t(:) + allocate(t(5)) + allocate(s(4), stat=istat) + end subroutine foo + subroutine integer() + end subroutine integer +end module n + +! This is the version of the bug in comment #12 of the PR. +! +module gfcbug68a + implicit none + public :: write +contains + function foo (i) + integer, intent(in) :: i + integer foo + write (*,*) i + foo = i + end function foo + subroutine write (m) + integer, intent(in) :: m + print *, m*m*m + end subroutine write +end module gfcbug68a + +program testit + use gfcbug68a + integer :: i = 27 + integer :: k + k = foo(i) + print *, "in the main:", k + call write(33) +end program testit diff --git a/Fortran/gfortran/regression/host_dummy_index_1.f90 b/Fortran/gfortran/regression/host_dummy_index_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/host_dummy_index_1.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! Tests the fix for PR23446. Based on PR example. +! Contributed by Paul Thomas +! +! Tests furthermore the fix for PR fortran/29916. +! Test contributed by Marco Restelli +! +PROGRAM TST + INTEGER IMAX + INTEGER :: A(4) = 1 + IMAX=2 + + CALL S(A) + CALL T(A) + CALL U(A) + if ( ALL(A.ne.(/2,2,3,4/))) STOP 1 + if ( ALL(F().ne.(/2.0,2.0/))) STOP 2 + +CONTAINS + SUBROUTINE S(A) + INTEGER A(IMAX) + a = 2 + END SUBROUTINE S + SUBROUTINE T(A) + INTEGER A(3:IMAX+4) + A(5:IMAX+4) = 3 + END SUBROUTINE T + SUBROUTINE U(A) + INTEGER A(2,IMAX) + A(2,2) = 4 + END SUBROUTINE U + FUNCTION F() + real :: F(IMAX) + F = 2.0 + END FUNCTION F +ENDPROGRAM TST diff --git a/Fortran/gfortran/regression/host_used_types_1.f90 b/Fortran/gfortran/regression/host_used_types_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/host_used_types_1.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! Tests the fix for PR25532, which was a regression introduced by +! the fix for PR20244. +! +! Contributed by Erik Edelmann +module ModelParams + implicit none + + type ReionizationParams + real :: fraction + end type ReionizationParams + + type CAMBparams + type(ReionizationParams) :: Reion + end type CAMBparams + + type(CAMBparams) CP +end module ModelParams + + +module ThermoData + use ModelParams + implicit none + +contains + + subroutine inithermo() + use ModelParams + if (0 < CP%Reion%fraction) then + end if + end subroutine inithermo + +! The bug expressed itself in this subroutine because the component type +! information was not being copied from the parent namespace. + subroutine SetTimeSteps + if (0 < CP%Reion%fraction) then + end if + end subroutine SetTimeSteps + +end module ThermoData diff --git a/Fortran/gfortran/regression/hypot_1.f90 b/Fortran/gfortran/regression/hypot_1.f90 --- /dev/null +++ b/Fortran/gfortran/regression/hypot_1.f90 @@ -0,0 +1,29 @@ +! { dg-do run } + +program test + implicit none + + interface check + procedure check_r4 + procedure check_r8 + end interface check + + real(kind=4) :: x4, y4 + real(kind=8) :: x8, y8 + + x8 = 1.9_8 ; x4 = 1.9_4 + y8 = -2.1_8 ; y4 = -2.1_4 + + call check(hypot(x8,y8), hypot(1.9_8,-2.1_8)) + call check(hypot(x4,y4), hypot(1.9_4,-2.1_4)) + +contains + subroutine check_r4 (a, b) + real(kind=4), intent(in) :: a, b + if (abs(a - b) > 1.e-5 * abs(b)) STOP 1 + end subroutine + subroutine check_r8 (a, b) + real(kind=8), intent(in) :: a, b + if (abs(a - b) > 1.e-7 * abs(b)) STOP 2 + end subroutine +end program test