[gfortran] Fix PR 20178: Implement g77 / f2c calling conventions

[Tobias Schlüter <tobias dot schlueter at physik dot uni-muenchen dot de>]

Until I mentioned it on the mailing list, noone had complained that we didn't
implement a calling convention compatible with g77.  Unfortunately, people
seem to care, so I implemented it.

The g77 calling convention requires two things for function results that we
didn't do:
- scalar COMPLEX functions return via a hidden argument
- default REAL functions return a C double

I implemented this, but it is currently only enabled via a command-line
option.  If we decide that this is the right way, I propose making
-fno-second-underscore the default also, as compatibility with g77 will then
not be required for this either.

If on the other hand we decide that the f2c calling convention should be the
default (I'm against it, see the PR's audit trail for a few arguments in both
ways), someone should implement the necessary fixes to those routines in
libgfortran that are affected by the calling conventions (i.e. those which can
be passed as an actual argument, and which are REAL*4 or COMPLEX).

This patch has a few warts, but hey -- it comes with documentation :-) (taken
from g77 for the most part).  The last hunk to gfc_get_function_type is
especially nasty, but it works because we will always get the tree for the
symbol there.

Patch bubblestrapped and regtested.  Documentation built with make dvi.  It
also passes the testsuite with -ff2c made the default -- except for
gfortran.fortran-torture/execute/csqrt_1.f90 which uses affected functions as
actual arguments.  The attached two testcases check the basic functionality of
the calling convention and also pass.

- Tobi

2004-03-05  Tobias Schl"uter  <tobias.schlueter@physik.uni-muenchen.de>

	PR fortran/20178
	* gfortran.h (gfc_option): Add flag_f2c.
	* invoke.texi: Document '-ff2c' command line option.
	* lang.opt (ff2c): New entry.
	* options.c (gfc-init_options): Set default calling convention
	to -fno-f2c.
	(handle_options): Set gfc_option.flag_f2c according to requested
	calling	convention.
	* trans-decl.c (gfc_trans_deferred_vars): Change todo error to
	assertion.
	* trans-expr.c (gfc_conv_variable): Correctly dereference access
	to hidden result argument.
	(gfc_conv_function_call): Add hidden result argument to argument
	list if f2c calling conventions requested.  Convert result of default
	REAL function to requested type if f2c calling conventions are used.
	Dereference COMPLEX result if f2c cc are used.
	* trans-types.c (gfc_return_by_reference): Return COMPLEX by reference
	depending on calling conventions.
	(gfc_get_function_type): Correctly make hidden result argument a
	pass-by-reference argument for COMPLEX.  Remove old code which does
	this for derived types.  Get correct function type for default REAL
	function if -ff2c.

! Make sure the f2c calling conventions work
! { dg-do run }
! { dg-options "-ff2c" }

function f(x)
  f = x
end function f

complex function c(a,b)
  c = cmplx (a,b)
end function c

double complex function d(e,f)
  double precision e, f
  d = cmplx (e, f, kind(d))
end function d

subroutine test_with_interface()
  interface
     real function f(x)
       real::x
     end function f
  end interface

  interface
     complex function c(a,b)
       real::a,b
     end function c
  end interface

  interface
     double complex function d(e,f)
       double precision::e,f
     end function d
  end interface
  
  double precision z, w

  x = 8.625
  if (x /= f(x)) call abort ()
  y = f(x)
  if (x /= y) call abort ()

  a = 1.
  b = -1.
  if (c(a,b) /= cmplx(a,b)) call abort ()

  z = 1.
  w = -1.
  if (d(z,w) /= cmplx(z,w, kind(z))) call abort ()
end subroutine test_with_interface

external f, c, d
real f
complex c
double complex d
double precision z, w

x = 8.625
if (x /= f(x)) call abort ()
y = f(x)
if (x /= y) call abort ()

a = 1.
b = -1.
if (c(a,b) /= cmplx(a,b)) call abort ()

z = 1.
w = -1.
if (d(z,w) /= cmplx(z,w, kind(z))) call abort ()

call test_with_interface ()
end

