f2c_4.f90: Add tests for complex functions

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

	* gfortran.dg/f2c_4.f90:  Add tests for complex functions
	* gfortran.dg/f2c_4.c: Likewise

From-SVN: r101261

gcc/testsuite/gfortran.dg/f2c_4.c

+/*  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 double f2c_4b__(double *);
+extern void f2c_4d__( complex *, complex *);
+extern void f2c_4f__( complex *, int *,complex *);
+extern void f2c_4h__( doublecomplex *, doublecomplex *);
+extern void f2c_4j__( doublecomplex *, int *, doublecomplex *);
 extern void abort (void);
 
 void f2c_4a__(void) {
@@ -7,3 +23,57 @@ void f2c_4a__(void) {
   b=f2c_4b__(&a);
   if ( a != b ) abort();
 }
+
+void f2c_4c__(void) {
+  complex x,ret_val;
+  x.r = 1234;
+  x.i = 5678;
+  f2c_4d__(&ret_val,&x);
+  if ( x.r != ret_val.r && x.i != ret_val.i ) abort();
+}
+
+void f2c_4e__(void) {
+  complex x,ret_val;
+  int i=0;
+  x.r = 1234;
+  x.i = 5678;
+  f2c_4f__(&ret_val,&i,&x);
+  if ( x.r != ret_val.r && x.i != ret_val.i ) abort();
+}
+
+void f2c_4g__(void) {
+  doublecomplex x,ret_val;
+  x.r = 1234;
+  x.i = 5678.0f;
+  f2c_4h__(&ret_val,&x);
+  if ( x.r != ret_val.r && x.i != ret_val.i ) abort();
+}
+
+void f2c_4i__(void) {
+  doublecomplex x,ret_val;
+  int i=0;
+  x.r = 1234.0f;
+  x.i = 5678.0f;
+  f2c_4j__(&ret_val,&i,&x);
+  if ( x.r != ret_val.r && x.i != ret_val.i ) abort();
+}
+
+void f2c_4k__(complex *ret_val, complex *x) {
+  ret_val->r = x->r;
+  ret_val->i = x->i;
+}
+
+void f2c_4l__(complex *ret_val, int *i, complex *x) {
+  ret_val->r = x->r;
+  ret_val->i = x->i;
+}
+
+void f2c_4m__(doublecomplex *ret_val, doublecomplex *x) {
+  ret_val->r = x->r;
+  ret_val->i = x->i;
+}
+
+void f2c_4n__(doublecomplex *ret_val, int *i, doublecomplex *x) {
+  ret_val->r = x->r;
+  ret_val->i = x->i;
+}

gcc/testsuite/gfortran.dg/f2c_4.f90

@@ -4,11 +4,55 @@
 
 ! Check -ff2c calling conventions
 !   Return value of REAL function is promoted to C type double
-!   Addional underscore appended to function name  
-call f2c_4a()
+!   Return value of COMPLEX function is via an extra argument in the
+!    calling sequence that points to where to store the return value
+!   Addional underscore appended to function name
+program f2c_4
+  complex c, f2c_4k, f2c_4l
+  double complex z, f2c_4m, f2c_4n
+  integer i
+
+  ! Promotion of REAL function
+  call f2c_4a()
+
+  ! Return COMPLEX arg - call Fortran routines from C
+  call f2c_4c()
+  call f2c_4e()
+  call f2c_4g()
+  call f2c_4i()
+
+  !  Return COMPLEX arg - call C routines from Fortran 
+  c = cmplx(1234.0,5678.0)
+  z = dcmplx(1234.0d0,5678.0d0)
+  if ( c .ne. f2c_4k(c) )   call abort
+  if ( c .ne. f2c_4l(i,c) ) call abort
+  if ( z .ne. f2c_4m(z) )   call abort
+  if ( z .ne. f2c_4n(i,z) ) call abort
+
 end
 
 real function f2c_4b(x)
   double precision x
   f2c_4b = x
 end
+
+complex function f2c_4d(x)
+  complex x
+  f2c_4d = x
+end
+
+complex function f2c_4f(i,x)
+  complex x
+  integer i
+  f2c_4f = x
+end
+
+double complex function f2c_4h(x)
+  double complex x
+  f2c_4h = x
+end
+
+double complex function f2c_4j(i,x)
+  double complex x
+  f2c_4j = x
+end