[patch, fortran] PR29651 (wrong code), PR30933 (undefined reference)

[Daniel Franke <franke dot daniel at gmail dot com>]

Attached patch represents a first attempt to fix wrong-code as:

  integer(2) :: i1 = 0, i2 = 0, s
  call signal(i1, i2, s)
  end

... which is translated to ... 
  {
    int4 D.908;
    int4 D.907;
    int4 D.906;

    D.906 = (int4) i1;
    D.907 = (int4) i2;
    D.908 = (int4) s;
    _gfortran_signal_sub_int (&D.906, &D.907, &D.908);
  }
Obiously, "status2 = (int2) D.908" is missing.

The proposed patch gives:
  {
    int4 status.2;
    int4 handler.1;
    int4 number.0;

    number.0 = (int4) i1;
    handler.1 = (int4) i2;
    _gfortran_signal_sub_int (&number.0, &handler.1, &status.2);
    s = (int2) status.2;
  }


Based on the patch from earlier this week, the current changes are straight 
forward: in gfc_trans_call(), branch off if the subroutine to translate is an 
intrinsic. Then, the actual translation is done similar to the translation of 
intrinsic functions. Unknown intrinsics, i.e. those not yet translated 
manually, are routed back to the original pathway.

A couple of questions arose while implementing this:
 (1) I chose gfc_trans_call as the place where to branch off, this is somewhat 
arbitrary. Are there functions further down in path which are better suited 
for this purpose?
 (2) To simplify the resolution and translation process, I re-used the 
function declarations gfor_fndecl_*. Is this permissable for subroutines?
 (3) If yes, could those intrinsics that are available as subroutines and 
functions (e. g. SIGNAL) share such function declarations? If yes, the 
subroutine could be translated to the equivalent function (or vice versa), 
the library could be simplified accordingly. 

The attached patch fixes two elements of a set of problems. I will continue to 
work on them after clarification of above questions.


:ADDPATCH fortran:

gcc/fortran:
2007-05-31  Daniel Franke  <franke.daniel@gmail.com>

	PR fortran/29651
	PR fortran/30933
	* iresolve.c (gfc_resolve_exit, gfc_resolve_signal_sub): Removed.
	* intrinsic.c (add_subroutines): Removed resolver-functions 
	from EXIT and SIGNAL.
	* trans.h (gfc_conv_intrinsic_subroutine):  New prototype.
	* trans-decl.c (gfor_fndecl_exit_sub, gfor_fndecl_signal_sub,
	gfor_fndecl_signal_sub_int): New subroutine declarations.
	(gfc_build_intrinsic_function_decls): Added subroutine declarations.
	* trans-stmt.c (gfc_trans_call): Translate intrinsic subroutines via ...
	* trans-intrinsic.c (gfc_conv_intrinsic_subroutine): ... this new function.
	(gfc_conv_intrinsic_exit_sub): New.
	(gfc_conv_intrinsic_signal_sub): New.


libgfortran:
	PR fortran/30933
	* intrinsics/exit.c(exit_i8): Removed.
	(exit_i4): Renamed to 'exit_sub'.
	* gfortran.map: Removed exit_i[48], added exit_sub.


Regtested on i686-pc-linux-gnu. Eventually, ok for trunk?


Regards
	Daniel


P.S. While we are at it, PR29240 asks for a third argument to the SIGNAL 
function. Could someone comment on my concerns given there? If the request is 
reconfirmed, I will add it ...

Index: gcc/fortran/intrinsic.c
===================================================================
--- gcc/fortran/intrinsic.c	(revision 125201)
+++ gcc/fortran/intrinsic.c	(working copy)
@@ -2470,7 +2470,7 @@
 	      c, BT_INTEGER, 4, REQUIRED);
 
   add_sym_1s ("exit", GFC_ISYM_EXIT, NOT_ELEMENTAL, BT_UNKNOWN, 0, GFC_STD_GNU,
-	      gfc_check_exit, NULL, gfc_resolve_exit,
+	      gfc_check_exit, NULL, NULL,
 	      st, BT_INTEGER, di, OPTIONAL);
 
   if ((gfc_option.allow_std & GFC_STD_GNU) || gfc_option.flag_all_intrinsics)