! Some basic testing that calls to the library still work correctly with
! -ff2c
!
! Once the library has support for f2c calling conventions (i.e. passing
! a REAL*4 or COMPLEX-valued intrinsic as procedure argument works), we
! can simply add -ff2c to the list of options to cycle through, and get
! complete coverage.  As of 2005-03-05 this doesn't work.
! { dg-do run }
! { dg-options "-ff2c" }

complex c
double complex d

x = 2.
if ((sqrt(x) - 1.41)**2 > 1.e-4) call abort ()
x = 1.
if ((atan(x) - 3.14/4) ** 2 > 1.e-4) call abort ()
c = (-1.,0.)
if (sqrt(c) /= (0., 1.)) call abort ()
d = c
if (sqrt(d) /= (0._8, 1._8)) call abort ()
end
 

? bak.diff
? curr.diff
? err
? err.diff
? f2c.diff
? f2c2.diff
? missing.diff
? op.diff
? pool.diff
? pool2.diff
? pr19479.diff
? semantic.cache
Index: gfortran.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/gfortran.h,v
retrieving revision 1.59
diff -u -p -r1.59 gfortran.h
--- gfortran.h	28 Feb 2005 00:38:12 -0000	1.59
+++ gfortran.h	5 Mar 2005 15:03:40 -0000
@@ -1402,6 +1402,7 @@ typedef struct
   int flag_no_backend;
   int flag_pack_derived;
   int flag_repack_arrays;
+  int flag_f2c;
 
   int q_kind;
   int r8;
Index: invoke.texi
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/invoke.texi,v
retrieving revision 1.7
diff -u -p -r1.7 invoke.texi
--- invoke.texi	10 Nov 2004 02:35:05 -0000	1.7
+++ invoke.texi	5 Mar 2005 15:03:41 -0000
@@ -143,7 +143,7 @@ by type.  Explanations are in the follow
 @item Code Generation Options
 @xref{Code Gen Options,,Options for Code Generation Conventions}.
 @gccoptlist{
--fno-underscoring  -fno-second-underscore @gol
+-ff2c -fno-underscoring  -fno-second-underscore @gol
 -fbounds-check  -fmax-stack-var-size=@var{n} @gol
 -fpackderived  -frepack-arrays}
 @end table
@@ -508,6 +508,39 @@ it.
 
 
 @table @gcctabopt
+@cindex -ff2c option
+@cindex options, -fno-f2c
+@item -ff2c
+@cindex calling convention
+@cindex @command{f2c} calling convention
+@cindex @command{g77} calling convention
+@cindex libf2c calling convention
+Generate code designed to be compatible with code generated
+by @command{g77} and @command{f2c}.
+
+The calling conventions used by @command{g77} (originally implemented
+in @command{f2c}) require functions that return type
+default @code{REAL} to actually return the C type @code{double}, and
+functions that return type @code{COMPLEX} to return the values via an
+extra argument in the calling sequence that points to where to
+store the return value.  Under the default GNU calling conventions, such
+functions simply return their results as they would in GNU
+C -- default @code{REAL} functions return the C type @code{float}, and
+@code{COMPLEX} functions return the GNU C type @code{complex}.
+
+This does not affect the generation of code that interfaces with
+the @command{libgfortran} library.
+
+@emph{Caution:} It is not a good idea to mix Fortran code compiled
+with @code{-ff2c} with code compiled with the default @code{-fno-f2c}
+calling conventions as, calling @code{COMPLEX} or default @code{REAL}
+functions between program parts which were compiled with different
+calling conventions will break at execution time.
+
+@emph{Caution:} This will break code which passes intrinsic functions
+of type default @code{REAL} or @code{COMPLEX} as actual arguments, as
+the library implementations use the @command{-fno-f2c} calling conventions.
+
 @cindex -fno-underscoring option
 @cindex options, -fno-underscoring
 @item -fno-underscoring
