aboutsummaryrefslogtreecommitdiff
path: root/gcc/testsuite/g77.f-torture
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/testsuite/g77.f-torture')
-rw-r--r--gcc/testsuite/g77.f-torture/compile/13060.f13
-rw-r--r--gcc/testsuite/g77.f-torture/compile/20030326-1.f14
-rw-r--r--gcc/testsuite/g77.f-torture/execute/10197.f15
-rw-r--r--gcc/testsuite/g77.f-torture/execute/13037.f58
-rw-r--r--gcc/testsuite/g77.f-torture/execute/1832.f8
-rw-r--r--gcc/testsuite/g77.f-torture/execute/select.f173
-rw-r--r--gcc/testsuite/g77.f-torture/noncompile/9263.f7
-rw-r--r--gcc/testsuite/g77.f-torture/noncompile/select_no_compile.f10
8 files changed, 298 insertions, 0 deletions
diff --git a/gcc/testsuite/g77.f-torture/compile/13060.f b/gcc/testsuite/g77.f-torture/compile/13060.f
new file mode 100644
index 00000000000..200117b0271
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/compile/13060.f
@@ -0,0 +1,13 @@
+ subroutine geo2()
+ implicit none
+
+ integer ms,n,ne(2)
+
+ ne(1) = 1
+ ne(2) = 2
+ ms = 1
+
+ call call_me(ne(1)*ne(1))
+
+ n = ne(ms)
+ end
diff --git a/gcc/testsuite/g77.f-torture/compile/20030326-1.f b/gcc/testsuite/g77.f-torture/compile/20030326-1.f
new file mode 100644
index 00000000000..bcbc73c179b
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/compile/20030326-1.f
@@ -0,0 +1,14 @@
+C PR fortran/9793
+C larson@w6yx.stanford.edu
+C
+ integer a, b, c
+
+ c = -2147483648 / -1
+
+ a = 1
+ b = 0
+ c = a / b
+
+ print *, c
+
+ end
diff --git a/gcc/testsuite/g77.f-torture/execute/10197.f b/gcc/testsuite/g77.f-torture/execute/10197.f
new file mode 100644
index 00000000000..0fa81f67809
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/execute/10197.f
@@ -0,0 +1,15 @@
+ IMPLICIT NONE
+ LOGICAL ERROR
+ CHARACTER*12 FORM
+ DATA ERROR /.FALSE./
+ DATA FORM /' '/
+ OPEN(UNIT=60,ACCESS='DIRECT',STATUS='SCRATCH',RECL=255)
+ INQUIRE(UNIT=60,FORM=FORM)
+ IF (FORM.EQ.'UNFORMATTED') THEN
+ ERROR = .FALSE.
+ ELSE
+ ERROR = .TRUE.
+ ENDIF
+ CLOSE(UNIT=60)
+ IF (ERROR) CALL ABORT
+ END
diff --git a/gcc/testsuite/g77.f-torture/execute/13037.f b/gcc/testsuite/g77.f-torture/execute/13037.f
new file mode 100644
index 00000000000..daafc528754
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/execute/13037.f
@@ -0,0 +1,58 @@
+c PR optimization/13037
+c Contributed by Kirill Smelkov
+c bug symptom: zeta(kkzc) seems to reference to zeta(kkzc-1) instead
+c with gcc-3.2.2 it is OK, so it is a regression.
+c
+ subroutine bug1(expnt)
+ implicit none
+
+ double precision zeta
+ common /bug1_area/zeta(3)
+
+ double precision expnt(3)
+
+
+ integer k, kkzc
+
+ kkzc=0
+ do k=1,3
+ kkzc = kkzc + 1
+ zeta(kkzc) = expnt(k)
+ enddo
+
+c the following line activates the bug
+ call bug1_activator(kkzc)
+ end
+
+
+c dummy subroutine
+ subroutine bug1_activator(inum)
+ implicit none
+ integer inum
+ end
+
+
+c test driver
+ program test_bug1
+ implicit none
+
+ double precision zeta
+ common /bug1_area/zeta(3)
+
+ double precision expnt(3)
+
+ zeta(1) = 0.0d0
+ zeta(2) = 0.0d0
+ zeta(3) = 0.0d0
+
+ expnt(1) = 1.0d0
+ expnt(2) = 2.0d0
+ expnt(3) = 3.0d0
+
+ call bug1(expnt)
+ if ((zeta(1).ne.1) .or. (zeta(2).ne.2) .or. (zeta(3).ne.3)) then
+ call abort
+ endif
+
+ end
+
diff --git a/gcc/testsuite/g77.f-torture/execute/1832.f b/gcc/testsuite/g77.f-torture/execute/1832.f
new file mode 100644
index 00000000000..9ae1ca9fb27
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/execute/1832.f
@@ -0,0 +1,8 @@
+ character*120 file
+ character*5 string
+ file = "c:/dos/adir/bdir/cdir/text.doc"
+ write(string, *) "a ", file
+ if (string .ne. ' a') call abort
+C-- The leading space is normal for list-directed output
+C-- "file" is not printed because it would overflow "string".
+ end
diff --git a/gcc/testsuite/g77.f-torture/execute/select.f b/gcc/testsuite/g77.f-torture/execute/select.f
new file mode 100644
index 00000000000..f1024330a71
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/execute/select.f
@@ -0,0 +1,173 @@
+C integer byte case with integer byte parameters as case(s)
+ subroutine ib
+ integer *1 a /1/
+ integer *1 one,two,three
+ parameter (one=1,two=2,three=3)
+ select case (a)
+ case (one)
+ case (two)
+ call abort
+ case (three)
+ call abort
+ case default
+ call abort
+ end select
+ print*,'normal ib'
+ end
+C integer halfword case with integer halfword parameters
+ subroutine ih
+ integer *2 a /1/
+ integer *2 one,two,three
+ parameter (one=1,two=2,three=3)
+ select case (a)
+ case (one)
+ case (two)
+ call abort
+ case (three)
+ call abort
+ case default
+ call abort
+ end select
+ print*,'normal ih'
+ end
+C integer case with integer parameters
+ subroutine iw
+ integer *4 a /1/
+ integer *4 one,two,three
+ parameter (one=1,two=2,three=3)
+ select case (a)
+ case (one)
+ case (two)
+ call abort
+ case (three)
+ call abort
+ case default
+ call abort
+ end select
+ print*,'normal iw'
+ end
+C integer double case with integer double parameters
+ subroutine id
+ integer *8 a /1/
+ integer *8 one,two,three
+ parameter (one=1,two=2,three=3)
+ select case (a)
+ case (one)
+ case (two)
+ call abort
+ case (three)
+ call abort
+ case default
+ call abort
+ end select
+ print*,'normal id'
+ end
+C integer byte select with integer case
+ subroutine ib_mixed
+ integer*1 s /1/
+ select case (s)
+ case (1)
+ case (2)
+ call abort
+ end select
+ print*,'ib ok'
+ end
+C integer halfword with integer case
+ subroutine ih_mixed
+ integer*2 s /1/
+ select case (s)
+ case (1)
+ case default
+ call abort
+ end select
+ print*,'ih ok'
+ end
+C integer word with integer case
+ subroutine iw_mixed
+ integer s /5/
+ select case (s)
+ case (1)
+ call abort
+ case (2)
+ call abort
+ case (3)
+ call abort
+ case (4)
+ call abort
+ case (5)
+C
+ case (6)
+ call abort
+ case default
+ call abort
+ end select
+ print*,'iw ok'
+ end
+C integer doubleword with integer case
+ subroutine id_mixed
+ integer *8 s /1024/
+ select case (s)
+ case (1)
+ call abort
+ case (1023)
+ call abort
+ case (1025)
+ call abort
+ case (1024)
+C
+ end select
+ print*,'i8 ok'
+ end
+ subroutine l1_mixed
+ logical*1 s /.TRUE./
+ select case (s)
+ case (.TRUE.)
+ case (.FALSE.)
+ call abort
+ end select
+ print*,'l1 ok'
+ end
+ subroutine l2_mixed
+ logical*2 s /.FALSE./
+ select case (s)
+ case (.TRUE.)
+ call abort
+ case (.FALSE.)
+ end select
+ print*,'lh ok'
+ end
+ subroutine l4_mixed
+ logical*4 s /.TRUE./
+ select case (s)
+ case (.FALSE.)
+ call abort
+ case (.TRUE.)
+ end select
+ print*,'lw ok'
+ end
+ subroutine l8_mixed
+ logical*8 s /.TRUE./
+ select case (s)
+ case (.TRUE.)
+ case (.FALSE.)
+ call abort
+ end select
+ print*,'ld ok'
+ end
+C main
+C -- regression cases
+ call ib
+ call ih
+ call iw
+ call id
+C -- new functionality
+ call ib_mixed
+ call ih_mixed
+ call iw_mixed
+ call id_mixed
+ end
+
+
+
+
+
diff --git a/gcc/testsuite/g77.f-torture/noncompile/9263.f b/gcc/testsuite/g77.f-torture/noncompile/9263.f
new file mode 100644
index 00000000000..e68b3e0a65f
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/noncompile/9263.f
@@ -0,0 +1,7 @@
+ PARAMETER (Q=1)
+ PARAMETER (P=10)
+ INTEGER C(10),D(10),E(10),F(10)
+ DATA (C(I),I=1,P) /10*10/ ! TERMINAL NOT INTEGER
+ DATA (D(I),I=Q,10) /10*10/ ! START NOT INTEGER
+ DATA (E(I),I=1,10,Q) /10*10/ ! INCREMENT NOT INTEGER
+ END
diff --git a/gcc/testsuite/g77.f-torture/noncompile/select_no_compile.f b/gcc/testsuite/g77.f-torture/noncompile/select_no_compile.f
new file mode 100644
index 00000000000..f7dad339a81
--- /dev/null
+++ b/gcc/testsuite/g77.f-torture/noncompile/select_no_compile.f
@@ -0,0 +1,10 @@
+ integer*1 one
+ integer*2 two
+ parameter (one=1)
+ parameter (two=2)
+ select case (I)
+ case (one)
+ case (two)
+ end select
+ end
+
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-18 13:08:03 +0000