diff options
Diffstat (limited to 'gcc/testsuite/g77.f-torture')
74 files changed, 0 insertions, 4029 deletions
diff --git a/gcc/testsuite/g77.f-torture/compile/19990218-0.f b/gcc/testsuite/g77.f-torture/compile/19990218-0.f deleted file mode 100644 index 3e34117ec69..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/19990218-0.f +++ /dev/null @@ -1,13 +0,0 @@ - program test - double precision a,b,c - data a,b/1.0d-46,1.0d0/ - c=fun(a,b) - print*,'in main: fun=',c - end - double precision function fun(a,b) - double precision a,b - print*,'in sub: a,b=',a,b - fun=a*b - print*,'in sub: fun=',fun - return - end diff --git a/gcc/testsuite/g77.f-torture/compile/19990305-0.f b/gcc/testsuite/g77.f-torture/compile/19990305-0.f deleted file mode 100644 index 32c656d90a6..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/19990305-0.f +++ /dev/null @@ -1,55 +0,0 @@ -* Date: Fri, 5 Mar 1999 00:35:44 -0500 (EST) -* From: Denes Molnar <molnard@phys.columbia.edu> -* To: fortran@gnu.org -* Subject: f771 gets fatal signal 6 -* Content-Type: TEXT/PLAIN; charset=US-ASCII -* X-UIDL: 8d81e9cbdcc96209c6e9b298d966ba7f -* -* Hi, -* -* -* Comiling object from the source code below WORKS FINE with -* 'g77 -o hwuci2 -c hwuci2.F' -* but FAILS with fatal signal 6 -* 'g77 -o hwuci2 -O -c hwuci2.F' -* -* Any explanations? -* -* I am running GNU Fortran 0.5.23 with GCC 2.8.1 (glibc1). -* -* -* Denes Molnar -* -* %%%%%%%%%%%%%%%%%%%%%%%%% -* %the source: -* %%%%%%%%%%%%%%%%%%%%%%%%% -* -CDECK ID>, HWUCI2. -*CMZ :- -23/08/94 13.22.29 by Mike Seymour -*-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles -C----------------------------------------------------------------------- - FUNCTION HWUCI2(A,B,Y0) -C----------------------------------------------------------------------- -C Integral LOG(A-EPSI-BY(1-Y))/(Y-Y0) -C----------------------------------------------------------------------- - IMPLICIT NONE - DOUBLE COMPLEX HWUCI2,HWULI2,EPSI,Y1,Y2,Z1,Z2,Z3,Z4 - DOUBLE PRECISION A,B,Y0,ZERO,ONE,FOUR,HALF - EXTERNAL HWULI2 - COMMON/SMALL/EPSI - PARAMETER (ZERO=0.D0, ONE =1.D0, FOUR= 4.D0, HALF=0.5D0) - IF(B.EQ.ZERO)THEN - HWUCI2=CMPLX(ZERO,ZERO) - ELSE - Y1=HALF*(ONE+SQRT(ONE-FOUR*(A+EPSI)/B)) - Y2=ONE-Y1 - Z1=Y0/(Y0-Y1) - Z2=(Y0-ONE)/(Y0-Y1) - Z3=Y0/(Y0-Y2) - Z4=(Y0-ONE)/(Y0-Y2) - HWUCI2=HWULI2(Z1)-HWULI2(Z2)+HWULI2(Z3)-HWULI2(Z4) - ENDIF - RETURN - END -* -* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/gcc/testsuite/g77.f-torture/compile/19990419-0.f b/gcc/testsuite/g77.f-torture/compile/19990419-0.f deleted file mode 100644 index 084e7a254bf..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/19990419-0.f +++ /dev/null @@ -1,7 +0,0 @@ -* Test case Toon submitted, cut down to expose the one bug. -* Belongs in compile/. - SUBROUTINE INIERS1 - IMPLICIT LOGICAL(L) - COMMON/COMIOD/ NHIERS1, LERS1 - inquire(nhiers1, exist=lers1) - END diff --git a/gcc/testsuite/g77.f-torture/compile/19990502-0.f b/gcc/testsuite/g77.f-torture/compile/19990502-0.f deleted file mode 100644 index 4f5d6859138..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/19990502-0.f +++ /dev/null @@ -1,66 +0,0 @@ -* Mailing-List: contact egcs-bugs-help@egcs.cygnus.com; run by ezmlm -* Precedence: bulk -* Sender: owner-egcs-bugs@egcs.cygnus.com -* From: Norbert Conrad <Norbert.Conrad@hrz.uni-giessen.de> -* Subject: egcs g77 19990524pre Internal compiler error in `print_operand' -* To: egcs-bugs@egcs.cygnus.com -* Date: Mon, 31 May 1999 11:46:52 +0200 (CET) -* Content-Type: text/plain; charset=US-ASCII -* X-UIDL: 9a00095a5fe4d774b7223de071157374 -* -* Hi, -* -* I ./configure --prefix=/opt and bootstrapped egcs g77 snapshot 19990524 -* on an i686-pc-linux-gnu. The program below gives an internal compiler error. -* -* -* Script started on Mon May 31 11:30:01 1999 -* lx{g010}:/tmp>/opt/bin/g77 -v -O3 -malign-double -c e3.f -* g77 version gcc-2.95 19990524 (prerelease) (from FSF-g77 version 0.5.24-19990515) -* Reading specs from /opt/lib/gcc-lib/i686-pc-linux-gnu/gcc-2.95/specs -* gcc version gcc-2.95 19990524 (prerelease) -* /opt/lib/gcc-lib/i686-pc-linux-gnu/gcc-2.95/f771 e3.f -quiet -dumpbase e3.f -malign-double -O3 -version -fversion -o /tmp/ccQgeaaa.s -* GNU F77 version gcc-2.95 19990524 (prerelease) (i686-pc-linux-gnu) compiled by GNU C version gcc-2.95 19990524 (prerelease). -* GNU Fortran Front End version 0.5.24-19990515 -* e3.f:25: Internal compiler error in `print_operand', at ./config/i386/i386.c:3405 -* Please submit a full bug report to `egcs-bugs@egcs.cygnus.com'. -* See <URL:http://egcs.cygnus.com/faq.html#bugreport> for details. -* lx{g010}:/tmp>cat e3.f - SUBROUTINE DLASQ2( QQ, EE, TOL2, SMALL2 ) - DOUBLE PRECISION SMALL2, TOL2 - DOUBLE PRECISION EE( * ), QQ( * ) - INTEGER ICONV, N, OFF - DOUBLE PRECISION QEMAX, XINF - EXTERNAL DLASQ3 - INTRINSIC MAX, SQRT - XINF = 0.0D0 - ICONV = 0 - IF( EE( N ).LE.MAX( QQ( N ), XINF, SMALL2 )*TOL2 ) THEN - END IF - IF( EE( N-2 ).LE.MAX( XINF, SMALL2, - $ ( QQ( N ) / ( QQ( N )+EE( N-1 ) ) )* QQ( N-1 ))*TOL2 ) THEN - QEMAX = MAX( QQ( N ), QQ( N-1 ), EE( N-1 ) ) - END IF - IF( N.EQ.0 ) THEN - IF( OFF.EQ.0 ) THEN - RETURN - ELSE - XINF =0.0D0 - END IF - ELSE IF( N.EQ.2 ) THEN - END IF - CALL DLASQ3(ICONV) - END -* lx{g010}:/tmp>exit -* -* Script done on Mon May 31 11:30:23 1999 -* -* Best regards, -* -* Norbert. -* -- -* Norbert Conrad phone: ++49 641 9913021 -* Hochschulrechenzentrum email: conrad@hrz.uni-giessen.de -* Heinrich-Buff-Ring 44 -* 35392 Giessen -* Germany diff --git a/gcc/testsuite/g77.f-torture/compile/19990502-1.f b/gcc/testsuite/g77.f-torture/compile/19990502-1.f deleted file mode 100644 index b7238fcd881..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/19990502-1.f +++ /dev/null @@ -1,6 +0,0 @@ - SUBROUTINE G(IGAMS,IWRK,NADC,NCellsInY) - INTEGER*2 IGAMS(2,NADC) - in = 1 - do while (in.le.nadc.and.IGAMS(2,in).le.in) - enddo - END diff --git a/gcc/testsuite/g77.f-torture/compile/960317-1.f b/gcc/testsuite/g77.f-torture/compile/960317-1.f deleted file mode 100644 index 4bb0a37278e..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/960317-1.f +++ /dev/null @@ -1,103 +0,0 @@ -* Date: Sat, 16 Mar 1996 19:58:37 -0500 (EST) -* From: Kate Hedstrom <kate@ahab.Rutgers.EDU> -* To: burley@gnu.ai.mit.edu -* Subject: g77 bug in assign -* -* I found some files in the NCAR graphics source code which used to -* compile with g77 and now don't. All contain the following combination -* of "save" and "assign". It fails on a Sun running SunOS 4.1.3 and a -* Sun running SunOS 5.5 (slightly older g77), but compiles on an -* IBM/RS6000: -* -C - SUBROUTINE QUICK - SAVE -C - ASSIGN 101 TO JUMP - 101 Continue -C - RETURN - END -* -* Everything else in the NCAR distribution compiled, including quite a -* few C routines. -* -* Kate -* -* -* nemo% g77 -v -c quick.f -* gcc -v -c -xf77 quick.f -* Reading specs from /usr/local/lib/gcc-lib/sparc-sun-sunos4.1.3/2.7.2/specs -* gcc version 2.7.2 -* /usr/local/lib/gcc-lib/sparc-sun-sunos4.1.3/2.7.2/f771 quick.f -fset-g77-defaults -quiet -dumpbase quick.f -version -fversion -o /usr/tmp/cca24166.s -* GNU F77 version 2.7.2 (sparc) compiled by GNU C version 2.7.1. -* GNU Fortran Front End version 0.5.18-960314 compiled: Mar 16 1996 14:28:11 -* gcc: Internal compiler error: program f771 got fatal signal 11 -* -* -* nemo% gdb /usr/local/lib/gcc-lib/*/*/f771 core -* GDB is free software and you are welcome to distribute copies of it -* under certain conditions; type "show copying" to see the conditions. -* There is absolutely no warranty for GDB; type "show warranty" for details. -* GDB 4.14 (sparc-sun-sunos4.1.3), -* Copyright 1995 Free Software Foundation, Inc... -* Core was generated by `f771'. -* Program terminated with signal 11, Segmentation fault. -* Couldn't read input and local registers from core file -* find_solib: Can't read pathname for load map: I/O error -* -* Couldn't read input and local registers from core file -* #0 0x21aa4 in ffecom_sym_transform_assign_ (s=???) at f/com.c:7881 -* 7881 if ((ffesymbol_save (s) || ffe_is_saveall ()) -* (gdb) where -* #0 0x21aa4 in ffecom_sym_transform_assign_ (s=???) at f/com.c:7881 -* Error accessing memory address 0xefffefcc: Invalid argument. -* (gdb) -* -* -* ahab% g77 -v -c quick.f -* gcc -v -c -xf77 quick.f -* Reading specs from /usr/local/lib/gcc-lib/sparc-sun-solaris2.5/2.7.2/specs -* gcc version 2.7.2 -* /usr/local/lib/gcc-lib/sparc-sun-solaris2.5/2.7.2/f771 quick.f -quiet -dumpbase quick.f -version -fversion -o /var/tmp/cca003D2.s -* GNU F77 version 2.7.2 (sparc) compiled by GNU C version 2.7.2. -* GNU Fortran Front End version 0.5.18-960304 compiled: Mar 5 1996 16:12:46 -* gcc: Internal compiler error: program f771 got fatal signal 11 -* -* -* ahab% !gdb -* gdb /usr/local/lib/gcc-lib/*/*/f771 core -* GDB is free software and you are welcome to distribute copies of it -* under certain conditions; type "show copying" to see the conditions. -* There is absolutely no warranty for GDB; type "show warranty" for details. -* GDB 4.15.1 (sparc-sun-solaris2.4), -* Copyright 1995 Free Software Foundation, Inc... -* Core was generated by -* `/usr/local/lib/gcc-lib/sparc-sun-solaris2.5/2.7.2/f771 quick.f -quiet -dumpbase'. -* Program terminated with signal 11, Segmentation fault. -* Reading symbols from /usr/lib/libc.so.1...done. -* Reading symbols from /usr/lib/libdl.so.1...done. -* #0 0x43e04 in ffecom_sym_transform_assign_ (s=0x3a22f8) at f/com.c:7963 -* Source file is more recent than executable. -* 7963 assert (st != NULL); -* (gdb) where -* #0 0x43e04 in ffecom_sym_transform_assign_ (s=0x3a22f8) at f/com.c:7963 -* #1 0x38044 in ffecom_expr_ (expr=0x3a23c0, dest_tree=0x0, dest=0x0, dest_used=0x0, assignp=true) at f/com.c:2100 -* #2 0x489c8 in ffecom_expr_assign_w (expr=0x3a23c0) at f/com.c:10238 -* #3 0xe9228 in ffeste_R838 (label=0x3a1ba8, target=0x3a23c0) at f/ste.c:2769 -* #4 0xdae60 in ffestd_stmt_pass_ () at f/std.c:840 -* #5 0xdc090 in ffestd_exec_end () at f/std.c:1405 -* #6 0xcb534 in ffestc_shriek_subroutine_ (ok=true) at f/stc.c:4849 -* #7 0xd8f00 in ffestc_R1225 (name=0x0) at f/stc.c:12307 -* #8 0xcc808 in ffestc_end () at f/stc.c:5572 -* #9 0x9fa84 in ffestb_end3_ (t=0x3a19c8) at f/stb.c:3216 -* #10 0x9f30c in ffestb_end (t=0x3a19c8) at f/stb.c:2995 -* #11 0x98414 in ffesta_save_ (t=0x3a19c8) at f/sta.c:453 -* #12 0x997ec in ffesta_second_ (t=0x3a19c8) at f/sta.c:1178 -* #13 0x8ed84 in ffelex_send_token_ () at f/lex.c:1614 -* #14 0x8cab8 in ffelex_finish_statement_ () at f/lex.c:946 -* #15 0x91684 in ffelex_file_fixed (wf=0x397780, f=0x37a560) at f/lex.c:2946 -* #16 0x107a94 in ffe_file (wf=0x397780, f=0x37a560) at f/top.c:456 -* #17 0x96218 in yyparse () at f/parse.c:77 -* #18 0x10beac in compile_file (name=0xdffffaf7 "quick.f") at toplev.c:2239 -* #19 0x110dc0 in main (argc=9, argv=0xdffff994, envp=0xdffff9bc) at toplev.c:3927 diff --git a/gcc/testsuite/g77.f-torture/compile/970125-0.f b/gcc/testsuite/g77.f-torture/compile/970125-0.f deleted file mode 100644 index 004f5584f3e..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/970125-0.f +++ /dev/null @@ -1,40 +0,0 @@ -C JCB comments: -C g77 doesn't accept the added line "integer(kind=7) ..." -- -C it crashes! -C -C It's questionable that g77 DTRT with regarding to passing -C %LOC() as an argument (thus by reference) and the new global -C analysis. I need to look into that further; my feeling is that -C passing %LOC() as an argument should be treated like passing an -C INTEGER(KIND=7) by reference, and no more specially than that -C (and that INTEGER(KIND=7) should be permitted as equivalent to -C INTEGER(KIND=1), INTEGER(KIND=2), or whatever, depending on the -C system's pointer size). -C -C The back end *still* has a bug here, which should be fixed, -C because, currently, what g77 is passing to it is, IMO, correct. - -C No options: -C ../../egcs/gcc/f/info.c:259: failed assertion `ffeinfo_types_[basictype][kindtype] != NULL' -C -fno-globals -O: -C ../../egcs/gcc/expr.c:7291: Internal compiler error in function expand_expr - -c Frontend bug fixed by JCB 1998-06-01 com.c &c changes. - - integer*4 i4 - integer*8 i8 - integer*8 max4 - data max4/2147483647/ - i4 = %loc(i4) - i8 = %loc(i8) - print *, max4 - print *, i4, %loc(i4) - print *, i8, %loc(i8) - call foo(i4, %loc(i4), i8, %loc(i8)) - end - subroutine foo(i4, i4a, i8, i8a) - integer(kind=7) i4a, i8a - integer*8 i8 - print *, i4, i4a - print *, i8, i8a - end diff --git a/gcc/testsuite/g77.f-torture/compile/970915-0.f b/gcc/testsuite/g77.f-torture/compile/970915-0.f deleted file mode 100644 index 9ac3cf8aa97..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/970915-0.f +++ /dev/null @@ -1,20 +0,0 @@ -* fixed by patch to safe_from_p to avoid visiting any SAVE_EXPR -* node twice in a given top-level call to it. -* (JCB com.c patch of 1998-06-04.) - - SUBROUTINE TSTSIG11 - IMPLICIT COMPLEX (A-Z) - EXTERNAL gzi1,gzi2 - branch3 = sw2 / cw - . * ( rdw * (epsh*gzi1(A,B)-gzi2(A,B)) - . + rdw * (epsh*gzi1(A,B)-gzi2(A,B)) ) - . + (-1./2. + 2.*sw2/3.) / (sw*cw) - . * rdw * (epsh*gzi1(A,B)-gzi2(A,B) - . + rdw * (epsh*gzi1(A,B)-gzi2(A,B)) - . + rdw * (epsh*gzi1(A,B)-gzi2(A,B)) ) - . * rup * (epsh*gzi1(A,B)-gzi2(A,B) - . + rup * (epsh*gzi1(A,B)-gzi2(A,B)) ) - . * 4.*(3.-tw**2) * gzi2(A,B) - . + ((1.+2./tauw)*tw**2-(5.+2./tauw))* gzi1(A,B) - RETURN - END diff --git a/gcc/testsuite/g77.f-torture/compile/980310-1.f b/gcc/testsuite/g77.f-torture/compile/980310-1.f deleted file mode 100644 index bc8aa85c14a..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/980310-1.f +++ /dev/null @@ -1,28 +0,0 @@ -C Causes internal compiler error on egcs 1.0.1 on i586-pc-sco3.2v5.0.4 -C To: egcs-bugs@cygnus.com -C Subject: backend case range problem/fix -C From: Dave Love <d.love@dl.ac.uk> -C Date: 02 Dec 1997 18:11:35 +0000 -C Message-ID: <rzqpvnfboo8.fsf@djlvig.dl.ac.uk> -C -C The following Fortran test case aborts the compiler because -C tree_int_cst_lt dereferences a null tree; this is a regression from -C gcc 2.7. - - INTEGER N - READ(*,*) N - SELECT CASE (N) - CASE (1:) - WRITE(*,*) 'case 1' - CASE (0) - WRITE(*,*) 'case 0' - END SELECT - END - -C The relevant change to cure this is: -C -C Thu Dec 4 06:34:40 1997 Richard Kenner <kenner@vlsi1.ultra.nyu.edu> -C -C * stmt.c (pushcase_range): Clean up handling of "infinite" values. -C - diff --git a/gcc/testsuite/g77.f-torture/compile/980310-2.f b/gcc/testsuite/g77.f-torture/compile/980310-2.f deleted file mode 100644 index 5077c552da8..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/980310-2.f +++ /dev/null @@ -1,43 +0,0 @@ -C unable to confirm this bug on egcs 1.0.1 for i586-pc-sco3.2v5.0.4 robertl -C -C Date: Sat, 23 Aug 1997 00:47:53 -0400 (EDT) -C From: David Bristow <dbristow@lynx.dac.neu.edu> -C To: egcs-bugs@cygnus.com -C Subject: g77 crashes compiling Dungeon -C Message-ID: <Pine.OSF.3.91.970823003521.11281A-100000@lynx.dac.neu.edu> -C -C The following small segment of Dungeon (the adventure that became the -C commercial hit Zork) causes an internal error in f771. The platform is -C i586-pc-linux-gnulibc1, the compiler is egcs-ss-970821 (g77-GNU Fortran -C 0.5.21-19970811) -C -C --cut here--cut here--cut here--cut here--cut here--cut here-- -C g77 --verbose -fugly -fvxt -c subr_.f -C g77 version 0.5.21-19970811 -C gcc --verbose -fugly -fvxt -xf77 subr_.f -xnone -lf2c -lm -C Reading specs from /usr/lib/gcc-lib/i586-pc-linux-gnulibc1/egcs-2.90.01/specs -C gcc version egcs-2.90.01 970821 (gcc2-970802 experimental) -C /usr/lib/gcc-lib/i586-pc-linux-gnulibc1/egcs-2.90.01/f771 subr_.f -fset-g77-defaults -quiet -dumpbase subr_.f -version -fversion -fugly -fvxt -o /tmp/cca23974.s -C f771: warning: -fugly is overloaded with meanings and likely to be removed; -C f771: warning: use only the specific -fugly-* options you need -C GNU F77 version egcs-2.90.01 970821 (gcc2-970802 experimental) (i586-pc-linux-gnulibc1) compiled by GNU C version egcs-2.90.01 970821 (gcc2-970802 experimental). -C GNU Fortran Front End version 0.5.21-19970811 -C f/com.c:941: failed assertion `TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e))' -C gcc: Internal compiler error: program f771 got fatal signal 6 -C --cut here--cut here--cut here--cut here--cut here--cut here-- -C -C Here's the FORTRAN code, it's basically a single subroutine from subr.f -C in the Dungeon source, slightly altered (the original calls RAN(), which -C doesn't exist in the g77 runtime) -C -C RND - Return a random integer mod n -C - INTEGER FUNCTION RND (N) - IMPLICIT INTEGER (A-Z) - REAL RAND - COMMON /SEED/ RNSEED - - RND = RAND(RNSEED)*FLOAT(N) - RETURN - - END diff --git a/gcc/testsuite/g77.f-torture/compile/980310-3.f b/gcc/testsuite/g77.f-torture/compile/980310-3.f deleted file mode 100644 index ddfb4c4bb9f..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/980310-3.f +++ /dev/null @@ -1,259 +0,0 @@ -c -c This demonstrates a problem with g77 and pic on x86 where -c egcs 1.0.1 and earlier will generate bogus assembler output. -c unfortunately, gas accepts the bogus acssembler output and -c generates code that almost works. -c - - -C Date: Wed, 17 Dec 1997 23:20:29 +0000 -C From: Joao Cardoso <jcardoso@inescn.pt> -C To: egcs-bugs@cygnus.com -C Subject: egcs-1.0 f77 bug on OSR5 -C When trying to compile the Fortran file that I enclose bellow, -C I got an assembler error: -C -C ./g77 -B./ -fpic -O -c scaleg.f -C /usr/tmp/cca002D8.s:123:syntax error at ( -C -C ./g77 -B./ -fpic -O0 -c scaleg.f -C /usr/tmp/cca002EW.s:246:invalid operand combination: leal -C -C Compiling without the -fpic flag runs OK. - - subroutine scaleg (n,ma,a,mb,b,low,igh,cscale,cperm,wk) -c -c *****parameters: - integer igh,low,ma,mb,n - double precision a(ma,n),b(mb,n),cperm(n),cscale(n),wk(n,6) -c -c *****local variables: - integer i,ir,it,j,jc,kount,nr,nrp2 - double precision alpha,basl,beta,cmax,coef,coef2,coef5,cor, - * ew,ewc,fi,fj,gamma,pgamma,sum,t,ta,tb,tc -c -c *****fortran functions: - double precision dabs, dlog10, dsign -c float -c -c *****subroutines called: -c none -c -c --------------------------------------------------------------- -c -c *****purpose: -c scales the matrices a and b in the generalized eigenvalue -c problem a*x = (lambda)*b*x such that the magnitudes of the -c elements of the submatrices of a and b (as specified by low -c and igh) are close to unity in the least squares sense. -c ref.: ward, r. c., balancing the generalized eigenvalue -c problem, siam j. sci. stat. comput., vol. 2, no. 2, june 1981, -c 141-152. -c -c *****parameter description: -c -c on input: -c -c ma,mb integer -c row dimensions of the arrays containing matrices -c a and b respectively, as declared in the main calling -c program dimension statement; -c -c n integer -c order of the matrices a and b; -c -c a real(ma,n) -c contains the a matrix of the generalized eigenproblem -c defined above; -c -c b real(mb,n) -c contains the b matrix of the generalized eigenproblem -c defined above; -c -c low integer -c specifies the beginning -1 for the rows and -c columns of a and b to be scaled; -c -c igh integer -c specifies the ending -1 for the rows and columns -c of a and b to be scaled; -c -c cperm real(n) -c work array. only locations low through igh are -c referenced and altered by this subroutine; -c -c wk real(n,6) -c work array that must contain at least 6*n locations. -c only locations low through igh, n+low through n+igh, -c ..., 5*n+low through 5*n+igh are referenced and -c altered by this subroutine. -c -c on output: -c -c a,b contain the scaled a and b matrices; -c -c cscale real(n) -c contains in its low through igh locations the integer -c exponents of 2 used for the column scaling factors. -c the other locations are not referenced; -c -c wk contains in its low through igh locations the integer -c exponents of 2 used for the row scaling factors. -c -c *****algorithm notes: -c none. -c -c *****history: -c written by r. c. ward....... -c modified 8/86 by bobby bodenheimer so that if -c sum = 0 (corresponding to the case where the matrix -c doesn't need to be scaled) the routine returns. -c -c --------------------------------------------------------------- -c - if (low .eq. igh) go to 410 - do 210 i = low,igh - wk(i,1) = 0.0d0 - wk(i,2) = 0.0d0 - wk(i,3) = 0.0d0 - wk(i,4) = 0.0d0 - wk(i,5) = 0.0d0 - wk(i,6) = 0.0d0 - cscale(i) = 0.0d0 - cperm(i) = 0.0d0 - 210 continue -c -c compute right side vector in resulting linear equations -c - basl = dlog10(2.0d0) - do 240 i = low,igh - do 240 j = low,igh - tb = b(i,j) - ta = a(i,j) - if (ta .eq. 0.0d0) go to 220 - ta = dlog10(dabs(ta)) / basl - 220 continue - if (tb .eq. 0.0d0) go to 230 - tb = dlog10(dabs(tb)) / basl - 230 continue - wk(i,5) = wk(i,5) - ta - tb - wk(j,6) = wk(j,6) - ta - tb - 240 continue - nr = igh-low+1 - coef = 1.0d0/float(2*nr) - coef2 = coef*coef - coef5 = 0.5d0*coef2 - nrp2 = nr+2 - beta = 0.0d0 - it = 1 -c -c start generalized conjugate gradient iteration -c - 250 continue - ew = 0.0d0 - ewc = 0.0d0 - gamma = 0.0d0 - do 260 i = low,igh - gamma = gamma + wk(i,5)*wk(i,5) + wk(i,6)*wk(i,6) - ew = ew + wk(i,5) - ewc = ewc + wk(i,6) - 260 continue - gamma = coef*gamma - coef2*(ew**2 + ewc**2) - + - coef5*(ew - ewc)**2 - if (it .ne. 1) beta = gamma / pgamma - t = coef5*(ewc - 3.0d0*ew) - tc = coef5*(ew - 3.0d0*ewc) - do 270 i = low,igh - wk(i,2) = beta*wk(i,2) + coef*wk(i,5) + t - cperm(i) = beta*cperm(i) + coef*wk(i,6) + tc - 270 continue -c -c apply matrix to vector -c - do 300 i = low,igh - kount = 0 - sum = 0.0d0 - do 290 j = low,igh - if (a(i,j) .eq. 0.0d0) go to 280 - kount = kount+1 - sum = sum + cperm(j) - 280 continue - if (b(i,j) .eq. 0.0d0) go to 290 - kount = kount+1 - sum = sum + cperm(j) - 290 continue - wk(i,3) = float(kount)*wk(i,2) + sum - 300 continue - do 330 j = low,igh - kount = 0 - sum = 0.0d0 - do 320 i = low,igh - if (a(i,j) .eq. 0.0d0) go to 310 - kount = kount+1 - sum = sum + wk(i,2) - 310 continue - if (b(i,j) .eq. 0.0d0) go to 320 - kount = kount+1 - sum = sum + wk(i,2) - 320 continue - wk(j,4) = float(kount)*cperm(j) + sum - 330 continue - sum = 0.0d0 - do 340 i = low,igh - sum = sum + wk(i,2)*wk(i,3) + cperm(i)*wk(i,4) - 340 continue - if(sum.eq.0.0d0) return - alpha = gamma / sum -c -c determine correction to current iterate -c - cmax = 0.0d0 - do 350 i = low,igh - cor = alpha * wk(i,2) - if (dabs(cor) .gt. cmax) cmax = dabs(cor) - wk(i,1) = wk(i,1) + cor - cor = alpha * cperm(i) - if (dabs(cor) .gt. cmax) cmax = dabs(cor) - cscale(i) = cscale(i) + cor - 350 continue - if (cmax .lt. 0.5d0) go to 370 - do 360 i = low,igh - wk(i,5) = wk(i,5) - alpha*wk(i,3) - wk(i,6) = wk(i,6) - alpha*wk(i,4) - 360 continue - pgamma = gamma - it = it+1 - if (it .le. nrp2) go to 250 -c -c end generalized conjugate gradient iteration -c - 370 continue - do 380 i = low,igh - ir = wk(i,1) + dsign(0.5d0,wk(i,1)) - wk(i,1) = ir - jc = cscale(i) + dsign(0.5d0,cscale(i)) - cscale(i) = jc - 380 continue -c -c scale a and b -c - do 400 i = 1,igh - ir = wk(i,1) - fi = 2.0d0**ir - if (i .lt. low) fi = 1.0d0 - do 400 j =low,n - jc = cscale(j) - fj = 2.0d0**jc - if (j .le. igh) go to 390 - if (i .lt. low) go to 400 - fj = 1.0d0 - 390 continue - a(i,j) = a(i,j)*fi*fj - b(i,j) = b(i,j)*fi*fj - 400 continue - 410 continue - return -c -c last line of scaleg -c - end diff --git a/gcc/testsuite/g77.f-torture/compile/980310-4.f b/gcc/testsuite/g77.f-torture/compile/980310-4.f deleted file mode 100644 index b169845e634..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/980310-4.f +++ /dev/null @@ -1,348 +0,0 @@ - -C To: egcs-bugs@cygnus.com -C Subject: -fPIC problem showing up with fortran on x86 -C From: Dave Love <d.love@dl.ac.uk> -C Date: 19 Dec 1997 19:31:41 +0000 -C -C -C This illustrates a long-standing problem noted at the end of the g77 -C `Actual Bugs' info node and thought to be in the back end. Although -C the report is against gcc 2.7 I can reproduce it (specifically on -C redhat 4.2) with the 971216 egcs snapshot. -C -C g77 version 0.5.21 -C gcc -v -fnull-version -o /tmp/gfa00415 -xf77-cpp-input /tmp/gfa00415.f -xnone -C -lf2c -lm -C - -C ------------ - subroutine dqage(f,a,b,epsabs,epsrel,limit,result,abserr, - * neval,ier,alist,blist,rlist,elist,iord,last) -C -------------------------------------------------- -C -C Modified Feb 1989 by Barry W. Brown to eliminate key -C as argument (use key=1) and to eliminate all Fortran -C output. -C -C Purpose: to make this routine usable from within S. -C -C -------------------------------------------------- -c***begin prologue dqage -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a1a1 -c***keywords automatic integrator, general-purpose, -c integrand examinator, globally adaptive, -c gauss-kronrod -c***author piessens,robert,appl. math. & progr. div. - k.u.leuven -c de doncker,elise,appl. math. & progr. div. - k.u.leuven -c***purpose the routine calculates an approximation result to a given -c definite integral i = integral of f over (a,b), -c hopefully satisfying following claim for accuracy -c abs(i-reslt).le.max(epsabs,epsrel*abs(i)). -c***description -c -c computation of a definite integral -c standard fortran subroutine -c double precision version -c -c parameters -c on entry -c f - double precision -c function subprogram defining the integrand -c function f(x). the actual name for f needs to be -c declared e x t e r n a l in the driver program. -c -c a - double precision -c lower limit of integration -c -c b - double precision -c upper limit of integration -c -c epsabs - double precision -c absolute accuracy requested -c epsrel - double precision -c relative accuracy requested -c if epsabs.le.0 -c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), -c the routine will end with ier = 6. -c -c key - integer -c key for choice of local integration rule -c a gauss-kronrod pair is used with -c 7 - 15 points if key.lt.2, -c 10 - 21 points if key = 2, -c 15 - 31 points if key = 3, -c 20 - 41 points if key = 4, -c 25 - 51 points if key = 5, -c 30 - 61 points if key.gt.5. -c -c limit - integer -c gives an upperbound on the number of subintervals -c in the partition of (a,b), limit.ge.1. -c -c on return -c result - double precision -c approximation to the integral -c -c abserr - double precision -c estimate of the modulus of the absolute error, -c which should equal or exceed abs(i-result) -c -c neval - integer -c number of integrand evaluations -c -c ier - integer -c ier = 0 normal and reliable termination of the -c routine. it is assumed that the requested -c accuracy has been achieved. -c ier.gt.0 abnormal termination of the routine -c the estimates for result and error are -c less reliable. it is assumed that the -c requested accuracy has not been achieved. -c error messages -c ier = 1 maximum number of subdivisions allowed -c has been achieved. one can allow more -c subdivisions by increasing the value -c of limit. -c however, if this yields no improvement it -c is rather advised to analyze the integrand -c in order to determine the integration -c difficulties. if the position of a local -c difficulty can be determined(e.g. -c singularity, discontinuity within the -c interval) one will probably gain from -c splitting up the interval at this point -c and calling the integrator on the -c subranges. if possible, an appropriate -c special-purpose integrator should be used -c which is designed for handling the type of -c difficulty involved. -c = 2 the occurrence of roundoff error is -c detected, which prevents the requested -c tolerance from being achieved. -c = 3 extremely bad integrand behaviour occurs -c at some points of the integration -c interval. -c = 6 the input is invalid, because -c (epsabs.le.0 and -c epsrel.lt.max(50*rel.mach.acc.,0.5d-28), -c result, abserr, neval, last, rlist(1) , -c elist(1) and iord(1) are set to zero. -c alist(1) and blist(1) are set to a and b -c respectively. -c -c alist - double precision -c vector of dimension at least limit, the first -c last elements of which are the left -c end points of the subintervals in the partition -c of the given integration range (a,b) -c -c blist - double precision -c vector of dimension at least limit, the first -c last elements of which are the right -c end points of the subintervals in the partition -c of the given integration range (a,b) -c -c rlist - double precision -c vector of dimension at least limit, the first -c last elements of which are the -c integral approximations on the subintervals -c -c elist - double precision -c vector of dimension at least limit, the first -c last elements of which are the moduli of the -c absolute error estimates on the subintervals -c -c iord - integer -c vector of dimension at least limit, the first k -c elements of which are pointers to the -c error estimates over the subintervals, -c such that elist(iord(1)), ..., -c elist(iord(k)) form a decreasing sequence, -c with k = last if last.le.(limit/2+2), and -c k = limit+1-last otherwise -c -c last - integer -c number of subintervals actually produced in the -c subdivision process -c -c***references (none) -c***routines called d1mach,dqk15,dqk21,dqk31, -c dqk41,dqk51,dqk61,dqpsrt -c***end prologue dqage -c - double precision a,abserr,alist,area,area1,area12,area2,a1,a2,b, - * blist,b1,b2,dabs,defabs,defab1,defab2,dmax1,d1mach,elist,epmach, - * epsabs,epsrel,errbnd,errmax,error1,error2,erro12,errsum,f, - * resabs,result,rlist,uflow - integer ier,iord,iroff1,iroff2,k,last,limit,maxerr,neval, - * nrmax -c - dimension alist(limit),blist(limit),elist(limit),iord(limit), - * rlist(limit) -c - external f -c -c list of major variables -c ----------------------- -c -c alist - list of left end points of all subintervals -c considered up to now -c blist - list of right end points of all subintervals -c considered up to now -c rlist(i) - approximation to the integral over -c (alist(i),blist(i)) -c elist(i) - error estimate applying to rlist(i) -c maxerr - pointer to the interval with largest -c error estimate -c errmax - elist(maxerr) -c area - sum of the integrals over the subintervals -c errsum - sum of the errors over the subintervals -c errbnd - requested accuracy max(epsabs,epsrel* -c abs(result)) -c *****1 - variable for the left subinterval -c *****2 - variable for the right subinterval -c last - index for subdivision -c -c -c machine dependent constants -c --------------------------- -c -c epmach is the largest relative spacing. -c uflow is the smallest positive magnitude. -c -c***first executable statement dqage - epmach = d1mach(4) - uflow = d1mach(1) -c -c test on validity of parameters -c ------------------------------ -c - ier = 0 - neval = 0 - last = 0 - result = 0.0d+00 - abserr = 0.0d+00 - alist(1) = a - blist(1) = b - rlist(1) = 0.0d+00 - elist(1) = 0.0d+00 - iord(1) = 0 - if(epsabs.le.0.0d+00.and. - * epsrel.lt.dmax1(0.5d+02*epmach,0.5d-28)) ier = 6 - if(ier.eq.6) go to 999 -c -c first approximation to the integral -c ----------------------------------- -c - neval = 0 - call dqk15(f,a,b,result,abserr,defabs,resabs) - last = 1 - rlist(1) = result - elist(1) = abserr - iord(1) = 1 -c -c test on accuracy. -c - errbnd = dmax1(epsabs,epsrel*dabs(result)) - if(abserr.le.0.5d+02*epmach*defabs.and.abserr.gt.errbnd) ier = 2 - if(limit.eq.1) ier = 1 - if(ier.ne.0.or.(abserr.le.errbnd.and.abserr.ne.resabs) - * .or.abserr.eq.0.0d+00) go to 60 -c -c initialization -c -------------- -c -c - errmax = abserr - maxerr = 1 - area = result - errsum = abserr - nrmax = 1 - iroff1 = 0 - iroff2 = 0 -c -c main do-loop -c ------------ -c - do 30 last = 2,limit -c -c bisect the subinterval with the largest error estimate. -c - a1 = alist(maxerr) - b1 = 0.5d+00*(alist(maxerr)+blist(maxerr)) - a2 = b1 - b2 = blist(maxerr) - call dqk15(f,a1,b1,area1,error1,resabs,defab1) - call dqk15(f,a2,b2,area2,error2,resabs,defab2) -c -c improve previous approximations to integral -c and error and test for accuracy. -c - neval = neval+1 - area12 = area1+area2 - erro12 = error1+error2 - errsum = errsum+erro12-errmax - area = area+area12-rlist(maxerr) - if(defab1.eq.error1.or.defab2.eq.error2) go to 5 - if(dabs(rlist(maxerr)-area12).le.0.1d-04*dabs(area12) - * .and.erro12.ge.0.99d+00*errmax) iroff1 = iroff1+1 - if(last.gt.10.and.erro12.gt.errmax) iroff2 = iroff2+1 - 5 rlist(maxerr) = area1 - rlist(last) = area2 - errbnd = dmax1(epsabs,epsrel*dabs(area)) - if(errsum.le.errbnd) go to 8 -c -c test for roundoff error and eventually set error flag. -c - if(iroff1.ge.6.or.iroff2.ge.20) ier = 2 -c -c set error flag in the case that the number of subintervals -c equals limit. -c - if(last.eq.limit) ier = 1 -c -c set error flag in the case of bad integrand behaviour -c at a point of the integration range. -c - if(dmax1(dabs(a1),dabs(b2)).le.(0.1d+01+0.1d+03* - * epmach)*(dabs(a2)+0.1d+04*uflow)) ier = 3 -c -c append the newly-created intervals to the list. -c - 8 if(error2.gt.error1) go to 10 - alist(last) = a2 - blist(maxerr) = b1 - blist(last) = b2 - elist(maxerr) = error1 - elist(last) = error2 - go to 20 - 10 alist(maxerr) = a2 - alist(last) = a1 - blist(last) = b1 - rlist(maxerr) = area2 - rlist(last) = area1 - elist(maxerr) = error2 - elist(last) = error1 -c -c call subroutine dqpsrt to maintain the descending ordering -c in the list of error estimates and select the subinterval -c with the largest error estimate (to be bisected next). -c - 20 call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) -c ***jump out of do-loop - if(ier.ne.0.or.errsum.le.errbnd) go to 40 - 30 continue -c -c compute final result. -c --------------------- -c - 40 result = 0.0d+00 - do 50 k=1,last - result = result+rlist(k) - 50 continue - abserr = errsum - 60 neval = 30*neval+15 - 999 return - end diff --git a/gcc/testsuite/g77.f-torture/compile/980310-6.f b/gcc/testsuite/g77.f-torture/compile/980310-6.f deleted file mode 100644 index fd91500eea8..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/980310-6.f +++ /dev/null @@ -1,21 +0,0 @@ -C From: Norbert Conrad <Norbert.Conrad@hrz.uni-giessen.de> -C Message-Id: <199711131008.LAA12272@marvin.hrz.uni-giessen.de> -C Subject: 971105 g77 bug -C To: egcs-bugs@cygnus.com -C Date: Thu, 13 Nov 1997 11:08:19 +0100 (CET) - -C I found a bug in g77 in snapshot 971105 - - subroutine ai (a) - dimension a(-1:*) - return - end -C ai.f: In subroutine `ai': -C ai.f:1: -C subroutine ai (a) -C ^ -C Array `a' at (^) is too large to handle -C -C This happens whenever the lower index boundary is negative and the upper index -C boundary is '*'. - diff --git a/gcc/testsuite/g77.f-torture/compile/980310-7.f b/gcc/testsuite/g77.f-torture/compile/980310-7.f deleted file mode 100644 index 9cfbaed692a..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/980310-7.f +++ /dev/null @@ -1,50 +0,0 @@ -C From: "David C. Doherty" <doherty@networkcs.com> -C Message-Id: <199711171846.MAA27947@uh.msc.edu> -C Subject: g77: auto arrays + goto = no go -C To: egcs-bugs@cygnus.com -C Date: Mon, 17 Nov 1997 12:46:27 -0600 (CST) - -C I sent the following to fortran@gnu.ai.mit.edu, and Dave Love -C replied that he was able to reproduce it on rs6000-aix; not on -C others. He suggested that I send it to egcs-bugs. - -C Hi - I've observed the following behavior regarding -C automatic arrays and gotos. Seems similar to what I found -C in the docs about computed gotos (but not exactly the same). -C -C I suspect from the nature of the error msg that it's in the GBE. -C -C I'm using egcs-971105, under linux-ppc. -C -C I also observed the same in g77-0.5.19 (and gcc 2.7.2?). -C -C I'd appreciate any advice on this. thanks for the great work. -C -- -C >cat testg77.f - subroutine testg77(n, a) -c - implicit none -c - integer n - real a(n) - real b(n) - integer i -c - do i = 1, 10 - if (i .gt. 4) goto 100 - write(0, '(i2)')i - enddo -c - goto 200 -100 continue -200 continue -c - return - end -C >g77 -c testg77.f -C testg77.f: In subroutine `testg77': -C testg77.f:19: label `200' used before containing binding contour -C testg77.f:18: label `100' used before containing binding contour -C -- -C If I comment out the b(n) line or replace it with, e.g., b(10), -C it compiles fine. diff --git a/gcc/testsuite/g77.f-torture/compile/980310-8.f b/gcc/testsuite/g77.f-torture/compile/980310-8.f deleted file mode 100644 index 9501012f60a..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/980310-8.f +++ /dev/null @@ -1,39 +0,0 @@ -C To: egcs-bugs@cygnus.com -C Subject: egcs-g77 and array indexing -C Reply-To: etseidl@jutland.ca.sandia.gov -C Date: Wed, 26 Nov 1997 10:38:27 -0800 -C From: Edward Seidl <etseidl@jutland.ca.sandia.gov> -C -C I have some horrible spaghetti code I'm trying compile with egcs-g77, -C but it's puking on code like the example below. I have no idea if it's -C legal fortran or not, and I'm in no position to change it. All I do know -C is it compiles with a number of other compilers, including f2c and -C g77-0.5.19.1/gcc-2.7.2.1. When I try to compile with egcs-2.90.18 971122 -C I get the following (on both i686-pc-linux-gnu and alphaev56-unknown-linux-gnu): -C -C foo.f: In subroutine `foobar': -C foo.f:11: -C subroutine foobar(norb,nnorb) -C ^ -C Array `norb' at (^) is too large to handle - - program foo - implicit integer(A-Z) - dimension norb(6) - nnorb=6 - - call foobar(norb,nnorb) - - stop - end - - subroutine foobar(norb,nnorb) - implicit integer(A-Z) - dimension norb(-1:*) - - do 10 i=-1,nnorb-2 - norb(i) = i+999 - 10 continue - - return - end diff --git a/gcc/testsuite/g77.f-torture/compile/980419-2.f b/gcc/testsuite/g77.f-torture/compile/980419-2.f deleted file mode 100644 index ac9134dc8a7..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/980419-2.f +++ /dev/null @@ -1,48 +0,0 @@ -c SEGVs in loop.c with -O2. - - character*80 function nxtlin(lun,ierr,itok) - character onechr*1,twochr*2,thrchr*3 - itok=0 - do while (.true.) - read (lun,'(a)',iostat=ierr) nxtlin - if (nxtlin(1:1).ne.'#') then - ito=0 - do 10 it=1,79 - if (nxtlin(it:it).ne.' ' .and. nxtlin(it+1:it+1).eq.' ') - $ then - itast=0 - itstrt=0 - do itt=ito+1,it - if (nxtlin(itt:itt).eq.'*') itast=itt - enddo - itstrt=ito+1 - do while (nxtlin(itstrt:itstrt).eq.' ') - itstrt=itstrt+1 - enddo - if (itast.gt.0) then - nchrs=itast-itstrt - if (nchrs.eq.1) then - onechr=nxtlin(itstrt:itstrt) - read (onechr,*) itokn - elseif (nchrs.eq.2) then - twochr=nxtlin(itstrt:itstrt+1) - read (twochr,*) itokn - elseif (nchrs.eq.3) then - thrchr=nxtlin(itstrt:itstrt+2) - read (thrchr,*) itokn - elseif (nchrs.eq.4) then - thrchr=nxtlin(itstrt:itstrt+3) - read (thrchr,*) itokn - endif - itok=itok+itokn - else - itok=itok+1 - endif - ito=it+1 - endif - 10 continue - return - endif - enddo - return - end diff --git a/gcc/testsuite/g77.f-torture/compile/980424-0.f b/gcc/testsuite/g77.f-torture/compile/980424-0.f deleted file mode 100644 index 5df45bb79a9..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/980424-0.f +++ /dev/null @@ -1,6 +0,0 @@ -C crashes in subst_stack_regs_pat on x86-linux, in the "abort();" -C within the switch statement. - SUBROUTINE C(A) - COMPLEX A - WRITE(*,*) A.NE.CMPLX(0.0D0) - END diff --git a/gcc/testsuite/g77.f-torture/compile/980427-0.f b/gcc/testsuite/g77.f-torture/compile/980427-0.f deleted file mode 100644 index d5d7d74c57b..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/980427-0.f +++ /dev/null @@ -1,8 +0,0 @@ -c ../../egcs/gcc/f/com.c:938: failed assertion `TREE_CODE (TREE_TYPE (e)) == REAL_TYPE' -c Fixed by 28-04-1998 global.c (ffeglobal_ref_progunit_) change. - external b - call y(b) - end - subroutine x - a = b() - end diff --git a/gcc/testsuite/g77.f-torture/compile/980729-0.f b/gcc/testsuite/g77.f-torture/compile/980729-0.f deleted file mode 100644 index 07789441d41..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/980729-0.f +++ /dev/null @@ -1,5 +0,0 @@ -c Got ICE on Alpha only with -mieee (currently not tested). -c Fixed by rth 1998-07-30 alpha.md change. - subroutine a(b,c) - b = max(b,c) - end diff --git a/gcc/testsuite/g77.f-torture/compile/981117-1.f b/gcc/testsuite/g77.f-torture/compile/981117-1.f deleted file mode 100644 index 019167064fa..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/981117-1.f +++ /dev/null @@ -1,23 +0,0 @@ -* egcs-bugs: -* From: Martin Kahlert <martin.kahlert@mchp.siemens.de> -* Subject: ICE in g77 from egcs-19981109 -* Message-Id: <199811101134.MAA29838@keksy.mchp.siemens.de> - -* As of 1998-11-17, fails -O2 -fomit-frame-pointer with -* egcs/gcc/testsuite/g77.f-torture/compile/981117-1.f:8: internal error--insn does not satisfy its constraints: -* (insn 31 83 32 (set (reg:SF 8 %st(0)) -* (mult:SF (reg:SF 8 %st(0)) -* (const_double:SF (mem/u:SF (symbol_ref/u:SI ("*.LC1")) 0) 0 0 1073643520))) 350 {strlensi-3} (nil) -* (nil)) -* ../../egcs/gcc/toplev.c:1390: Internal compiler error in function fatal_insn - -* Fixed sometime before 1998-11-21 -- don't know by which change. - - SUBROUTINE SSPTRD - PARAMETER (HALF = 0.5 ) - DO I = 1, N - CALL SSPMV(TAUI) - ALPHA = -HALF*TAUI - CALL SAXPY(ALPHA) - ENDDO - END diff --git a/gcc/testsuite/g77.f-torture/compile/990115-1.f b/gcc/testsuite/g77.f-torture/compile/990115-1.f deleted file mode 100644 index 187e1b463b5..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/990115-1.f +++ /dev/null @@ -1,8 +0,0 @@ -C Derived from lapack - SUBROUTINE ZGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, - $ WORK, RWORK, INFO ) - COMPLEX*16 WORK( * ) - DO 20 I = 1, RANK - WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 ) - 20 CONTINUE - END diff --git a/gcc/testsuite/g77.f-torture/compile/alpha1.f b/gcc/testsuite/g77.f-torture/compile/alpha1.f deleted file mode 100644 index 7cda74ebd45..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/alpha1.f +++ /dev/null @@ -1,10 +0,0 @@ - REAL*8 A,B,C - REAL*4 RARRAY(19)/19*(-1)/ - INTEGER BOTTOM,RIGHT - INTEGER IARRAY(19)/0,0,0,0,0,0,0,0,0,0,0,0,13,14,0,0,0,0,0/ - EQUIVALENCE (RARRAY(13),BOTTOM),(RARRAY(14),RIGHT) -C - IF(I.NE.0) call exit(1) -C gcc: Internal compiler error: program f771 got fatal signal 11 -C at this point! - END diff --git a/gcc/testsuite/g77.f-torture/compile/compile.exp b/gcc/testsuite/g77.f-torture/compile/compile.exp deleted file mode 100644 index a2a2177a94f..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/compile.exp +++ /dev/null @@ -1,44 +0,0 @@ -# Expect driver script for GCC Regression Tests -# Copyright (C) 1993, 1995, 1997 Free Software Foundation -# -# This file 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 2 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 this program; if not, write to the Free Software -# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -# These tests come from Torbjorn Granlund's (tege@cygnus.com) -# F torture test suite, and other contributors. - -if $tracelevel then { - strace $tracelevel -} - -# load support procs -load_lib f-torture.exp - -foreach testcase [glob -nocomplain $srcdir/$subdir/*.f] { - # If we're only testing specific files and this isn't one of them, skip it. - if ![runtest_file_p $runtests $testcase] then { - continue - } - - f-torture $testcase -} - -foreach testcase [glob -nocomplain $srcdir/$subdir/*.F] { - # If we're only testing specific files and this isn't one of them, skip it. - if ![runtest_file_p $runtests $testcase] then { - continue - } - - f-torture $testcase -} diff --git a/gcc/testsuite/g77.f-torture/compile/toon_1.f b/gcc/testsuite/g77.f-torture/compile/toon_1.f deleted file mode 100644 index 6b6847c4de5..00000000000 --- a/gcc/testsuite/g77.f-torture/compile/toon_1.f +++ /dev/null @@ -1,3 +0,0 @@ - SUBROUTINE AAP(NOOT) - DIMENSION NOOT(*) - END diff --git a/gcc/testsuite/g77.f-torture/execute/19981119-0.f b/gcc/testsuite/g77.f-torture/execute/19981119-0.f deleted file mode 100644 index 5cfab57a5fc..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/19981119-0.f +++ /dev/null @@ -1,40 +0,0 @@ -* X-Delivered: at request of burley on mescaline.gnu.org -* Date: Sat, 31 Oct 1998 18:26:29 +0200 (EET) -* From: "B. Yanchitsky" <yan@im.imag.kiev.ua> -* To: fortran@gnu.org -* Subject: Bug report -* MIME-Version: 1.0 -* Content-Type: TEXT/PLAIN; charset=US-ASCII -* -* There is a trouble with g77 on Alpha. -* My configuration: -* Digital Personal Workstation 433au, -* Digital Unix 4.0D, -* GNU Fortran 0.5.23 and GNU C 2.8.1. -* -* The following program treated successfully but crashed when running. -* -* C --- PROGRAM BEGIN ------- -* - subroutine sub(N,u) - integer N - double precision u(-N:N,-N:N) - -C vvvv CRASH HERE vvvvv - u(-N,N)=0d0 - return - end - - - program bug - integer N - double precision a(-10:10,-10:10) - data a/441*1d0/ - N=10 - call sub(N,a) - if (a(-N,N) .ne. 0d0) call abort - end -* -* C --- PROGRAM END ------- -* -* Good luck! diff --git a/gcc/testsuite/g77.f-torture/execute/19990313-0.f b/gcc/testsuite/g77.f-torture/execute/19990313-0.f deleted file mode 100644 index abf898fb793..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/19990313-0.f +++ /dev/null @@ -1,33 +0,0 @@ -* To: craig@jcb-sc.com -* Subject: Re: G77 and KIND=2 -* Content-Type: text/plain; charset=us-ascii -* From: Dave Love <d.love@dl.ac.uk> -* Date: 03 Mar 1999 18:20:11 +0000 -* In-Reply-To: craig@jcb-sc.com's message of "1 Mar 1999 21:04:38 -0000" -* User-Agent: Gnus/5.07007 (Pterodactyl Gnus v0.70) Emacs/20.3 -* X-UIDL: d442bafe961c2a6ec6904f492e05d7b0 -* -* ISTM that there is a real problem printing integer*8 (on x86): -* -* $ cat x.f -*[modified for test suite] - integer *8 foo, bar - data r/4e10/ - foo = 4e10 - bar = r - if (foo .ne. bar) call abort - end -* $ g77 x.f && ./a.out -* 1345294336 -* 123 -* $ f2c x.f && g77 x.c && ./a.out -* x.f: -* MAIN: -* 40000000000 -* 123 -* $ -* -* Gdb shows the upper half of the buffer passed to do_lio is zeroed in -* the g77 case. -* -* I've forgotten how the code generation happens. diff --git a/gcc/testsuite/g77.f-torture/execute/19990313-1.f b/gcc/testsuite/g77.f-torture/execute/19990313-1.f deleted file mode 100644 index d99c72f2fde..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/19990313-1.f +++ /dev/null @@ -1,7 +0,0 @@ - integer *8 foo, bar - double precision r - data r/4d10/ - foo = 4d10 - bar = r - if (foo .ne. bar) call abort - end diff --git a/gcc/testsuite/g77.f-torture/execute/19990313-2.f b/gcc/testsuite/g77.f-torture/execute/19990313-2.f deleted file mode 100644 index ffb7549d413..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/19990313-2.f +++ /dev/null @@ -1,7 +0,0 @@ - integer *8 foo, bar - complex c - data c/(4e10,0)/ - foo = 4e10 - bar = c - if (foo .ne. bar) call abort - end diff --git a/gcc/testsuite/g77.f-torture/execute/19990313-3.f b/gcc/testsuite/g77.f-torture/execute/19990313-3.f deleted file mode 100644 index 6366dccd890..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/19990313-3.f +++ /dev/null @@ -1,7 +0,0 @@ - integer *8 foo, bar - double complex c - data c/(4d10,0)/ - foo = 4d10 - bar = c - if (foo .ne. bar) call abort - end diff --git a/gcc/testsuite/g77.f-torture/execute/19990325-0.f b/gcc/testsuite/g77.f-torture/execute/19990325-0.f deleted file mode 100644 index a230362fdde..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/19990325-0.f +++ /dev/null @@ -1,313 +0,0 @@ -* test whether complex operators properly handle -* full and partial aliasing. -* (libf2c/libF77 routines used to assume no aliasing, -* then were changed to accommodate full aliasing, while -* the libg2c/libF77 versions were changed to accommodate -* both full and partial aliasing.) -* -* NOTE: this (19990325-0.f) is the single-precision version. -* See 19990325-1.f for the double-precision version. - - program complexalias - implicit none - -* Make sure non-aliased cases work. (Catch roundoff/precision -* problems, etc., here. Modify subroutine check if they occur.) - - call tryfull (1, 3, 5) - -* Now check various combinations of aliasing. - -* Full aliasing. - call tryfull (1, 1, 5) - -* Partial aliasing. - call trypart (2, 3, 5) - call trypart (2, 1, 5) - call trypart (2, 5, 3) - call trypart (2, 5, 1) - - end - - subroutine tryfull (xout, xin1, xin2) - implicit none - integer xout, xin1, xin2 - -* out, in1, and in2 are the desired indexes into the REAL array (array). - - complex expect - integer pwr - integer out, in1, in2 - - real array(6) - complex carray(3) - equivalence (carray(1), array(1)) - -* Make sure the indexes can be accommodated by the equivalences above. - - if (mod (xout, 2) .ne. 1) call abort - if (mod (xin1, 2) .ne. 1) call abort - if (mod (xin2, 2) .ne. 1) call abort - -* Convert the indexes into ones suitable for the COMPLEX array (carray). - - out = (xout + 1) / 2 - in1 = (xin1 + 1) / 2 - in2 = (xin2 + 1) / 2 - -* Check some open-coded stuff, just in case. - - call prepare1 (carray(in1)) - expect = + carray(in1) - carray(out) = + carray(in1) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = - carray(in1) - carray(out) = - carray(in1) - call check (expect, carray(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) + carray(in2) - carray(out) = carray(in1) + carray(in2) - call check (expect, carray(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) - carray(in2) - carray(out) = carray(in1) - carray(in2) - call check (expect, carray(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) * carray(in2) - carray(out) = carray(in1) * carray(in2) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = carray(in1) ** 2 - carray(out) = carray(in1) ** 2 - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = carray(in1) ** 3 - carray(out) = carray(in1) ** 3 - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = abs (carray(in1)) - array(out*2-1) = abs (carray(in1)) - array(out*2) = 0 - call check (expect, carray(out)) - -* Now check the stuff implemented in libF77. - - call prepare1 (carray(in1)) - expect = cos (carray(in1)) - carray(out) = cos (carray(in1)) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = exp (carray(in1)) - carray(out) = exp (carray(in1)) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = log (carray(in1)) - carray(out) = log (carray(in1)) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = sin (carray(in1)) - carray(out) = sin (carray(in1)) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = sqrt (carray(in1)) - carray(out) = sqrt (carray(in1)) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = conjg (carray(in1)) - carray(out) = conjg (carray(in1)) - call check (expect, carray(out)) - - call prepare1i (carray(in1), pwr) - expect = carray(in1) ** pwr - carray(out) = carray(in1) ** pwr - call check (expect, carray(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) / carray(in2) - carray(out) = carray(in1) / carray(in2) - call check (expect, carray(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) ** carray(in2) - carray(out) = carray(in1) ** carray(in2) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = carray(in1) ** .2 - carray(out) = carray(in1) ** .2 - call check (expect, carray(out)) - - end - - subroutine trypart (xout, xin1, xin2) - implicit none - integer xout, xin1, xin2 - -* out, in1, and in2 are the desired indexes into the REAL array (array). - - complex expect - integer pwr - integer out, in1, in2 - - real array(6) - complex carray(3), carrayp(2) - equivalence (carray(1), array(1)) - equivalence (carrayp(1), array(2)) - -* Make sure the indexes can be accommodated by the equivalences above. - - if (mod (xout, 2) .ne. 0) call abort - if (mod (xin1, 2) .ne. 1) call abort - if (mod (xin2, 2) .ne. 1) call abort - -* Convert the indexes into ones suitable for the COMPLEX array (carray). - - out = xout / 2 - in1 = (xin1 + 1) / 2 - in2 = (xin2 + 1) / 2 - -* Check some open-coded stuff, just in case. - - call prepare1 (carray(in1)) - expect = + carray(in1) - carrayp(out) = + carray(in1) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = - carray(in1) - carrayp(out) = - carray(in1) - call check (expect, carrayp(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) + carray(in2) - carrayp(out) = carray(in1) + carray(in2) - call check (expect, carrayp(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) - carray(in2) - carrayp(out) = carray(in1) - carray(in2) - call check (expect, carrayp(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) * carray(in2) - carrayp(out) = carray(in1) * carray(in2) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = carray(in1) ** 2 - carrayp(out) = carray(in1) ** 2 - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = carray(in1) ** 3 - carrayp(out) = carray(in1) ** 3 - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = abs (carray(in1)) - array(out*2) = abs (carray(in1)) - array(out*2+1) = 0 - call check (expect, carrayp(out)) - -* Now check the stuff implemented in libF77. - - call prepare1 (carray(in1)) - expect = cos (carray(in1)) - carrayp(out) = cos (carray(in1)) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = exp (carray(in1)) - carrayp(out) = exp (carray(in1)) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = log (carray(in1)) - carrayp(out) = log (carray(in1)) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = sin (carray(in1)) - carrayp(out) = sin (carray(in1)) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = sqrt (carray(in1)) - carrayp(out) = sqrt (carray(in1)) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = conjg (carray(in1)) - carrayp(out) = conjg (carray(in1)) - call check (expect, carrayp(out)) - - call prepare1i (carray(in1), pwr) - expect = carray(in1) ** pwr - carrayp(out) = carray(in1) ** pwr - call check (expect, carrayp(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) / carray(in2) - carrayp(out) = carray(in1) / carray(in2) - call check (expect, carrayp(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) ** carray(in2) - carrayp(out) = carray(in1) ** carray(in2) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = carray(in1) ** .2 - carrayp(out) = carray(in1) ** .2 - call check (expect, carrayp(out)) - - end - - subroutine prepare1 (in) - implicit none - complex in - - in = (3.2, 4.2) - - end - - subroutine prepare1i (in, i) - implicit none - complex in - integer i - - in = (2.3, 2.5) - i = 4 - - end - - subroutine prepare2 (in1, in2) - implicit none - complex in1, in2 - - in1 = (1.3, 2.4) - in2 = (3.5, 7.1) - - end - - subroutine check (expect, got) - implicit none - complex expect, got - - if (aimag(expect) .ne. aimag(got)) call abort - if (real(expect) .ne. real(got)) call abort - - end diff --git a/gcc/testsuite/g77.f-torture/execute/19990325-1.f b/gcc/testsuite/g77.f-torture/execute/19990325-1.f deleted file mode 100644 index 802f375b33d..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/19990325-1.f +++ /dev/null @@ -1,313 +0,0 @@ -* test whether complex operators properly handle -* full and partial aliasing. -* (libf2c/libF77 routines used to assume no aliasing, -* then were changed to accommodate full aliasing, while -* the libg2c/libF77 versions were changed to accommodate -* both full and partial aliasing.) -* -* NOTE: this (19990325-1.f) is the double-precision version. -* See 19990325-0.f for the single-precision version. - - program doublecomplexalias - implicit none - -* Make sure non-aliased cases work. (Catch roundoff/precision -* problems, etc., here. Modify subroutine check if they occur.) - - call tryfull (1, 3, 5) - -* Now check various combinations of aliasing. - -* Full aliasing. - call tryfull (1, 1, 5) - -* Partial aliasing. - call trypart (2, 3, 5) - call trypart (2, 1, 5) - call trypart (2, 5, 3) - call trypart (2, 5, 1) - - end - - subroutine tryfull (xout, xin1, xin2) - implicit none - integer xout, xin1, xin2 - -* out, in1, and in2 are the desired indexes into the REAL array (array). - - double complex expect - integer pwr - integer out, in1, in2 - - double precision array(6) - double complex carray(3) - equivalence (carray(1), array(1)) - -* Make sure the indexes can be accommodated by the equivalences above. - - if (mod (xout, 2) .ne. 1) call abort - if (mod (xin1, 2) .ne. 1) call abort - if (mod (xin2, 2) .ne. 1) call abort - -* Convert the indexes into ones suitable for the COMPLEX array (carray). - - out = (xout + 1) / 2 - in1 = (xin1 + 1) / 2 - in2 = (xin2 + 1) / 2 - -* Check some open-coded stuff, just in case. - - call prepare1 (carray(in1)) - expect = + carray(in1) - carray(out) = + carray(in1) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = - carray(in1) - carray(out) = - carray(in1) - call check (expect, carray(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) + carray(in2) - carray(out) = carray(in1) + carray(in2) - call check (expect, carray(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) - carray(in2) - carray(out) = carray(in1) - carray(in2) - call check (expect, carray(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) * carray(in2) - carray(out) = carray(in1) * carray(in2) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = carray(in1) ** 2 - carray(out) = carray(in1) ** 2 - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = carray(in1) ** 3 - carray(out) = carray(in1) ** 3 - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = abs (carray(in1)) - array(out*2-1) = abs (carray(in1)) - array(out*2) = 0 - call check (expect, carray(out)) - -* Now check the stuff implemented in libF77. - - call prepare1 (carray(in1)) - expect = cos (carray(in1)) - carray(out) = cos (carray(in1)) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = exp (carray(in1)) - carray(out) = exp (carray(in1)) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = log (carray(in1)) - carray(out) = log (carray(in1)) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = sin (carray(in1)) - carray(out) = sin (carray(in1)) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = sqrt (carray(in1)) - carray(out) = sqrt (carray(in1)) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = conjg (carray(in1)) - carray(out) = conjg (carray(in1)) - call check (expect, carray(out)) - - call prepare1i (carray(in1), pwr) - expect = carray(in1) ** pwr - carray(out) = carray(in1) ** pwr - call check (expect, carray(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) / carray(in2) - carray(out) = carray(in1) / carray(in2) - call check (expect, carray(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) ** carray(in2) - carray(out) = carray(in1) ** carray(in2) - call check (expect, carray(out)) - - call prepare1 (carray(in1)) - expect = carray(in1) ** .2 - carray(out) = carray(in1) ** .2 - call check (expect, carray(out)) - - end - - subroutine trypart (xout, xin1, xin2) - implicit none - integer xout, xin1, xin2 - -* out, in1, and in2 are the desired indexes into the REAL array (array). - - double complex expect - integer pwr - integer out, in1, in2 - - double precision array(6) - double complex carray(3), carrayp(2) - equivalence (carray(1), array(1)) - equivalence (carrayp(1), array(2)) - -* Make sure the indexes can be accommodated by the equivalences above. - - if (mod (xout, 2) .ne. 0) call abort - if (mod (xin1, 2) .ne. 1) call abort - if (mod (xin2, 2) .ne. 1) call abort - -* Convert the indexes into ones suitable for the COMPLEX array (carray). - - out = xout / 2 - in1 = (xin1 + 1) / 2 - in2 = (xin2 + 1) / 2 - -* Check some open-coded stuff, just in case. - - call prepare1 (carray(in1)) - expect = + carray(in1) - carrayp(out) = + carray(in1) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = - carray(in1) - carrayp(out) = - carray(in1) - call check (expect, carrayp(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) + carray(in2) - carrayp(out) = carray(in1) + carray(in2) - call check (expect, carrayp(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) - carray(in2) - carrayp(out) = carray(in1) - carray(in2) - call check (expect, carrayp(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) * carray(in2) - carrayp(out) = carray(in1) * carray(in2) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = carray(in1) ** 2 - carrayp(out) = carray(in1) ** 2 - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = carray(in1) ** 3 - carrayp(out) = carray(in1) ** 3 - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = abs (carray(in1)) - array(out*2) = abs (carray(in1)) - array(out*2+1) = 0 - call check (expect, carrayp(out)) - -* Now check the stuff implemented in libF77. - - call prepare1 (carray(in1)) - expect = cos (carray(in1)) - carrayp(out) = cos (carray(in1)) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = exp (carray(in1)) - carrayp(out) = exp (carray(in1)) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = log (carray(in1)) - carrayp(out) = log (carray(in1)) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = sin (carray(in1)) - carrayp(out) = sin (carray(in1)) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = sqrt (carray(in1)) - carrayp(out) = sqrt (carray(in1)) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = conjg (carray(in1)) - carrayp(out) = conjg (carray(in1)) - call check (expect, carrayp(out)) - - call prepare1i (carray(in1), pwr) - expect = carray(in1) ** pwr - carrayp(out) = carray(in1) ** pwr - call check (expect, carrayp(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) / carray(in2) - carrayp(out) = carray(in1) / carray(in2) - call check (expect, carrayp(out)) - - call prepare2 (carray(in1), carray(in2)) - expect = carray(in1) ** carray(in2) - carrayp(out) = carray(in1) ** carray(in2) - call check (expect, carrayp(out)) - - call prepare1 (carray(in1)) - expect = carray(in1) ** .2 - carrayp(out) = carray(in1) ** .2 - call check (expect, carrayp(out)) - - end - - subroutine prepare1 (in) - implicit none - double complex in - - in = (3.2d0, 4.2d0) - - end - - subroutine prepare1i (in, i) - implicit none - double complex in - integer i - - in = (2.3d0, 2.5d0) - i = 4 - - end - - subroutine prepare2 (in1, in2) - implicit none - double complex in1, in2 - - in1 = (1.3d0, 2.4d0) - in2 = (3.5d0, 7.1d0) - - end - - subroutine check (expect, got) - implicit none - double complex expect, got - - if (dimag(expect) .ne. dimag(got)) call abort - if (dble(expect) .ne. dble(got)) call abort - - end diff --git a/gcc/testsuite/g77.f-torture/execute/19990419-1.f b/gcc/testsuite/g77.f-torture/execute/19990419-1.f deleted file mode 100644 index 7449bac2b95..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/19990419-1.f +++ /dev/null @@ -1,21 +0,0 @@ -* Test DO WHILE, to make sure it fully reevaluates its expression. -* Belongs in execute/. - common /x/ ival - j = 0 - do while (i() .eq. 1) - j = j + 1 - if (j .gt. 5) call abort - end do - if (j .ne. 4) call abort - if (ival .ne. 5) call abort - end - function i() - common /x/ ival - ival = ival + 1 - i = 10 - if (ival .lt. 5) i = 1 - end - block data - common /x/ ival - data ival/0/ - end diff --git a/gcc/testsuite/g77.f-torture/execute/970625-2.f b/gcc/testsuite/g77.f-torture/execute/970625-2.f deleted file mode 100644 index 3ef6f46cb79..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/970625-2.f +++ /dev/null @@ -1,84 +0,0 @@ -* Date: Wed, 25 Jun 1997 12:48:26 +0200 (MET DST) -* MIME-Version: 1.0 -* From: R.Hooft@EuroMail.com (Rob Hooft) -* To: g77-alpha@gnu.ai.mit.edu -* Subject: Re: testing 970624. -* In-Reply-To: <199706251027.GAA07892@churchy.gnu.ai.mit.edu> -* References: <199706251018.MAA21538@nu> -* <199706251027.GAA07892@churchy.gnu.ai.mit.edu> -* X-Mailer: VM 6.30 under Emacs 19.34.1 -* Content-Type: text/plain; charset=US-ASCII -* -* >>>>> "CB" == Craig Burley <burley@gnu.ai.mit.edu> writes: -* -* CB> but OTOH I'd like to see more problems like this on other -* CB> applications, and especially other systems -* -* How about this one: An application that prints "112." on all -* compilers/platforms I have tested, except with the new g77 on ALPHA (I -* don't have the new g77 on any other platform here to test)? -* -* Application Appended. Source code courtesy of my boss..... -* Disclaimer: I do not know the right answer, or even whether there is a -* single right answer..... -* -* Regards, -* -- -* ===== R.Hooft@EuroMail.com http://www.Sander.EMBL-Heidelberg.DE/rob/ == -* ==== In need of protein modeling? http://www.Sander.EMBL-Heidelberg.DE/whatif/ -* Validation of protein structures? http://biotech.EMBL-Heidelberg.DE:8400/ ==== -* == PGPid 0xFA19277D == Use Linux! Free Software Rules The World! ============= -* -* nu[152]for% cat humor.f - PROGRAM SUBROUTINE - LOGICAL ELSE IF - INTEGER REAL, GO TO PROGRAM, WHILE - REAL FORMAT(2) - DATA IF,REAL,END DO,WHILE,FORMAT(2),I2/2,6,7,1,112.,1/ - DO THEN=1, END DO, WHILE - CALL = END DO - IF - PROGRAM = THEN - IF - ELSE IF = THEN .GT. IF - IF (THEN.GT.REAL) THEN - CALL FUNCTION PROGRAM (ELSE IF, GO TO PROGRAM, THEN) - ELSE IF (ELSE IF) THEN - REAL = THEN + END DO - END IF - END DO - 10 FORMAT(I2/I2) = WHILE*REAL*THEN - IF (FORMAT(I2) .NE. FORMAT(I2+I2)) CALL ABORT - END ! DO - SUBROUTINE FUNCTION PROGRAM (REAL,INTEGER, LOGICAL) - LOGICAL REAL - REAL LOGICAL - INTEGER INTEGER, STOP, RETURN, GO TO - ASSIGN 9 TO STOP - ASSIGN = 9 + LOGICAL - ASSIGN 7 TO RETURN - ASSIGN 9 TO GO TO - GO TO = 5 - STOP = 8 - IF (.NOT.REAL) GOTO STOP - IF (LOGICAL.GT.INTEGER) THEN - IF = LOGICAL +5 - IF (LOGICAL.EQ.5) ASSIGN 5 TO IF - INTEGER=IF - ELSE - IF (ASSIGN.GT.STOP) ASSIGN 9 TO GOTO - ELSE = GO TO - END IF = ELSE + GO TO - IF (.NOT.REAL.AND.GOTO.GT.ELSE) GOTO RETURN - END IF - 5 CONTINUE - 7 LOGICAL=LOGICAL+STOP - 9 RETURN - END ! IF -* nu[153]for% f77 humor.f -* nu[154]for% ./a.out -* 112.0000 -* nu[155]for% f90 humor.f -* nu[156]for% ./a.out -* 112.0000 -* nu[157]for% g77 humor.f -* nu[158]for% ./a.out -* 40. diff --git a/gcc/testsuite/g77.f-torture/execute/970816-3.f b/gcc/testsuite/g77.f-torture/execute/970816-3.f deleted file mode 100644 index 6398600f059..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/970816-3.f +++ /dev/null @@ -1,20 +0,0 @@ -* Date: Wed, 13 Aug 1997 15:34:23 +0200 (METDST) -* From: Claus Denk <denk@cica.es> -* To: g77-alpha@gnu.ai.mit.edu -* Subject: 970811 report - segfault bug on alpha still there -*[...] -* Now, the bug that I reported some weeks ago is still there, I'll post -* the test program again: -* - PROGRAM TEST -C a bug in g77-0.5.21 - alpha. Works with NSTART=0 and segfaults with -C NSTART=1 on the second write. - PARAMETER (NSTART=1,NADD=NSTART+1) - REAL AB(NSTART:NSTART) - AB(NSTART)=1.0 - I=1 - J=2 - IND=I-J+NADD - write(*,*) AB(IND) - write(*,*) AB(I-J+NADD) - END diff --git a/gcc/testsuite/g77.f-torture/execute/971102-1.f b/gcc/testsuite/g77.f-torture/execute/971102-1.f deleted file mode 100644 index 6b0c2f3b3a9..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/971102-1.f +++ /dev/null @@ -1,11 +0,0 @@ - i=3 - j=0 - do i=i,5 - j = j+i - end do - do i=3,i - j = j+i - end do - if (i.ne.7) call abort() - print *, i,j - end diff --git a/gcc/testsuite/g77.f-torture/execute/980520-1.f b/gcc/testsuite/g77.f-torture/execute/980520-1.f deleted file mode 100644 index 6d05c6767fd..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980520-1.f +++ /dev/null @@ -1,6 +0,0 @@ -c Produced a link error through not eliminating the unused statement -c function after 1998-05-15 change to gcc/toplev.c. It's in -c `execute' since it needs to link. -c Fixed by 1998-05-23 change to f/com.c. - values(i,j) = val((i-1)*n+j) - end diff --git a/gcc/testsuite/g77.f-torture/execute/980628-0.f b/gcc/testsuite/g77.f-torture/execute/980628-0.f deleted file mode 100644 index c36b1efc052..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-0.f +++ /dev/null @@ -1,61 +0,0 @@ -* g77 0.5.23 and previous had bugs involving too little space -* allocated for EQUIVALENCE and COMMON areas needing initial -* padding to meet alignment requirements of the system. - - call subr - end - - subroutine subr - implicit none - - real r1(5), r2(5), r3(5) - double precision d1, d2, d3 - integer i1, i2, i3 - equivalence (r1(2), d1) - equivalence (r2(2), d2) - equivalence (r3(2), d3) - - r1(1) = 1. - d1 = 10. - r1(4) = 1. - r1(5) = 1. - i1 = 1 - r2(1) = 2. - d2 = 20. - r2(4) = 2. - r2(5) = 2. - i2 = 2 - r3(1) = 3. - d3 = 30. - r3(4) = 3. - r3(5) = 3. - i3 = 3 - - call x (r1, d1, i1, r2, d2, i2, r3, d3, i3) - - end - - subroutine x (r1, d1, i1, r2, d2, i2, r3, d3, i3) - implicit none - - real r1(5), r2(5), r3(5) - double precision d1, d2, d3 - integer i1, i2, i3 - - if (r1(1) .ne. 1.) call abort - if (d1 .ne. 10.) call abort - if (r1(4) .ne. 1.) call abort - if (r1(5) .ne. 1.) call abort - if (i1 .ne. 1) call abort - if (r2(1) .ne. 2.) call abort - if (d2 .ne. 20.) call abort - if (r2(4) .ne. 2.) call abort - if (r2(5) .ne. 2.) call abort - if (i2 .ne. 2) call abort - if (r3(1) .ne. 3.) call abort - if (d3 .ne. 30.) call abort - if (r3(4) .ne. 3.) call abort - if (r3(5) .ne. 3.) call abort - if (i3 .ne. 3) call abort - - end diff --git a/gcc/testsuite/g77.f-torture/execute/980628-1.f b/gcc/testsuite/g77.f-torture/execute/980628-1.f deleted file mode 100644 index 6ab0a0a81a8..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-1.f +++ /dev/null @@ -1,62 +0,0 @@ -* g77 0.5.23 and previous had bugs involving too little space -* allocated for EQUIVALENCE and COMMON areas needing initial -* padding to meet alignment requirements of the system. - - call subr - end - - subroutine subr - implicit none - save - - real r1(5), r2(5), r3(5) - double precision d1, d2, d3 - integer i1, i2, i3 - equivalence (r1(2), d1) - equivalence (r2(2), d2) - equivalence (r3(2), d3) - - r1(1) = 1. - d1 = 10. - r1(4) = 1. - r1(5) = 1. - i1 = 1 - r2(1) = 2. - d2 = 20. - r2(4) = 2. - r2(5) = 2. - i2 = 2 - r3(1) = 3. - d3 = 30. - r3(4) = 3. - r3(5) = 3. - i3 = 3 - - call x (r1, d1, i1, r2, d2, i2, r3, d3, i3) - - end - - subroutine x (r1, d1, i1, r2, d2, i2, r3, d3, i3) - implicit none - - real r1(5), r2(5), r3(5) - double precision d1, d2, d3 - integer i1, i2, i3 - - if (r1(1) .ne. 1.) call abort - if (d1 .ne. 10.) call abort - if (r1(4) .ne. 1.) call abort - if (r1(5) .ne. 1.) call abort - if (i1 .ne. 1) call abort - if (r2(1) .ne. 2.) call abort - if (d2 .ne. 20.) call abort - if (r2(4) .ne. 2.) call abort - if (r2(5) .ne. 2.) call abort - if (i2 .ne. 2) call abort - if (r3(1) .ne. 3.) call abort - if (d3 .ne. 30.) call abort - if (r3(4) .ne. 3.) call abort - if (r3(5) .ne. 3.) call abort - if (i3 .ne. 3) call abort - - end diff --git a/gcc/testsuite/g77.f-torture/execute/980628-10.f b/gcc/testsuite/g77.f-torture/execute/980628-10.f deleted file mode 100644 index 427f635add9..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-10.f +++ /dev/null @@ -1,57 +0,0 @@ -* g77 0.5.23 and previous had bugs involving too little space -* allocated for EQUIVALENCE and COMMON areas needing initial -* padding to meet alignment requirements of the system. - - call subr - end - - subroutine subr - implicit none - save - - character c1(11), c2(11), c3(11) - real r1, r2, r3 - character c4, c5, c6 - equivalence (r1, c1(2)) - equivalence (r2, c2(2)) - equivalence (r3, c3(2)) - - c1(1) = '1' - r1 = 1. - c1(11) = '1' - c4 = '4' - c2(1) = '2' - r2 = 2. - c2(11) = '2' - c5 = '5' - c3(1) = '3' - r3 = 3. - c3(11) = '3' - c6 = '6' - - call x (c1, r1, c2, r2, c3, r3, c4, c5, c6) - - end - - subroutine x (c1, r1, c2, r2, c3, r3, c4, c5, c6) - implicit none - - character c1(11), c2(11), c3(11) - real r1, r2, r3 - character c4, c5, c6 - - if (c1(1) .ne. '1') call abort - if (r1 .ne. 1.) call abort - if (c1(11) .ne. '1') call abort - if (c4 .ne. '4') call abort - if (c2(1) .ne. '2') call abort - if (r2 .ne. 2.) call abort - if (c2(11) .ne. '2') call abort - if (c5 .ne. '5') call abort - if (c3(1) .ne. '3') call abort - if (r3 .ne. 3.) call abort - if (c3(11) .ne. '3') call abort - if (c6 .ne. '6') call abort - - end - diff --git a/gcc/testsuite/g77.f-torture/execute/980628-2.f b/gcc/testsuite/g77.f-torture/execute/980628-2.f deleted file mode 100644 index a140e7db611..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-2.f +++ /dev/null @@ -1,55 +0,0 @@ -* g77 0.5.23 and previous had bugs involving too little space -* allocated for EQUIVALENCE and COMMON areas needing initial -* padding to meet alignment requirements of the system. - - call subr - end - - subroutine subr - implicit none - - character c1(11), c2(11), c3(11) - real r1, r2, r3 - character c4, c5, c6 - equivalence (c1(2), r1) - equivalence (c2(2), r2) - equivalence (c3(2), r3) - - c1(1) = '1' - r1 = 1. - c1(11) = '1' - c4 = '4' - c2(1) = '2' - r2 = 2. - c2(11) = '2' - c5 = '5' - c3(1) = '3' - r3 = 3. - c3(11) = '3' - c6 = '6' - - call x (c1, r1, c2, r2, c3, r3, c4, c5, c6) - - end - - subroutine x (c1, r1, c2, r2, c3, r3, c4, c5, c6) - implicit none - - character c1(11), c2(11), c3(11) - real r1, r2, r3 - character c4, c5, c6 - - if (c1(1) .ne. '1') call abort - if (r1 .ne. 1.) call abort - if (c1(11) .ne. '1') call abort - if (c4 .ne. '4') call abort - if (c2(1) .ne. '2') call abort - if (r2 .ne. 2.) call abort - if (c2(11) .ne. '2') call abort - if (c5 .ne. '5') call abort - if (c3(1) .ne. '3') call abort - if (r3 .ne. 3.) call abort - if (c3(11) .ne. '3') call abort - if (c6 .ne. '6') call abort - - end diff --git a/gcc/testsuite/g77.f-torture/execute/980628-3.f b/gcc/testsuite/g77.f-torture/execute/980628-3.f deleted file mode 100644 index 47e6ea57301..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-3.f +++ /dev/null @@ -1,56 +0,0 @@ -* g77 0.5.23 and previous had bugs involving too little space -* allocated for EQUIVALENCE and COMMON areas needing initial -* padding to meet alignment requirements of the system. - - call subr - end - - subroutine subr - implicit none - save - - character c1(11), c2(11), c3(11) - real r1, r2, r3 - character c4, c5, c6 - equivalence (c1(2), r1) - equivalence (c2(2), r2) - equivalence (c3(2), r3) - - c1(1) = '1' - r1 = 1. - c1(11) = '1' - c4 = '4' - c2(1) = '2' - r2 = 2. - c2(11) = '2' - c5 = '5' - c3(1) = '3' - r3 = 3. - c3(11) = '3' - c6 = '6' - - call x (c1, r1, c2, r2, c3, r3, c4, c5, c6) - - end - - subroutine x (c1, r1, c2, r2, c3, r3, c4, c5, c6) - implicit none - - character c1(11), c2(11), c3(11) - real r1, r2, r3 - character c4, c5, c6 - - if (c1(1) .ne. '1') call abort - if (r1 .ne. 1.) call abort - if (c1(11) .ne. '1') call abort - if (c4 .ne. '4') call abort - if (c2(1) .ne. '2') call abort - if (r2 .ne. 2.) call abort - if (c2(11) .ne. '2') call abort - if (c5 .ne. '5') call abort - if (c3(1) .ne. '3') call abort - if (r3 .ne. 3.) call abort - if (c3(11) .ne. '3') call abort - if (c6 .ne. '6') call abort - - end diff --git a/gcc/testsuite/g77.f-torture/execute/980628-4.f b/gcc/testsuite/g77.f-torture/execute/980628-4.f deleted file mode 100644 index 40bd6e6df51..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-4.f +++ /dev/null @@ -1,27 +0,0 @@ -* g77 0.5.23 and previous had bugs involving too little space -* allocated for EQUIVALENCE and COMMON areas needing initial -* padding to meet alignment requirements of the system, -* including when initial values are provided (e.g. DATA). - - program test - implicit none - - real r - double precision d - common /cmn/ r, d - - if (r .ne. 1.) call abort - if (d .ne. 10.) call abort - - end - - block data init - implicit none - - real r - double precision d - common /cmn/ r, d - - data r/1./, d/10./ - - end diff --git a/gcc/testsuite/g77.f-torture/execute/980628-5.f b/gcc/testsuite/g77.f-torture/execute/980628-5.f deleted file mode 100644 index 14f39e3c51e..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-5.f +++ /dev/null @@ -1,27 +0,0 @@ -* g77 0.5.23 and previous had bugs involving too little space -* allocated for EQUIVALENCE and COMMON areas needing initial -* padding to meet alignment requirements of the system, -* including when initial values are provided (e.g. DATA). - - program test - implicit none - - character c - double precision d - common /cmn/ c, d - - if (c .ne. '1') call abort - if (d .ne. 10.) call abort - - end - - block data init - implicit none - - character c - double precision d - common /cmn/ c, d - - data c/'1'/, d/10./ - - end diff --git a/gcc/testsuite/g77.f-torture/execute/980628-6.f b/gcc/testsuite/g77.f-torture/execute/980628-6.f deleted file mode 100644 index c5ade65ed39..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-6.f +++ /dev/null @@ -1,26 +0,0 @@ -* g77 0.5.23 and previous had bugs involving too little space -* allocated for EQUIVALENCE and COMMON areas needing initial -* padding to meet alignment requirements of the system, -* including when initial values are provided (e.g. DATA). - - program test - implicit none - - character c - double precision d(100) - common /cmn/ c, d - - if (d(80) .ne. 10.) call abort - - end - - block data init - implicit none - - character c - double precision d(100) - common /cmn/ c, d - - data d(80)/10./ - - end diff --git a/gcc/testsuite/g77.f-torture/execute/980628-7.f b/gcc/testsuite/g77.f-torture/execute/980628-7.f deleted file mode 100644 index c81ba31fc26..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-7.f +++ /dev/null @@ -1,62 +0,0 @@ -* g77 0.5.23 and previous had bugs involving too little space -* allocated for EQUIVALENCE and COMMON areas needing initial -* padding to meet alignment requirements of the system. - - call subr - end - - subroutine subr - implicit none - - real r1(5), r2(5), r3(5) - double precision d1, d2, d3 - integer i1, i2, i3 - equivalence (d1, r1(2)) - equivalence (d2, r2(2)) - equivalence (d3, r3(2)) - - r1(1) = 1. - d1 = 10. - r1(4) = 1. - r1(5) = 1. - i1 = 1 - r2(1) = 2. - d2 = 20. - r2(4) = 2. - r2(5) = 2. - i2 = 2 - r3(1) = 3. - d3 = 30. - r3(4) = 3. - r3(5) = 3. - i3 = 3 - - call x (r1, d1, i1, r2, d2, i2, r3, d3, i3) - - end - - subroutine x (r1, d1, i1, r2, d2, i2, r3, d3, i3) - implicit none - - real r1(5), r2(5), r3(5) - double precision d1, d2, d3 - integer i1, i2, i3 - - if (r1(1) .ne. 1.) call abort - if (d1 .ne. 10.) call abort - if (r1(4) .ne. 1.) call abort - if (r1(5) .ne. 1.) call abort - if (i1 .ne. 1) call abort - if (r2(1) .ne. 2.) call abort - if (d2 .ne. 20.) call abort - if (r2(4) .ne. 2.) call abort - if (r2(5) .ne. 2.) call abort - if (i2 .ne. 2) call abort - if (r3(1) .ne. 3.) call abort - if (d3 .ne. 30.) call abort - if (r3(4) .ne. 3.) call abort - if (r3(5) .ne. 3.) call abort - if (i3 .ne. 3) call abort - - end - diff --git a/gcc/testsuite/g77.f-torture/execute/980628-8.f b/gcc/testsuite/g77.f-torture/execute/980628-8.f deleted file mode 100644 index 8940d009954..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-8.f +++ /dev/null @@ -1,63 +0,0 @@ -* g77 0.5.23 and previous had bugs involving too little space -* allocated for EQUIVALENCE and COMMON areas needing initial -* padding to meet alignment requirements of the system. - - call subr - end - - subroutine subr - implicit none - save - - real r1(5), r2(5), r3(5) - double precision d1, d2, d3 - integer i1, i2, i3 - equivalence (d1, r1(2)) - equivalence (d2, r2(2)) - equivalence (d3, r3(2)) - - r1(1) = 1. - d1 = 10. - r1(4) = 1. - r1(5) = 1. - i1 = 1 - r2(1) = 2. - d2 = 20. - r2(4) = 2. - r2(5) = 2. - i2 = 2 - r3(1) = 3. - d3 = 30. - r3(4) = 3. - r3(5) = 3. - i3 = 3 - - call x (r1, d1, i1, r2, d2, i2, r3, d3, i3) - - end - - subroutine x (r1, d1, i1, r2, d2, i2, r3, d3, i3) - implicit none - - real r1(5), r2(5), r3(5) - double precision d1, d2, d3 - integer i1, i2, i3 - - if (r1(1) .ne. 1.) call abort - if (d1 .ne. 10.) call abort - if (r1(4) .ne. 1.) call abort - if (r1(5) .ne. 1.) call abort - if (i1 .ne. 1) call abort - if (r2(1) .ne. 2.) call abort - if (d2 .ne. 20.) call abort - if (r2(4) .ne. 2.) call abort - if (r2(5) .ne. 2.) call abort - if (i2 .ne. 2) call abort - if (r3(1) .ne. 3.) call abort - if (d3 .ne. 30.) call abort - if (r3(4) .ne. 3.) call abort - if (r3(5) .ne. 3.) call abort - if (i3 .ne. 3) call abort - - end - diff --git a/gcc/testsuite/g77.f-torture/execute/980628-9.f b/gcc/testsuite/g77.f-torture/execute/980628-9.f deleted file mode 100644 index 54e6552d628..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980628-9.f +++ /dev/null @@ -1,56 +0,0 @@ -* g77 0.5.23 and previous had bugs involving too little space -* allocated for EQUIVALENCE and COMMON areas needing initial -* padding to meet alignment requirements of the system. - - call subr - end - - subroutine subr - implicit none - - character c1(11), c2(11), c3(11) - real r1, r2, r3 - character c4, c5, c6 - equivalence (r1, c1(2)) - equivalence (r2, c2(2)) - equivalence (r3, c3(2)) - - c1(1) = '1' - r1 = 1. - c1(11) = '1' - c4 = '4' - c2(1) = '2' - r2 = 2. - c2(11) = '2' - c5 = '5' - c3(1) = '3' - r3 = 3. - c3(11) = '3' - c6 = '6' - - call x (c1, r1, c2, r2, c3, r3, c4, c5, c6) - - end - - subroutine x (c1, r1, c2, r2, c3, r3, c4, c5, c6) - implicit none - - character c1(11), c2(11), c3(11) - real r1, r2, r3 - character c4, c5, c6 - - if (c1(1) .ne. '1') call abort - if (r1 .ne. 1.) call abort - if (c1(11) .ne. '1') call abort - if (c4 .ne. '4') call abort - if (c2(1) .ne. '2') call abort - if (r2 .ne. 2.) call abort - if (c2(11) .ne. '2') call abort - if (c5 .ne. '5') call abort - if (c3(1) .ne. '3') call abort - if (r3 .ne. 3.) call abort - if (c3(11) .ne. '3') call abort - if (c6 .ne. '6') call abort - - end - diff --git a/gcc/testsuite/g77.f-torture/execute/980701-0.f b/gcc/testsuite/g77.f-torture/execute/980701-0.f deleted file mode 100644 index a3ddd55473a..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980701-0.f +++ /dev/null @@ -1,72 +0,0 @@ -* g77 0.5.23 and previous had bugs involving too little space -* allocated for EQUIVALENCE and COMMON areas needing initial -* padding to meet alignment requirements of the system. - - call subr - end - - subroutine subr - implicit none - - real r1(5), r2(5), r3(5) - real s1(2), s2(2), s3(2) - double precision d1, d2, d3 - integer i1, i2, i3 - equivalence (r1, s1(2)) - equivalence (d1, r1(2)) - equivalence (r2, s2(2)) - equivalence (d2, r2(2)) - equivalence (r3, s3(2)) - equivalence (d3, r3(2)) - - s1(1) = 1. - r1(1) = 1. - d1 = 10. - r1(4) = 1. - r1(5) = 1. - i1 = 1 - s2(1) = 2. - r2(1) = 2. - d2 = 20. - r2(4) = 2. - r2(5) = 2. - i2 = 2 - s3(1) = 3. - r3(1) = 3. - d3 = 30. - r3(4) = 3. - r3(5) = 3. - i3 = 3 - - call x (s1, r1, d1, i1, s2, r2, d2, i2, s3, r3, d3, i3) - - end - - subroutine x (s1, r1, d1, i1, s2, r2, d2, i2, s3, r3, d3, i3) - implicit none - - real r1(5), r2(5), r3(5) - real s1(2), s2(2), s3(2) - double precision d1, d2, d3 - integer i1, i2, i3 - - if (s1(1) .ne. 1.) call abort - if (r1(1) .ne. 1.) call abort - if (d1 .ne. 10.) call abort - if (r1(4) .ne. 1.) call abort - if (r1(5) .ne. 1.) call abort - if (i1 .ne. 1) call abort - if (s2(1) .ne. 2.) call abort - if (r2(1) .ne. 2.) call abort - if (d2 .ne. 20.) call abort - if (r2(4) .ne. 2.) call abort - if (r2(5) .ne. 2.) call abort - if (i2 .ne. 2) call abort - if (s3(1) .ne. 3.) call abort - if (r3(1) .ne. 3.) call abort - if (d3 .ne. 30.) call abort - if (r3(4) .ne. 3.) call abort - if (r3(5) .ne. 3.) call abort - if (i3 .ne. 3) call abort - - end diff --git a/gcc/testsuite/g77.f-torture/execute/980701-1.f b/gcc/testsuite/g77.f-torture/execute/980701-1.f deleted file mode 100644 index fba78564572..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/980701-1.f +++ /dev/null @@ -1,72 +0,0 @@ -* g77 0.5.23 and previous had bugs involving too little space -* allocated for EQUIVALENCE and COMMON areas needing initial -* padding to meet alignment requirements of the system. - - call subr - end - - subroutine subr - implicit none - - real r1(5), r2(5), r3(5) - real s1(2), s2(2), s3(2) - double precision d1, d2, d3 - integer i1, i2, i3 - equivalence (d1, r1(2)) - equivalence (r1, s1(2)) - equivalence (d2, r2(2)) - equivalence (r2, s2(2)) - equivalence (d3, r3(2)) - equivalence (r3, s3(2)) - - s1(1) = 1. - r1(1) = 1. - d1 = 10. - r1(4) = 1. - r1(5) = 1. - i1 = 1 - s2(1) = 2. - r2(1) = 2. - d2 = 20. - r2(4) = 2. - r2(5) = 2. - i2 = 2 - s3(1) = 3. - r3(1) = 3. - d3 = 30. - r3(4) = 3. - r3(5) = 3. - i3 = 3 - - call x (s1, r1, d1, i1, s2, r2, d2, i2, s3, r3, d3, i3) - - end - - subroutine x (s1, r1, d1, i1, s2, r2, d2, i2, s3, r3, d3, i3) - implicit none - - real r1(5), r2(5), r3(5) - real s1(2), s2(2), s3(2) - double precision d1, d2, d3 - integer i1, i2, i3 - - if (s1(1) .ne. 1.) call abort - if (r1(1) .ne. 1.) call abort - if (d1 .ne. 10.) call abort - if (r1(4) .ne. 1.) call abort - if (r1(5) .ne. 1.) call abort - if (i1 .ne. 1) call abort - if (s2(1) .ne. 2.) call abort - if (r2(1) .ne. 2.) call abort - if (d2 .ne. 20.) call abort - if (r2(4) .ne. 2.) call abort - if (r2(5) .ne. 2.) call abort - if (i2 .ne. 2) call abort - if (s3(1) .ne. 3.) call abort - if (r3(1) .ne. 3.) call abort - if (d3 .ne. 30.) call abort - if (r3(4) .ne. 3.) call abort - if (r3(5) .ne. 3.) call abort - if (i3 .ne. 3) call abort - - end diff --git a/gcc/testsuite/g77.f-torture/execute/alpha2.f b/gcc/testsuite/g77.f-torture/execute/alpha2.f deleted file mode 100644 index d7b9d39da4b..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/alpha2.f +++ /dev/null @@ -1,19 +0,0 @@ -c This was originally a compile test. - IMPLICIT REAL*8 (A-H,O-Z) - COMMON /C/ A(9), INT - DATA A / - 1 0.49999973986348730D01, 0.40000399113084100D01, - 2 0.29996921166596490D01, 0.20016917082678680D01, - 3 0.99126390351864390D00, 0.97963256554443300D-01, - 4 -0.87360964813570100D-02, 0.16917082678692080D-02, - 5 7./ -C Data values were once mis-compiled on (OSF/1 ?) Alpha with -O2 -c such that, for instance, `7.' appeared as `4.' in the assembler -c output. - call test(a(9), 7) - END - subroutine test(r, i) - double precision r - if (nint(r)/=i) call abort - end - diff --git a/gcc/testsuite/g77.f-torture/execute/auto0.f b/gcc/testsuite/g77.f-torture/execute/auto0.f deleted file mode 100644 index 4b6b2f51a8e..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/auto0.f +++ /dev/null @@ -1,80 +0,0 @@ -* Test automatic arrays. - program auto0 - implicit none - integer i - integer j0(40) - integer j1(40) - integer jc0(40) - integer jc1(40) - common /jc0/ jc0 - common /jc1/ jc1 - - data j0/40*3/ - data j1/40*4/ - - i = 40 - call a1 (j0, j1, i) - - do i = 1, 40 - if (j0(i) .ne. 4) call abort - if (j1(i) .ne. 3) call abort - if (jc0(i) .ne. 6) call abort - if (jc1(i) .ne. 5) call abort - end do - - end - - block data jc - implicit none - integer jc0(40) - integer jc1(40) - common /jc0/ jc0 - common /jc1/ jc1 - - data jc0/40*5/ - data jc1/40*6/ - - end - - subroutine a1 (j0, j1, n) - implicit none - integer j0(40), j1(40), n - integer k0(n), k1(n) - integer i - integer jc0(40) - integer jc1(40) - common /jc0/ jc0 - common /jc1/ jc1 - - do i = 1, 40 - j0(i) = j1(i) - j0(i) - jc0(i) = jc1(i) - jc0(i) - end do - - n = -1 - - do i = 1, 40 - k0(i) = n - k1(i) = n - end do - - do i = 1, 40 - j1(i) = j1(i) + k0(i) * j0(i) - jc1(i) = jc1(i) + k1(i) * jc0(i) - end do - - n = 500 - - do i = 1, 40 - if (k0(i) .ne. -1) call abort - k0(i) = n - if (k1(i) .ne. -1) call abort - k1(i) = n - end do - - do i = 1, 40 - j0(i) = j1(i) + j0(i) - jc0(i) = jc1(i) + jc0(i) - end do - - end diff --git a/gcc/testsuite/g77.f-torture/execute/auto1.f b/gcc/testsuite/g77.f-torture/execute/auto1.f deleted file mode 100644 index ab9044ceca5..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/auto1.f +++ /dev/null @@ -1,88 +0,0 @@ -* Test automatic arrays. - program auto1 - implicit none - integer i - integer j0(40) - integer j1(40) - integer jc0(40) - integer jc1(40) - common /jc0/ jc0 - common /jc1/ jc1 - - data j0/40*3/ - data j1/40*4/ - - i = 40 - call a1 (j0, j1, i) - - do i = 1, 40 - if (j0(i) .ne. 4) call abort - if (j1(i) .ne. 3) call abort - if (jc0(i) .ne. 6) call abort - if (jc1(i) .ne. 5) call abort - end do - - end - - block data jc - implicit none - integer jc0(40) - integer jc1(40) - common /jc0/ jc0 - common /jc1/ jc1 - - data jc0/40*5/ - data jc1/40*6/ - - end - - subroutine a1 (j0, j1, n) - implicit none - integer j0(40), j1(40), n - integer k0(n,3,2), k1(n,3,2) - integer i,j,k - integer jc0(40) - integer jc1(40) - common /jc0/ jc0 - common /jc1/ jc1 - - do i = 1, 40 - j0(i) = j1(i) - j0(i) - jc0(i) = jc1(i) - jc0(i) - end do - - n = -1 - - do k = 1, 2 - do j = 1, 3 - do i = 1, 40 - k0(i, j, k) = n - k1(i, j, k) = n - end do - end do - end do - - do i = 1, 40 - j1(i) = j1(i) + k0(i, 3, 2) * j0(i) - jc1(i) = jc1(i) + k1(i, 1, 1) * jc0(i) - end do - - n = 500 - - do k = 1, 2 - do j = 1, 3 - do i = 1, 40 - if (k0(i, j, k) .ne. -1) call abort - k0(i, j, k) = n - if (k1(i, j, k) .ne. -1) call abort - k1(i, j, k) = n - end do - end do - end do - - do i = 1, 40 - j0(i) = j1(i) + j0(i) - jc0(i) = jc1(i) + jc0(i) - end do - - end diff --git a/gcc/testsuite/g77.f-torture/execute/cabs.f b/gcc/testsuite/g77.f-torture/execute/cabs.f deleted file mode 100644 index 61fd263620b..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/cabs.f +++ /dev/null @@ -1,14 +0,0 @@ - program cabs_1 - complex z0 - real r0 - complex*16 z1 - real*8 r1 - - z0 = cmplx(3.,4.) - r0 = cabs(z0) - if (r0 .ne. 5.) call abort - - z1 = dcmplx(3.d0,4.d0) - r1 = zabs(z1) - if (r1 .ne. 5.d0) call abort - end diff --git a/gcc/testsuite/g77.f-torture/execute/claus.f b/gcc/testsuite/g77.f-torture/execute/claus.f deleted file mode 100644 index bccef7f4090..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/claus.f +++ /dev/null @@ -1,13 +0,0 @@ - PROGRAM TEST - REAL AB(3) - do i=1,3 - AB(i)=i - enddo - k=1 - n=2 - ind=k-n+2 - if (ind /= 1) call abort - if (ab(ind) /= 1) call abort - if (k-n+2 /= 1) call abort - if (ab(k-n+2) /= 1) call abort - END diff --git a/gcc/testsuite/g77.f-torture/execute/complex_1.f b/gcc/testsuite/g77.f-torture/execute/complex_1.f deleted file mode 100644 index 77da6359f72..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/complex_1.f +++ /dev/null @@ -1,18 +0,0 @@ - program complex_1 - complex z0, z1, z2 - - z0 = cmplx(0.,.5) - z1 = 1./z0 - if (z1 .ne. cmplx(0.,-2)) call abort - - z0 = 10.*z0 - if (z0 .ne. cmplx(0.,5.)) call abort - - z2 = cmplx(1.,2.) - z1 = z0/z2 - if (z1 .ne. cmplx(2.,1.)) call abort - - z1 = z0*z2 - if (z1 .ne. cmplx(-10.,5.)) call abort - end - diff --git a/gcc/testsuite/g77.f-torture/execute/cpp.F b/gcc/testsuite/g77.f-torture/execute/cpp.F deleted file mode 100644 index fc9386b5c92..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/cpp.F +++ /dev/null @@ -1,5 +0,0 @@ -! Some versions of cpp will delete "//'World' as a C++ comment. - character*40 title - title = 'Hello '//'World' - if (title .ne. 'Hello World') call abort - end diff --git a/gcc/testsuite/g77.f-torture/execute/dcomplex.f b/gcc/testsuite/g77.f-torture/execute/dcomplex.f deleted file mode 100644 index a46f03aabef..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/dcomplex.f +++ /dev/null @@ -1,18 +0,0 @@ - program foo - complex*16 z0, z1, z2 - - z0 = dcmplx(0.,.5) - z1 = 1./z0 - if (z1 .ne. dcmplx(0.,-2)) call abort - - z0 = 10.*z0 - if (z0 .ne. dcmplx(0.,5.)) call abort - - z2 = cmplx(1.,2.) - z1 = z0/z2 - if (z1 .ne. dcmplx(2.,1.)) call abort - - z1 = z0*z2 - if (z1 .ne. dcmplx(-10.,5.)) call abort - end - diff --git a/gcc/testsuite/g77.f-torture/execute/dnrm2.f b/gcc/testsuite/g77.f-torture/execute/dnrm2.f deleted file mode 100644 index c69608786b9..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/dnrm2.f +++ /dev/null @@ -1,74 +0,0 @@ -CCC g77 0.5.21 `Actual Bugs': -CCC * A code-generation bug afflicts Intel x86 targets when `-O2' is -CCC specified compiling, for example, an old version of the `DNRM2' -CCC routine. The x87 coprocessor stack is being somewhat mismanaged -CCC in cases where assigned `GOTO' and `ASSIGN' are involved. -CCC -CCC Version 0.5.21 of `g77' contains an initial effort to fix the -CCC problem, but this effort is incomplete, and a more complete fix is -CCC planned for the next release. - -C Currently this test fails with (at least) `-O2 -funroll-loops' on -C i586-unknown-linux-gnulibc1. - -C (This is actually an obsolete version of dnrm2 -- consult the -c current Netlib BLAS.) - - integer i - double precision a(1:100), dnrm2 - do i=1,100 - a(i)=0.D0 - enddo - if (dnrm2(100,a,1) .ne. 0.0) call abort - end - - double precision function dnrm2 ( n, dx, incx) - integer i, incx, ix, j, n, next - double precision dx(1), cutlo, cuthi, hitest, sum, xmax,zero,one - data zero, one /0.0d0, 1.0d0/ - data cutlo, cuthi / 8.232d-11, 1.304d19 / - j = 0 - if(n .gt. 0 .and. incx.gt.0) go to 10 - dnrm2 = zero - go to 300 - 10 assign 30 to next - sum = zero - i = 1 - ix = 1 - 20 go to next,(30, 50, 70, 110) - 30 if( dabs(dx(i)) .gt. cutlo) go to 85 - assign 50 to next - xmax = zero - 50 if( dx(i) .eq. zero) go to 200 - if( dabs(dx(i)) .gt. cutlo) go to 85 - assign 70 to next - go to 105 - 100 continue - ix = j - assign 110 to next - sum = (sum / dx(i)) / dx(i) - 105 xmax = dabs(dx(i)) - go to 115 - 70 if( dabs(dx(i)) .gt. cutlo ) go to 75 - 110 if( dabs(dx(i)) .le. xmax ) go to 115 - sum = one + sum * (xmax / dx(i))**2 - xmax = dabs(dx(i)) - go to 200 - 115 sum = sum + (dx(i)/xmax)**2 - go to 200 - 75 sum = (sum * xmax) * xmax - 85 hitest = cuthi/float( n ) - do 95 j = ix,n - if(dabs(dx(i)) .ge. hitest) go to 100 - sum = sum + dx(i)**2 - i = i + incx - 95 continue - dnrm2 = dsqrt( sum ) - go to 300 - 200 continue - ix = ix + 1 - i = i + incx - if( ix .le. n ) go to 20 - dnrm2 = xmax * dsqrt(sum) - 300 continue - end diff --git a/gcc/testsuite/g77.f-torture/execute/erfc.f b/gcc/testsuite/g77.f-torture/execute/erfc.f deleted file mode 100644 index e5e0412f587..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/erfc.f +++ /dev/null @@ -1,38 +0,0 @@ -c============================================== test.f - real x, y - real*8 x1, y1 - x=0. - y = erfc(x) - if (y .ne. 1.) call abort - - x=1.1 - y = erfc(x) - if (abs(y - .1197949) .ge. 1.e-6) call abort - -* modified from x=10, y .gt. 1.5e-44 to avoid lack of -mieee on Alphas. - x=8 - y = erfc(x) - if (y .gt. 1.2e-28) call abort - - x1=0. - y1 = erfc(x1) - if (y1 .ne. 1.) call abort - - x1=1.1d0 - y1 = erfc(x1) - if (abs(y1 - .1197949d0) .ge. 1.d-6) call abort - - x1=10 - y1 = erfc(x1) - if (y1 .gt. 1.5d-44) call abort - end -c================================================= -!output: -! 0. 1.875 -! 1.10000002 1.48958981 -! 10. 5.00220949E-06 -! -!The values should be: -!erfc(0)=1 -!erfc(1.1)= 0.1197949 -!erfc(10)<1.543115467311259E-044 diff --git a/gcc/testsuite/g77.f-torture/execute/execute.exp b/gcc/testsuite/g77.f-torture/execute/execute.exp deleted file mode 100644 index 31608eed4f9..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/execute.exp +++ /dev/null @@ -1,55 +0,0 @@ -# Copyright (C) 1991, 1992, 1993, 1995, 1997 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 2 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 this program; if not, write to the Free Software -# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -# Please email any bugs, comments, and/or additions to this file to: -# bug-g77@prep.ai.mit.edu - -# This file was written by Rob Savoye. (rob@cygnus.com) -# Modified and maintained by Jeffrey Wheat (cassidy@cygnus.com) - -# -# These tests come from Torbjorn Granlund (tege@cygnus.com) -# Fortran torture test suite. -# - -if $tracelevel then { - strace $tracelevel -} - -# load support procs -load_lib f-torture.exp - -# -# main test loop -# - -foreach src [lsort [glob -nocomplain $srcdir/$subdir/*.f]] { - # If we're only testing specific files and this isn't one of them, skip it. - if ![runtest_file_p $runtests $src] then { - continue - } - - f-torture-execute $src -} - -foreach src [lsort [glob -nocomplain $srcdir/$subdir/*.F]] { - # If we're only testing specific files and this isn't one of them, skip it. - if ![runtest_file_p $runtests $src] then { - continue - } - - f-torture-execute $src -} diff --git a/gcc/testsuite/g77.f-torture/execute/exp.f b/gcc/testsuite/g77.f-torture/execute/exp.f deleted file mode 100644 index de388f181b0..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/exp.f +++ /dev/null @@ -1,3 +0,0 @@ - a = 2**-2*1. - if (a .ne. .25) call abort - end diff --git a/gcc/testsuite/g77.f-torture/execute/io0.f b/gcc/testsuite/g77.f-torture/execute/io0.f deleted file mode 100644 index c56c9919077..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/io0.f +++ /dev/null @@ -1,46 +0,0 @@ -* Preliminary tests for a few things in the i/o library. -* Thrown together by Dave Love not from specific bug reports -- -* other ideas welcome. - - character *(*) fmt - parameter (fmt='(1x,i3,f5.1)') -* Scratch file makes sure we can use one and avoids dealing with -* explicit i/o in the testsuite. - open(90, status='scratch') ! try a biggish unit number - write(90, '()') ! extra record for interest -* Formatted i/o can go wild (endless loop AFAIR) if we're wrongly -* assuming an ANSI sprintf. - write(90, fmt) 123, 123.0 - backspace 90 ! backspace problems reported on DOSish systems - read(90, fmt) i, r - endfile 90 - if (i/=123 .or. nint(r)/=123) call abort - rewind 90 ! make sure we can rewind too - read(90, '()') - read(90, fmt) i, r - if (i/=123 .or. nint(r)/=123) call abort - close(90) -* Make sure we can do unformatted i/o OK. This might be -* problematic on DOS-like systems if we've done an fopen in text -* mode, not binary. - open(90, status='scratch', access='direct', form='unformatted', - + recl=8) - write(90, rec=1) 123, 123.0 - read(90, rec=1) i, r - if (i/=123 .or. nint(r)/=123) call abort - close(90) - open(90, status='scratch', form='unformatted') - write(90) 123, 123.0 - backspace 90 - read(90) i, r - if (i/=123 .or. nint(r)/=123) call abort - close(90) -* Fails at 1998-09-01 on spurious recursive i/o check (fixed by -* 1998-09-06 libI77 change): - open(90, status='scratch', form='formatted', recl=16, - + access='direct') - write(90, '(i8,f8.1)',rec=1) 123, 123.0 - read(90, '(i8,f8.1)', rec=1) i, r - if (i/=123 .or. nint(r)/=123) call abort - close(90) - end diff --git a/gcc/testsuite/g77.f-torture/execute/io1.f b/gcc/testsuite/g77.f-torture/execute/io1.f deleted file mode 100644 index c5242446a49..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/io1.f +++ /dev/null @@ -1,10 +0,0 @@ -* Fixed by 1998-09-28 libI77/open.c change. - open(90,status='scratch') - write(90, '(1X, I1 / 1X, I1)') 1, 2 - rewind 90 - write(90, '(1X, I1)') 1 - rewind 90 ! implicit ENDFILE expected - read(90, *) i - read(90, *, end=10) j - call abort() - 10 end diff --git a/gcc/testsuite/g77.f-torture/execute/labug1.f b/gcc/testsuite/g77.f-torture/execute/labug1.f deleted file mode 100644 index 032fa41f899..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/labug1.f +++ /dev/null @@ -1,57 +0,0 @@ - PROGRAM LABUG1 - -* This program core dumps on mips-sgi-irix6.2 when compiled -* with egcs-19981101, egcs-19981109 and egcs-19981122 snapshots -* with -O2 -* -* Originally derived from LAPACK test suite. -* Almost any change allows it to run. -* -* David Billinghurst, (David.Billinghurst@riotinto.com.au) -* 25 November 1998 -* -* .. Parameters .. - INTEGER LDA, LDE - PARAMETER ( LDA = 2500, LDE = 50 ) - COMPLEX CZERO - PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) - - INTEGER I, J, M, N - REAL V - COMPLEX A(LDA),B(LDA),C(LDA),E(LDE,LDE),F(LDE,LDE) - COMPLEX Z - - N=2 - M=1 -* - do i = 1, m - do j = 1, n - e(i,j) = czero - f(i,j) = czero - end do - end do -* - DO J = 1, N - DO I = 1, M - V = ABS( E(I,J) - F(I,J) ) - END DO - END DO - - CALL SUB2(M,Z) - - END - - subroutine SUB2(I,A) - integer i - complex a - end - - - - - - - - - - diff --git a/gcc/testsuite/g77.f-torture/execute/large_vec.f b/gcc/testsuite/g77.f-torture/execute/large_vec.f deleted file mode 100644 index 0af5b1b0b3f..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/large_vec.f +++ /dev/null @@ -1,3 +0,0 @@ - parameter (nmax=165000) - double precision x(nmax) - end diff --git a/gcc/testsuite/g77.f-torture/execute/le.f b/gcc/testsuite/g77.f-torture/execute/le.f deleted file mode 100644 index 74e42750d55..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/le.f +++ /dev/null @@ -1,29 +0,0 @@ - program fool - - real foo - integer n - logical t - - foo = 2.5 - n = 5 - - t = (n > foo) - if (t .neqv. .true.) call abort - t = (n >= foo) - if (t .neqv. .true.) call abort - t = (n < foo) - if (t .neqv. .false.) call abort - t = (n <= 5) - if (t .neqv. .true.) call abort - t = (n >= 5 ) - if (t .neqv. .true.) call abort - t = (n == 5) - if (t .neqv. .true.) call abort - t = (n /= 5) - if (t .neqv. .false.) call abort - t = (n /= foo) - if (t .neqv. .true.) call abort - t = (n == foo) - if (t .neqv. .false.) call abort - - end diff --git a/gcc/testsuite/g77.f-torture/execute/short.f b/gcc/testsuite/g77.f-torture/execute/short.f deleted file mode 100644 index 89ae273891c..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/short.f +++ /dev/null @@ -1,57 +0,0 @@ - program short - - parameter ( N=2 ) - common /chb/ pi,sig(0:N) - common /parm/ h(2,2) - -c initialize some variables - h(2,2) = 1117 - h(2,1) = 1178 - h(1,2) = 1568 - h(1,1) = 1621 - sig(0) = -1. - sig(1) = 0. - sig(2) = 1. - - call printout - stop - end - -c ****************************************************************** - - subroutine printout - parameter ( N=2 ) - common /chb/ pi,sig(0:N) - common /parm/ h(2,2) - dimension yzin1(0:N), yzin2(0:N) - -c function subprograms - z(i,j,k) = 0.5*h(i,j)*(sig(k)-1.) - -c a four-way average of rhobar - do 260 k=0,N - yzin1(k) = 0.25 * - & ( z(2,2,k) + z(1,2,k) + - & z(2,1,k) + z(1,1,k) ) - 260 continue - -c another four-way average of rhobar - do 270 k=0,N - rtmp1 = z(2,2,k) - rtmp2 = z(1,2,k) - rtmp3 = z(2,1,k) - rtmp4 = z(1,1,k) - yzin2(k) = 0.25 * - & ( rtmp1 + rtmp2 + rtmp3 + rtmp4 ) - 270 continue - - do k=0,N - if (yzin1(k) .ne. yzin2(k)) call abort - enddo - if (yzin1(0) .ne. -1371.) call abort - if (yzin1(1) .ne. -685.5) call abort - if (yzin1(2) .ne. 0.) call abort - - return - end - diff --git a/gcc/testsuite/g77.f-torture/execute/u77-test.f b/gcc/testsuite/g77.f-torture/execute/u77-test.f deleted file mode 100644 index 198d48b460c..00000000000 --- a/gcc/testsuite/g77.f-torture/execute/u77-test.f +++ /dev/null @@ -1,421 +0,0 @@ -*** Some random stuff for testing libU77. Should be done better. It's -* hard to test things where you can't guarantee the result. Have a -* good squint at what it prints, though detected errors will cause -* starred messages. -* -* Currently not tested: -* ALARM -* CHDIR (func) -* CHMOD (func) -* FGET (func/subr) -* FGETC (func) -* FPUT (func/subr) -* FPUTC (func) -* FSTAT (subr) -* GETCWD (subr) -* HOSTNM (subr) -* IRAND -* KILL -* LINK (func) -* LSTAT (subr) -* RENAME (func/subr) -* SIGNAL (subr) -* SRAND -* STAT (subr) -* SYMLNK (func/subr) -* UMASK (func) -* UNLINK (func) -* -* NOTE! This is the testsuite version, so it should compile and -* execute on all targets, and either run to completion (with -* success status) or fail (by calling abort). The *other* version, -* which is a bit more interactive and tests a couple of things -* this one cannot, should be generally the same, and is in -* libf2c/libU77/u77-test.f. Please keep it up-to-date. - - implicit none - - external hostnm -* intrinsic hostnm - integer hostnm - - integer i, j, k, ltarray (9), idat (3), count, rate, count_max, - + pid, mask - real tarray1(2), tarray2(2), r1, r2 - double precision d1 - integer(kind=2) bigi - logical issum - intrinsic getpid, getuid, getgid, ierrno, gerror, time8, - + fnum, isatty, getarg, access, unlink, fstat, iargc, - + stat, lstat, getcwd, gmtime, etime, chmod, itime, date, - + chdir, fgetc, fputc, system_clock, second, idate, secnds, - + time, ctime, fdate, ttynam, date_and_time, mclock, mclock8, - + cpu_time, dtime, ftell, abort - external lenstr, ctrlc - integer lenstr - logical l - character gerr*80, c*1 - character ctim*25, line*80, lognam*20, wd*100, line2*80, ddate*8, - + ttime*10, zone*5, ctim2*25 - integer fstatb (13), statb (13) - integer *2 i2zero - integer values(8) - integer(kind=7) sigret - - i = time () - ctim = ctime (i) - WRITE (6,'(A/)') '1 GNU libU77 test at: ' // ctim(:lenstr (ctim)) - write (6,'(A,I3,'', '',I3)') - + ' Logical units 5 and 6 correspond (FNUM) to' - + // ' Unix i/o units ', fnum(5), fnum(6) - if (lnblnk('foo ').ne.3 .or. len_trim('foo ').ne.3) then - print *, 'LNBLNK or LEN_TRIM failed' - call abort - end if - - bigi = time8 () - - call ctime (i, ctim2) - if (ctim .ne. ctim2) then - write (6, *) '*** CALL CTIME disagrees with CTIME(): ', - + ctim2(:lenstr (ctim2)), ' vs. ', ctim(:lenstr (ctim)) - call doabort - end if - - j = time () - if (i .gt. bigi .or. bigi .gt. j) then - write (6, *) '*** TIME/TIME8/TIME sequence failures: ', - + i, bigi, j - call doabort - end if - - print *, 'Command-line arguments: ', iargc () - do i = 0, iargc () - call getarg (i, line) - print *, 'Arg ', i, ' is: ', line(:lenstr (line)) - end do - - l= isatty(6) - line2 = ttynam(6) - if (l) then - line = 'and 6 is a tty device (ISATTY) named '//line2 - else - line = 'and 6 isn''t a tty device (ISATTY)' - end if - write (6,'(1X,A)') line(:lenstr(line)) - call ttynam (6, line) - if (line .ne. line2) then - print *, '*** CALL TTYNAM disagrees with TTYNAM: ', - + line(:lenstr (line)) - call doabort - end if - -* regression test for compiler crash fixed by JCB 1998-08-04 com.c - sigret = signal(2, ctrlc) - - pid = getpid() - WRITE (6,'(A,I10)') ' Process id (GETPID): ', pid - WRITE (6,'(A,I10)') ' User id (GETUID): ', GETUID () - WRITE (6,'(A,I10)') ' Group id (GETGID): ', GETGID () - WRITE (6, *) 'If you have the `id'' program, the following call' - write (6, *) 'of SYSTEM should agree with the above:' - call flush(6) - CALL SYSTEM ('echo " " `id`') - call flush - - lognam = 'blahblahblah' - call getlog (lognam) - write (6,*) 'Login name (GETLOG): ', lognam(:lenstr (lognam)) - - wd = 'blahblahblah' - call getenv ('LOGNAME', wd) - write (6,*) 'Login name (GETENV of LOGNAME): ', wd(:lenstr (wd)) - - call umask(0, mask) - write(6,*) 'UMASK returns', mask - call umask(mask) - - ctim = fdate() - write (6,*) 'FDATE returns: ', ctim(:lenstr (ctim)) - call fdate (ctim) - write (6,*) 'CALL FDATE returns: ', ctim(:lenstr (ctim)) - - j=time() - call ltime (j, ltarray) - write (6,'(1x,a,9i4)') 'LTIME returns:', ltarray - call gmtime (j, ltarray) - write (6,'(1x,a,9i4)') 'GMTIME returns:', ltarray - - call system_clock(count) ! omitting optional args - call system_clock(count, rate, count_max) - write(6,*) 'SYSTEM_CLOCK returns: ', count, rate, count_max - - call date_and_time(ddate) ! omitting optional args - call date_and_time(ddate, ttime, zone, values) - write(6, *) 'DATE_AND_TIME returns: ', ddate, ' ', ttime, ' ', - + zone, ' ', values - - write (6,*) 'Sleeping for 1 second (SLEEP) ...' - call sleep (1) - -c consistency-check etime vs. dtime for first call - r1 = etime (tarray1) - r2 = dtime (tarray2) - if (abs (r1-r2).gt.1.0) then - write (6,*) - + 'Results of ETIME and DTIME differ by more than a second:', - + r1, r2 - call doabort - end if - if (.not. issum (r1, tarray1(1), tarray1(2))) then - write (6,*) '*** ETIME didn''t return sum of the array: ', - + r1, ' /= ', tarray1(1), '+', tarray1(2) - call doabort - end if - if (.not. issum (r2, tarray2(1), tarray2(2))) then - write (6,*) '*** DTIME didn''t return sum of the array: ', - + r2, ' /= ', tarray2(1), '+', tarray2(2) - call doabort - end if - write (6, '(A,3F10.3)') - + ' Elapsed total, user, system time (ETIME): ', - + r1, tarray1 - -c now try to get times to change enough to see in etime/dtime - write (6,*) 'Looping until clock ticks at least once...' - do i = 1,1000 - do j = 1,1000 - end do - call dtime (tarray2, r2) - if (tarray2(1) .ne. 0. .or. tarray2(2) .ne. 0.) exit - end do - call etime (tarray1, r1) - if (.not. issum (r1, tarray1(1), tarray1(2))) then - write (6,*) '*** ETIME didn''t return sum of the array: ', - + r1, ' /= ', tarray1(1), '+', tarray1(2) - call doabort - end if - if (.not. issum (r2, tarray2(1), tarray2(2))) then - write (6,*) '*** DTIME didn''t return sum of the array: ', - + r2, ' /= ', tarray2(1), '+', tarray2(2) - call doabort - end if - write (6, '(A,3F10.3)') - + ' Differences in total, user, system time (DTIME): ', - + r2, tarray2 - write (6, '(A,3F10.3)') - + ' Elapsed total, user, system time (ETIME): ', - + r1, tarray1 - write (6, *) '(Clock-tick detected after ', i, ' 1K loops.)' - - call idate (i,j,k) - call idate (idat) - write (6,*) 'IDATE (date,month,year): ',idat - print *, '... and the VXT version (month,date,year): ', i,j,k - if (i/=idat(2) .or. j/=idat(1) .or. k/=mod(idat(3),100)) then - print *, '*** VXT and U77 versions don''t agree' - call doabort - end if - - call date (ctim) - write (6,*) 'DATE (dd-mmm-yy): ', ctim(:lenstr (ctim)) - - call itime (idat) - write (6,*) 'ITIME (hour,minutes,seconds): ', idat - - call time(line(:8)) - print *, 'TIME: ', line(:8) - - write (6,*) 'SECNDS(0.0) returns: ',secnds(0.0) - - write (6,*) 'SECOND returns: ', second() - call dumdum(r1) - call second(r1) - write (6,*) 'CALL SECOND returns: ', r1 - -* compiler crash fixed by 1998-10-01 com.c change - if (rand(0).lt.0.0 .or. rand(0).gt.1.0) then - write (6,*) '*** rand(0) error' - call doabort() - end if - - i = getcwd(wd) - if (i.ne.0) then - call perror ('*** getcwd') - call doabort - else - write (6,*) 'Current directory is "'//wd(:lenstr(wd))//'"' - end if - call chdir ('.',i) - if (i.ne.0) then - write (6,*) '***CHDIR to ".": ', i - call doabort - end if - - i=hostnm(wd) - if(i.ne.0) then - call perror ('*** hostnm') - call doabort - else - write (6,*) 'Host name is ', wd(:lenstr(wd)) - end if - - i = access('/dev/null ', 'rw') - if (i.ne.0) write (6,*) '***Read/write ACCESS to /dev/null: ', i - write (6,*) 'Creating file "foo" for testing...' - open (3,file='foo',status='UNKNOWN') - rewind 3 - call fputc(3, 'c',i) - call fputc(3, 'd',j) - if (i+j.ne.0) write(6,*) '***FPUTC: ', i -C why is it necessary to reopen? (who wrote this?) -C the better to test with, my dear! (-- burley) - close(3) - open(3,file='foo',status='old') - call fseek(3,0,0,*10) - go to 20 - 10 write(6,*) '***FSEEK failed' - call doabort - 20 call fgetc(3, c,i) - if (i.ne.0) then - write(6,*) '***FGETC: ', i - call doabort - end if - if (c.ne.'c') then - write(6,*) '***FGETC read the wrong thing: ', ichar(c) - call doabort - end if - i= ftell(3) - if (i.ne.1) then - write(6,*) '***FTELL offset: ', i - call doabort - end if - call ftell(3, i) - if (i.ne.1) then - write(6,*) '***CALL FTELL offset: ', i - call doabort - end if - call chmod ('foo', 'a+w',i) - if (i.ne.0) then - write (6,*) '***CHMOD of "foo": ', i - call doabort - end if - i = fstat (3, fstatb) - if (i.ne.0) then - write (6,*) '***FSTAT of "foo": ', i - call doabort - end if - i = stat ('foo', statb) - if (i.ne.0) then - write (6,*) '***STAT of "foo": ', i - call doabort - end if - write (6,*) ' with stat array ', statb - if (statb(6) .ne. getgid ()) then - write (6,*) 'Note: FSTAT gid wrong (happens on some systems).' - end if - if (statb(5) .ne. getuid () .or. statb(4) .ne. 1) then - write (6,*) '*** FSTAT uid or nlink is wrong' - call doabort - end if - do i=1,13 - if (fstatb (i) .ne. statb (i)) then - write (6,*) '*** FSTAT and STAT don''t agree on '// ' - + array element ', i, ' value ', fstatb (i), statb (i) - call abort - end if - end do - i = lstat ('foo', fstatb) - do i=1,13 - if (fstatb (i) .ne. statb (i)) then - write (6,*) '*** LSTAT and STAT don''t agree on '// - + 'array element ', i, ' value ', fstatb (i), statb (i) - call abort - end if - end do - -C in case it exists already: - call unlink ('bar',i) - call link ('foo ', 'bar ',i) - if (i.ne.0) then - write (6,*) '***LINK "foo" to "bar" failed: ', i - call doabort - end if - call unlink ('foo',i) - if (i.ne.0) then - write (6,*) '***UNLINK "foo" failed: ', i - call doabort - end if - call unlink ('foo',i) - if (i.eq.0) then - write (6,*) '***UNLINK "foo" again: ', i - call doabort - end if - - call gerror (gerr) - i = ierrno() - write (6,'(A,I3,A/1X,A)') ' The current error number is: ', - + i, - + ' and the corresponding message is:', gerr(:lenstr(gerr)) - write (6,*) 'This is sent to stderr prefixed by the program name' - call getarg (0, line) - call perror (line (:lenstr (line))) - call unlink ('bar') - - print *, 'MCLOCK returns ', mclock () - print *, 'MCLOCK8 returns ', mclock8 () - - call cpu_time (d1) - print *, 'CPU_TIME returns ', d1 - -C WRITE (6,*) 'You should see exit status 1' - CALL EXIT(0) - 99 END - -* Return length of STR not including trailing blanks, but always > 0. - integer function lenstr (str) - character*(*) str - if (str.eq.' ') then - lenstr=1 - else - lenstr = lnblnk (str) - end if - end - -* Just make sure SECOND() doesn't "magically" work the second time. - subroutine dumdum(r) - r = 3.14159 - end - -* Test whether sum is approximately left+right. - logical function issum (sum, left, right) - implicit none - real sum, left, right - real mysum, delta, width - mysum = left + right - delta = abs (mysum - sum) - width = abs (left) + abs (right) - issum = (delta .le. .0001 * width) - end - -* Signal handler - subroutine ctrlc - print *, 'Got ^C' - call doabort - end - -* A problem has been noticed, so maybe abort the test. - subroutine doabort -* For this version, call the ABORT intrinsic. - intrinsic abort - call abort - end - -* Testsuite version only. -* Don't actually reference the HOSTNM intrinsic, because some targets -* need -lsocket, which we don't have a mechanism for supplying. - integer function hostnm(nm) - character*(*) nm - nm = 'not determined by this version of u77-test.f' - hostnm = 0 - end diff --git a/gcc/testsuite/g77.f-torture/noncompile/19981216-0.f b/gcc/testsuite/g77.f-torture/noncompile/19981216-0.f deleted file mode 100644 index 0cc9087d6cb..00000000000 --- a/gcc/testsuite/g77.f-torture/noncompile/19981216-0.f +++ /dev/null @@ -1,89 +0,0 @@ -* Resent-From: Craig Burley <burley@gnu.org> -* Resent-To: craig@jcb-sc.com -* X-Delivered: at request of burley on mescaline.gnu.org -* Date: Wed, 16 Dec 1998 18:31:24 +0100 -* From: Dieter Stueken <stueken@conterra.de> -* Organization: con terra GmbH -* To: fortran@gnu.org -* Subject: possible bug -* Content-Type: text/plain; charset=iso-8859-1 -* X-Mime-Autoconverted: from 8bit to quoted-printable by mescaline.gnu.org id KAA09085 -* X-UIDL: 72293bf7f9fac8378ec7feca2bccbce2 -* -* Hi, -* -* I'm about to compile a very old, very ugly Fortran program. -* For one part I got: -* -* f77: Internal compiler error: program f771 got fatal signal 6 -* -* instead of any detailed error message. I was able to break down the -* problem to the following source fragment: -* -* ------------------------------------------- - PROGRAM WAP - - integer*2 ios - character*80 name - - name = 'blah' - open(unit=8,status='unknown',file=name,form='formatted', - F iostat=ios) - - END -* ------------------------------------------- -* -* The problem seems to be caused by the "integer*2 ios" declaration. -* So far I solved it by simply using a plain integer instead. -* -* I'm running gcc on a Linux system compiled/installed -* with no special options: -* -* -> g77 -v -* g77 version 0.5.23 -* Driving: g77 -v -c -xf77-version /dev/null -xnone -* Reading specs from /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/specs -* gcc version 2.8.1 -* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/cpp -lang-c -v -undef -* -D__GNUC__=2 -D__GNUC_MINOR__=8 -D__ELF__ -D__unix__ -D__linux__ -* -D__unix -D__linux -Asystem(posix) -D_LANGUAGE_FORTRAN -traditional -* -Di386 -Di686 -Asystem(unix) -Acpu(i386) -Amachine(i386) -D__i386__ -* -D__i686__ -Asystem(unix) -Acpu(i386) -Amachine(i386) /dev/null -* /dev/null -* GNU CPP version 2.8.1 (i386 GNU/Linux with ELF) -* #include "..." search starts here: -* #include <...> search starts here: -* /usr/local/include -* /usr/i686-pc-linux-gnulibc1/include -* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/include -* /usr/include -* End of search list. -* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/f771 -fnull-version -* -quiet -dumpbase g77-version.f -version -fversion -o /tmp/cca24911.s -* /dev/null -* GNU F77 version 2.8.1 (i686-pc-linux-gnulibc1) compiled by GNU C version -* 2.8.1. -* GNU Fortran Front End version 0.5.23 -* as -V -Qy -o /tmp/cca24911.o /tmp/cca24911.s -* GNU assembler version 2.8.1 (i486-linux), using BFD version 2.8.1 -* ld -m elf_i386 -dynamic-linker /lib/ld-linux.so.1 -o /tmp/cca24911 -* /tmp/cca24911.o /usr/lib/crt1.o /usr/lib/crti.o -* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/crtbegin.o -* -L/usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1 -L/usr -lg2c -lm -lgcc -* -lc -lgcc /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/crtend.o -* /usr/lib/crtn.o -* /tmp/cca24911 -* __G77_LIBF77_VERSION__: 0.5.23 -* @(#)LIBF77 VERSION 19970919 -* __G77_LIBI77_VERSION__: 0.5.23 -* @(#) LIBI77 VERSION pjw,dmg-mods 19980405 -* __G77_LIBU77_VERSION__: 0.5.23 -* @(#) LIBU77 VERSION 19970919 -* -* -* Regards, Dieter. -* -- -* Dieter Stüken, con terra GmbH, Münster -* stueken@conterra.de stueken@qgp.uni-muenster.de -* http://www.conterra.de/ http://qgp.uni-muenster.de/~stueken -* (0)251-980-2027 (0)251-83-334974 diff --git a/gcc/testsuite/g77.f-torture/noncompile/19990218-1.f b/gcc/testsuite/g77.f-torture/noncompile/19990218-1.f deleted file mode 100644 index 25b7c5b2b52..00000000000 --- a/gcc/testsuite/g77.f-torture/noncompile/19990218-1.f +++ /dev/null @@ -1,13 +0,0 @@ - double precision function fun(a,b) - double precision a,b - print*,'in sub: a,b=',a,b - fun=a*b - print*,'in sub: fun=',fun - return - end - program test - double precision a,b,c - data a,b/1.0d-46,1.0d0/ - c=fun(a,b) - print*,'in main: fun=',c - end diff --git a/gcc/testsuite/g77.f-torture/noncompile/980615-0.f b/gcc/testsuite/g77.f-torture/noncompile/980615-0.f deleted file mode 100644 index 316969f6aa8..00000000000 --- a/gcc/testsuite/g77.f-torture/noncompile/980615-0.f +++ /dev/null @@ -1,10 +0,0 @@ -* Fixed by JCB 1998-07-25 change to stc.c. - -* Date: Thu, 11 Jun 1998 22:35:20 -0500 -* From: Ian A Watson <WATSON_IAN_A@lilly.com> -* Subject: crash -* - CaLL foo(W) - END - SUBROUTINE foo(W) - yy(I)=A(I)Q(X) diff --git a/gcc/testsuite/g77.f-torture/noncompile/980616-0.f b/gcc/testsuite/g77.f-torture/noncompile/980616-0.f deleted file mode 100644 index bd5e74022a3..00000000000 --- a/gcc/testsuite/g77.f-torture/noncompile/980616-0.f +++ /dev/null @@ -1,8 +0,0 @@ -* Fixed by 1998-07-11 equiv.c change. -* ../../gcc/f/equiv.c:666: failed assertion `ffebld_op (subscript) == FFEBLD_opCONTER' - -* Date: Mon, 15 Jun 1998 21:54:32 -0500 -* From: Ian A Watson <WATSON_IAN_A@lilly.com> -* Subject: Mangler Crash - EQUIVALENCE(I,glerf(P)) - COMMON /foo/ glerf(3) diff --git a/gcc/testsuite/g77.f-torture/noncompile/check0.f b/gcc/testsuite/g77.f-torture/noncompile/check0.f deleted file mode 100644 index fc3c6ca730e..00000000000 --- a/gcc/testsuite/g77.f-torture/noncompile/check0.f +++ /dev/null @@ -1,11 +0,0 @@ -CCC Abort fixed by: -CCC1998-04-21 Jim Wilson <wilson@cygnus.com> -CCC -CCC * stmt.c (check_seenlabel): When search for line number note for -CCC warning, handle case where there is no such note. - logical l(10) - integer i(10) - goto (10,20),l - goto (10,20),i - 10 stop - 20 end diff --git a/gcc/testsuite/g77.f-torture/noncompile/noncompile.exp b/gcc/testsuite/g77.f-torture/noncompile/noncompile.exp deleted file mode 100644 index 7087aa2eb4d..00000000000 --- a/gcc/testsuite/g77.f-torture/noncompile/noncompile.exp +++ /dev/null @@ -1,39 +0,0 @@ -# Copyright (C) 1988, 90, 91, 92, 97, 1998 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 2 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 this program; if not, write to the Free Software -# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -# Please email any bugs, comments, and/or additions to this file to: -# bug-gcc@prep.ai.mit.edu - -# This file was written by Jeff Law. (law@cs.utah.edu) - -# -# These tests come from Torbjorn Granlund (tege@cygnus.com) -# C torture test suite. -# - -load_lib mike-g77.exp - -# Test check0.f -prebase - -set src_code check0.f -# Not really sure what the error should be here... -set compiler_output ".*:8.*:9" - -set groups {passed gcc-noncompile} - -postbase $src_code $run $groups - |