[patch] Test gfortran -ff2c COMPLEX function return values

[Billinghurst, David (CALCRTS)]

This tests gfortran calling conventions for complex functions
with -ff2c.  Tested with:
 - 4.0 on mips-sgi-irix
 - 4.1 on i686-pc-cygwin
 - g77/gcc 3.3.1 on mips-sgi-irix


2005-06-06  David Billinghurst  <David.Billinghurst@riotinto.com>

	* gfortran.dg/f2c_6.f90: New test
	* gfortran.dg/f2c_6.c: New test

--- /dev/null   Mon Jun  6 10:51:49 2005
+++ f2c_6.f90   Mon Jun  6 13:19:45 2005
@@ -0,0 +1,48 @@
+! { dg-do run }
+! { dg-additional-sources f2c_6.c }
+! { dg-options "-ff2c -w" }
+
+! Check -ff2c calling conventions
+!   Return value of COMPLEX function is via an extra argument in the
+!    calling sequence that points to where to store the return value
+!   Additional underscore appended to function name
+      complex c, f2c_6i, f2c_6j 
+      double complex z, f2c_6k, f2c_6l
+      integer i
+
+!     Call Fortran routines from C
+      call f2c_6a()
+      call f2c_6c()
+      call f2c_6e()
+      call f2c_6g()
+
+!     Now call C routines from Fortran 
+      c = cmplx(1234.0,5678.0)
+      z = dcmplx(1234.0d0,5678.0d0)
+      if ( c .ne. f2c_6i(c) )   call abort
+      if ( c .ne. f2c_6j(i,c) ) call abort
+      if ( z .ne. f2c_6k(z) )   call abort
+      if ( z .ne. f2c_6l(i,z) ) call abort
+
+      end
+
+      complex function f2c_6b(x)
+      complex x
+      f2c_6b = x
+      end
+
+      complex function f2c_6d(i,x)
+      complex x
+      integer i
+      f2c_6d = x
+      end
+
+      double complex function f2c_6f(x)
+      double complex x
+      f2c_6f = x
+      end
+
+      double complex function f2c_6h(i,x)
+      double complex x
+      f2c_6h = x
+      end

--- /dev/null   Mon Jun  6 10:51:49 2005
+++ f2c_6.c     Mon Jun  6 13:21:17 2005
@@ -0,0 +1,72 @@
+/*  Check -ff2c calling conventions
+    Return value of COMPLEX function is via an extra argument in the
+     calling sequence that points to where to store the return value
+    Additional underscore appended to function name
+  
+   Simplified from f2c output and tested with g77 */
+
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+
+extern void f2c_6b__( complex *, complex *);
+extern void f2c_6d__( complex *, int *,complex *);
+extern void f2c_6f__( doublecomplex *, doublecomplex *);
+extern void f2c_6h__( doublecomplex *, int *, doublecomplex *);
+
+extern void abort (void);
+
+void f2c_6a__(void) {
+  complex x,ret_val;
+  x.r = 1234;
+  x.i = 5678;
+  f2c_6b__(&ret_val,&x);
+  if ( x.r != ret_val.r && x.i != ret_val.i ) abort();
+}
+
+void f2c_6c__(void) {
+  complex x,ret_val;
+  int i=0;
+  x.r = 1234;
+  x.i = 5678;
+  f2c_6d__(&ret_val,&i,&x);
+  if ( x.r != ret_val.r && x.i != ret_val.i ) abort();
+}
+
+void f2c_6e__(void) {
+  doublecomplex x,ret_val;
+  x.r = 1234;
+  x.i = 5678.0f;
+  f2c_6f__(&ret_val,&x);
+  if ( x.r != ret_val.r && x.i != ret_val.i ) abort();
+}
+
+void f2c_6g__(void) {
+  doublecomplex x,ret_val;
+  int i=0;
+  x.r = 1234.0f;
+  x.i = 5678.0f;
+  f2c_6h__(&ret_val,&i,&x);
+  if ( x.r != ret_val.r && x.i != ret_val.i ) abort();
+}
+
+void f2c_6i__(complex *ret_val, complex *x) {
+  ret_val->r = x->r;
+  ret_val->i = x->i;
+}
+
+void f2c_6j__(complex *ret_val, int *i, complex *x) {
+  ret_val->r = x->r;
+  ret_val->i = x->i;
+}
+
+void f2c_6k__(doublecomplex *ret_val, doublecomplex *x) {
+  ret_val->r = x->r;
+  ret_val->i = x->i;
+}
+
+void f2c_6l__(doublecomplex *ret_val, int *i, doublecomplex *x) {
+  ret_val->r = x->r;
+  ret_val->i = x->i;
+}


NOTICE
This e-mail and any attachments are private and confidential and may contain privileged information. If you are not an authorised recipient, the copying or distribution of this e-mail and any attachments is prohibited and you must not read, print or act in reliance on this e-mail or attachments.
This notice should not be removed.