Index: lang.opt
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/lang.opt,v
retrieving revision 1.8
diff -u -p -r1.8 lang.opt
--- lang.opt	31 Oct 2004 01:24:29 -0000	1.8
+++ lang.opt	5 Mar 2005 15:03:41 -0000
@@ -81,6 +81,10 @@ fdump-parse-tree
 F95
 Display the code tree after parsing.
 
+ff2c
+F95
+Use f2c calling convention.
+
 ffixed-form
 F95
 Assume that the source file is fixed form
Index: options.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/options.c,v
retrieving revision 1.17
diff -u -p -r1.17 options.c
--- options.c	30 Jan 2005 18:34:03 -0000	1.17
+++ options.c	5 Mar 2005 15:03:41 -0000
@@ -66,6 +66,7 @@ gfc_init_options (unsigned int argc ATTR
   gfc_option.flag_no_backend = 0;
   gfc_option.flag_pack_derived = 0;
   gfc_option.flag_repack_arrays = 0;
+  gfc_option.flag_f2c = 0;
 
   gfc_option.q_kind = gfc_default_double_kind;
   gfc_option.i8 = 0;
@@ -214,6 +215,10 @@ gfc_handle_option (size_t scode, const c
       gfc_option.warn_unused_labels = value;
       break;
 
+    case OPT_ff2c:
+      gfc_option.flag_f2c = value;
+      break;
+
     case OPT_fdollar_ok:
       gfc_option.flag_dollar_ok = value;
       break;
Index: trans-decl.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-decl.c,v
retrieving revision 1.54
diff -u -p -r1.54 trans-decl.c
--- trans-decl.c	24 Feb 2005 18:26:27 -0000	1.54
+++ trans-decl.c	5 Mar 2005 15:03:42 -0000
@@ -1906,7 +1906,8 @@ gfc_trans_deferred_vars (gfc_symbol * pr
 	    fnbody = gfc_trans_dummy_character (proc_sym->ts.cl, fnbody);
 	}
       else
-	gfc_todo_error ("Deferred non-array return by reference");
+	gcc_assert (gfc_option.flag_f2c
+		    && proc_sym->ts.type == BT_COMPLEX);
     }
 
   for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
@@ -2241,6 +2242,10 @@ gfc_generate_function_code (gfc_namespac
 	  gfc_add_expr_to_block (&block, tmp);
 	}
     }
+  else if (sym->attr.function)
+    {
+      /* Correctly set the result dummy argument.  */
+    }
 
   /* Add all the decls we created during processing.  */
   decl = saved_function_decls;
Index: trans-expr.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-expr.c,v
retrieving revision 1.39
diff -u -p -r1.39 trans-expr.c
--- trans-expr.c	4 Mar 2005 21:03:29 -0000	1.39
+++ trans-expr.c	5 Mar 2005 15:03:42 -0000
@@ -337,6 +337,11 @@ gfc_conv_variable (gfc_se * se, gfc_expr
 	  && !sym->attr.dimension)
 	se->expr = gfc_build_indirect_ref (se->expr);
 
+      /* Dereference scalar hidden result.  */
+      if (sym->result == sym && sym->ts.type == BT_COMPLEX
+	  && !sym->attr.dimension)
+	se->expr = gfc_build_indirect_ref (se->expr);
+
       /* Dereference pointer variables.  */
       if ((sym->attr.pointer || sym->attr.allocatable)
 	  && (sym->attr.dummy
@@ -1114,7 +1119,13 @@ gfc_conv_function_call (gfc_se * se, gfc
 				      convert (gfc_charlen_type_node, len));
 	}
       else
-	gcc_unreachable ();
+	{
+	  gcc_assert (gfc_option.flag_f2c && sym->ts.type == BT_COMPLEX);
+
+	  type = gfc_get_complex_type (sym->ts.kind);
+	  var = gfc_build_addr_expr (NULL, gfc_create_var (type, "cmplx"));
+	  arglist = gfc_chainon_list (arglist, var);
+	}
     }
 
   formal = sym->formal;
@@ -1224,6 +1235,16 @@ gfc_conv_function_call (gfc_se * se, gfc
       && (sym->attr.pointer || (sym->result && sym->result->attr.pointer)))
     se->expr = gfc_build_indirect_ref (se->expr);
 