@@ -2552,7 +2552,7 @@
 	      st, BT_INTEGER, di, OPTIONAL);
 
   add_sym_3s ("signal", GFC_ISYM_SIGNAL, NOT_ELEMENTAL, BT_UNKNOWN, 0, GFC_STD_GNU,
-	      gfc_check_signal_sub, NULL, gfc_resolve_signal_sub,
+	      gfc_check_signal_sub, NULL, NULL,
 	      num, BT_INTEGER, di, REQUIRED, han, BT_UNKNOWN, 0, REQUIRED,
 	      st, BT_INTEGER, di, OPTIONAL);
 
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c	(revision 125201)
+++ gcc/fortran/trans-stmt.c	(working copy)
@@ -329,10 +329,19 @@
     {
 
       /* Translate the call.  */
-      has_alternate_specifier
-	= gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual,
-				  NULL_TREE);
+      if (code->resolved_sym->attr.proc == PROC_INTRINSIC)
+	{
+	  gfc_intrinsic_sym *isym;
+	  isym = gfc_find_subroutine (code->symtree->n.sym->name);
 
+	  has_alternate_specifier = false;
+	  gfc_conv_intrinsic_subroutine(&se, isym, code->resolved_sym, code->ext.actual);
+	}
+      else
+        has_alternate_specifier
+	  = gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual,
+				    NULL_TREE);
+
       /* A subroutine without side-effect, by definition, does nothing!  */
       TREE_SIDE_EFFECTS (se.expr) = 1;
 
@@ -398,8 +407,16 @@
       gfc_init_block (&block);
 
       /* Add the subroutine call to the block.  */
-      gfc_conv_function_call (&loopse, code->resolved_sym, code->ext.actual,
-			      NULL_TREE);
+      if (code->resolved_sym->attr.proc == PROC_INTRINSIC)
+	{
+	  gfc_intrinsic_sym *isym;
+	  isym = gfc_find_subroutine (code->symtree->n.sym->name);
+
+	  gfc_conv_intrinsic_subroutine(&se, isym, code->resolved_sym, code->ext.actual);
+	}
+      else
+        gfc_conv_function_call (&loopse, code->resolved_sym, code->ext.actual,
+				NULL_TREE);
       gfc_add_expr_to_block (&loopse.pre, loopse.expr);
 
       gfc_add_block_to_block (&block, &loopse.pre);
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h	(revision 125201)
+++ gcc/fortran/trans.h	(working copy)
@@ -304,6 +304,10 @@
 /* Intrinsic function handling.  */
 void gfc_conv_intrinsic_function (gfc_se *, gfc_expr *);
 
+/* intrinsic subroutine handlng.  */
+void gfc_conv_intrinsic_subroutine(gfc_se *, gfc_intrinsic_sym *, 
+				   gfc_symbol *, gfc_actual_arglist *);
+
 /* Does an intrinsic map directly to an external library call.  */
 int gfc_is_intrinsic_libcall (gfc_expr *);
 
@@ -556,7 +560,12 @@
 extern GTY(()) tree gfor_fndecl_si_kind;
 extern GTY(()) tree gfor_fndecl_sr_kind;
 
+/* Intrinsic subroutines.  */
+extern GTY(()) tree gfor_fndecl_exit_sub;
+extern GTY(()) tree gfor_fndecl_signal_sub;
+extern GTY(()) tree gfor_fndecl_signal_sub_int;
 
+
 /* True if node is an integer constant.  */
 #define INTEGER_CST_P(node) (TREE_CODE(node) == INTEGER_CST)
 
Index: gcc/fortran/iresolve.c
===================================================================
--- gcc/fortran/iresolve.c	(revision 125201)
+++ gcc/fortran/iresolve.c	(working copy)
@@ -2660,38 +2660,6 @@
 }
 
 
-void
-gfc_resolve_signal_sub (gfc_code *c)
-{
-  const char *name;
-  gfc_expr *number, *handler, *status;
-  gfc_typespec ts;
-
-  number = c->ext.actual->expr;
-  handler = c->ext.actual->next->expr;
-  status = c->ext.actual->next->next->expr;
-  ts.type = BT_INTEGER;
-  ts.kind = gfc_c_int_kind;
-
-  /* handler can be either BT_INTEGER or BT_PROCEDURE  */
-  if (handler->ts.type == BT_INTEGER)
-    {
-      if (handler->ts.kind != gfc_c_int_kind)
-	gfc_convert_type (handler, &ts, 2);
-      name = gfc_get_string (PREFIX ("signal_sub_int"));
-    }
-  else
-    name = gfc_get_string (PREFIX ("signal_sub"));
-
-  if (number->ts.kind != gfc_c_int_kind)
-    gfc_convert_type (number, &ts, 2);
-  if (status != NULL && status->ts.kind != gfc_c_int_kind)
-    gfc_convert_type (status, &ts, 2);
-
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
-}
-
-
 /* Resolve the SYSTEM intrinsic subroutine.  */
 
 void