+  /* f2c calling conventions require a scalar default real function to
+     return a double precision result.  Convert this back to default
+     real.  We only care about the cases that can happen in Fortran 77.
+  */
+  if (gfc_option.flag_f2c && sym->ts.type == BT_REAL 
+      && sym->ts.kind == gfc_default_real_kind && !sym->attr.pointer
+      && !(sym->result && (sym->result->attr.pointer
+			   || sym->result->attr.dimension)))
+    se->expr = fold_convert (gfc_get_real_type (sym->ts.kind), se->expr);
+
   /* A pure function may still have side-effects - it may modify its
      parameters.  */
   TREE_SIDE_EFFECTS (se->expr) = 1;
@@ -1258,7 +1279,10 @@ gfc_conv_function_call (gfc_se * se, gfc
 	      se->string_length = len;
 	    }
 	  else
-	    gcc_unreachable ();
+	    {
+	      gcc_assert (sym->ts.type == BT_COMPLEX && gfc_option.flag_f2c);
+	      se->expr = gfc_build_indirect_ref (var);
+	    }
 	}
     }
 }
Index: trans-types.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/fortran/trans-types.c,v
retrieving revision 1.38
diff -u -p -r1.38 trans-types.c
--- trans-types.c	28 Feb 2005 00:38:12 -0000	1.38
+++ trans-types.c	5 Mar 2005 15:03:42 -0000
@@ -1296,7 +1296,7 @@ gfc_sym_type (gfc_symbol * sym)
     }
 
   /* We currently pass all parameters by reference.
-     See f95_get_function_decl.  For dummy function parameters return the
+     See gfc_get_function_decl.  For dummy function parameters return the
      function type.  */
   if (byref)
     {
@@ -1446,19 +1446,29 @@ gfc_get_derived_type (gfc_symbol * deriv
 int
 gfc_return_by_reference (gfc_symbol * sym)
 {
+  gfc_symbol *result;
+
   if (!sym->attr.function)
     return 0;
 
-  if (sym->result)
-    sym = sym->result;
+  result = sym->result ? sym->result : sym;
 
-  if (sym->attr.dimension)
+  if (result->attr.dimension)
     return 1;
 
-  if (sym->ts.type == BT_CHARACTER)
+  if (result->ts.type == BT_CHARACTER)
     return 1;
 
-  /* Possibly return complex numbers by reference for g77 compatibility.  */
+  /* Possibly return complex numbers by reference for g77 compatibility.
+     We don't do this for calls to intrinsics (as the library uses the
+     -fno-f2c calling convention), nor for calls to functions which always
+     require an explicit interface, as no compatibility problems can
+     arise there.  */
+  if (gfc_option.flag_f2c
+      && result->ts.type == BT_COMPLEX
+      && !sym->attr.intrinsic && !sym->attr.always_explicit)
+    return 1;
+  
   return 0;
 }
 
@@ -1500,7 +1510,7 @@ gfc_get_function_type (gfc_symbol * sym)
 	gfc_conv_const_charlen (arg->ts.cl);
 
       type = gfc_sym_type (arg);
-      if (arg->ts.type == BT_DERIVED
+      if (arg->ts.type == BT_COMPLEX
 	  || arg->attr.dimension
 	  || arg->ts.type == BT_CHARACTER)
 	type = build_reference_type (type);
@@ -1565,7 +1575,17 @@ gfc_get_function_type (gfc_symbol * sym)
   else if (!sym->attr.function || gfc_return_by_reference (sym))
     type = void_type_node;
   else
-    type = gfc_sym_type (sym);
+    {
+      type = gfc_sym_type (sym);
+      if (gfc_option.flag_f2c
+	  && sym->ts.type == BT_REAL
+	  && sym->ts.kind == gfc_default_real_kind)
+	{
+	  sym->ts.kind = gfc_default_double_kind;
+	  type = gfc_sym_type (sym);
+	  sym->ts.kind = gfc_default_real_kind;
+	}
+    }
 
   type = build_function_type (type, typelist);