@@ -2725,24 +2693,6 @@
 }
 
 
-/* Resolve the EXIT intrinsic subroutine.  */
-
-void
-gfc_resolve_exit (gfc_code *c)
-{
-  const char *name;
-  int kind;
-
-  if (c->ext.actual->expr != NULL)
-    kind = c->ext.actual->expr->ts.kind;
-  else
-    kind = gfc_default_integer_kind;
-
-  name = gfc_get_string (PREFIX ("exit_i%d"), kind);
-  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
-}
-
-
 /* Resolve the FLUSH intrinsic subroutine.  */
 
 void
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(revision 125201)
+++ gcc/fortran/trans-decl.c	(working copy)
@@ -143,6 +143,12 @@
 tree gfor_fndecl_si_kind;
 tree gfor_fndecl_sr_kind;
 
+/* Intrinsic subroutines.  */
+tree gfor_fndecl_exit_sub;
+tree gfor_fndecl_signal_sub;
+tree gfor_fndecl_signal_sub_int;
+
+
 /* BLAS gemm functions.  */
 tree gfor_fndecl_sgemm;
 tree gfor_fndecl_dgemm;
@@ -2231,6 +2237,23 @@
     gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
 				     gfc_int4_type_node,
 				     0);
+
+  gfor_fndecl_exit_sub =
+    gfc_build_library_function_decl (get_identifier (PREFIX("exit_sub")),
+				     void_type_node,
+				     1, gfc_c_int_type_node);
+
+  gfor_fndecl_signal_sub = 
+    gfc_build_library_function_decl (get_identifier (PREFIX("signal_sub")),
+				     void_type_node,
+				     3, gfc_c_int_type_node,
+				     gfc_c_int_type_node, gfc_c_int_type_node);
+
+  gfor_fndecl_signal_sub_int = 
+    gfc_build_library_function_decl (get_identifier (PREFIX("signal_sub_int")),
+				     void_type_node,
+				     3, gfc_c_int_type_node,
+				     gfc_c_int_type_node, gfc_c_int_type_node);
 }
 
 
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c	(revision 125201)
+++ gcc/fortran/trans-intrinsic.c	(working copy)
@@ -4164,4 +4164,155 @@
     }
 }
 
+
+
+
+/* generate code for intrinsic subroutines  */
+
+static void
+gfc_conv_intrinsic_subroutine_args (gfc_se * se, gfc_intrinsic_arg * formal, 
+				    gfc_actual_arglist * actual, tree * argv, int argc)
+{
+  gfc_se argse;
+  int i;
+
+  for (i = 0; i < argc; i++, actual = actual->next, formal = formal->next)
+    {
+      gfc_expr *e = actual->expr;
+
+      gcc_assert(formal);
+
+      /* Skip omitted optional arguments.  */
+      if (!e)
+	continue;
+
+      /* Evaluate the parameter.  This will substitute scalarized
+         references automatically.  */
+      gfc_init_se (&argse, se);
+
+      switch (e->ts.type)
+        {
+          case BT_CHARACTER:
+	    gfc_conv_expr (&argse, e);
+	    gfc_conv_string_parameter (&argse);
+	    argv[i++] = argse.string_length;
+	    break;
+
+	  case BT_PROCEDURE:
+	    gfc_conv_expr_reference (&argse, e);
+	    break;
+
+	  case BT_INTEGER:
+	  case BT_REAL:
+	  case BT_COMPLEX:
+	    gfc_conv_expr_val (&argse, e);
+	    break;
+
+	  default:
+	    gcc_unreachable();
+	}
+
+      /* If an optional argument is itself an optional dummy argument,
+	 check its presence and substitute a null if absent.  */
+      if (e->expr_type ==EXPR_VARIABLE
+	    && e->symtree->n.sym->attr.optional
+	    && formal->optional)
+	gfc_conv_missing_dummy (&argse, e, formal->ts);
+
+      gfc_add_block_to_block (&se->pre, &argse.pre);
+      gfc_add_block_to_block (&se->post, &argse.post);
+      argv[i] = argse.expr;
+    }
+}
+
+
+static void
+gfc_conv_intrinsic_exit_sub (gfc_se * se, gfc_symbol * sym ATTRIBUTE_UNUSED, 
+			       gfc_intrinsic_arg * formal, gfc_actual_arglist * actual)
+{
+  tree arg, status, c_int_type;
+
+  c_int_type = gfc_get_int_type (gfc_c_int_kind);
+
+  gfc_conv_intrinsic_subroutine_args(se, formal, actual, &arg, 1);
+
+  if (actual->expr)
+    {
+      status = gfc_create_var (c_int_type, "status");
+      gfc_add_modify_expr(&se->pre, status, fold_convert(c_int_type, arg));
+      status = build_fold_addr_expr (status);
+    }
+  else
+    status = null_pointer_node;
+
+   se->expr = build_call_expr (gfor_fndecl_exit_sub, 1, status);
+}
+
+
+static void
+gfc_conv_intrinsic_signal_sub (gfc_se * se, gfc_symbol * sym ATTRIBUTE_UNUSED, 
+			       gfc_intrinsic_arg * formal, gfc_actual_arglist * actual)
+{
+  tree arg[3], number, handler, status, c_int_type, tmp;
+  gfc_expr *handler_expr, *status_expr;
+
+  c_int_type = gfc_get_int_type (gfc_c_int_kind);
+
+  gfc_conv_intrinsic_subroutine_args(se, formal, actual, arg, 3);
+
+  number = gfc_create_var (c_int_type, "number");
+  gfc_add_modify_expr(&se->pre, number, fold_convert(c_int_type, arg[0]));
+  number = build_fold_addr_expr (number);
+
+  handler_expr = actual->next->expr;
+  if (handler_expr->ts.type == BT_INTEGER)
+    {
+      handler = gfc_create_var (c_int_type, "handler");
+      gfc_add_modify_expr(&se->pre, handler, fold_convert(c_int_type, arg[1]));
+      handler = build_fold_addr_expr (handler);
+      tmp = gfor_fndecl_signal_sub_int;
+    }
+  else
+    {
+      handler = gfc_create_var (TREE_TYPE (arg[1]), "handler");
+      gfc_add_modify_expr(&se->pre, handler, arg[1]);
+      tmp = gfor_fndecl_signal_sub;
+    }
+
+  status_expr  = actual->next->next->expr;
+  if (status_expr)
+    {
+      status = gfc_create_var (c_int_type, "status");
+      gfc_add_modify_expr(&se->post, arg[2], fold_convert(TREE_TYPE (arg[2]), status));
+      status = build_fold_addr_expr (status);
+    }
+  else
+    status = null_pointer_node;
+
+   se->expr = build_call_expr (tmp, 3, number, handler, status);
+}
+
+
+
+void
+gfc_conv_intrinsic_subroutine (gfc_se * se, gfc_intrinsic_sym * isym, 
+			       gfc_symbol *resolved_sym, gfc_actual_arglist * actual)
+{
+  gcc_assert(isym);
+
+  switch (isym->id)
+    {
+      case GFC_ISYM_EXIT:
+	gfc_conv_intrinsic_exit_sub(se, resolved_sym, isym->formal, actual);
+	break;
+
+      case GFC_ISYM_SIGNAL:
+	gfc_conv_intrinsic_signal_sub(se, resolved_sym, isym->formal, actual);
+	break;
+
+      default:
+	gfc_conv_function_call (se, resolved_sym, actual, NULL_TREE);
+    }
+}
+
 #include "gt-fortran-trans-intrinsic.h"
Index: libgfortran/intrinsics/exit.c
===================================================================
--- libgfortran/intrinsics/exit.c	(revision 125201)
+++ libgfortran/intrinsics/exit.c	(working copy)
@@ -39,20 +39,11 @@
 /* SUBROUTINE EXIT(STATUS)
    INTEGER, INTENT(IN), OPTIONAL :: STATUS  */
 
-extern void exit_i4 (GFC_INTEGER_4 *);
-export_proto(exit_i4);
+extern void exit_sub (int *);
+export_proto(exit_sub);
 
 void
-exit_i4 (GFC_INTEGER_4 * status)
+exit_sub (int * status)
 {
   exit (status ? *status : 0);
 }
-
-extern void exit_i8 (GFC_INTEGER_8 *);
-export_proto(exit_i8);
-
-void
-exit_i8 (GFC_INTEGER_8 * status)
-{
-  exit (status ? *status : 0);
-}
Index: libgfortran/gfortran.map
===================================================================
--- libgfortran/gfortran.map	(revision 125201)
+++ libgfortran/gfortran.map	(working copy)
@@ -91,8 +89,7 @@
     _gfortran_eoshift3_8_char;
     _gfortran_etime;
     _gfortran_etime_sub;
-    _gfortran_exit_i4;
-    _gfortran_exit_i8;
+    _gfortran_exit_sub;
     _gfortran_exponent_r10;
     _gfortran_exponent_r16;
     _gfortran_exponent_r4;