Le 20/07/2015 23:55, Thomas Koenig a écrit :
Hi,
I'm back from holiday, so I can finally reply.
Am 13.07.2015 um 21:54 schrieb Thomas Schwinge:
--- gcc/fortran/iresolve.c
+++ gcc/fortran/iresolve.c
@@ -2207,6 +2207,9 @@ gfc_resolve_fe_runtime_error (gfc_code *c)
a->name = "%VAL";
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+ //TODO
+ extern tree gfor_fndecl_runtime_error;
+ c->resolved_sym->backend_decl = gfor_fndecl_runtime_error;
}
This patch actually works quite well. I cannot check the varargs part
on x86_64, but the non-return part is OK. Obviously, the backend decl
for runtime_error needs to be set.
The question is where to put this. iresolve.c seems conceptually wrong,
but I cannot find a clean place to put this in trans-*, without
special casing in strange places.
For what it's worth, I had started hacking on this; I attach what it
looks like after a few cleanups.
I would like to avoid the hack in iresolve. So let's reuse the
frontend-passes.c part of my patch (set resolved_isym) and then handle
it in gfc_conv_intrinsic_subroutine, the way my patch does it (I'm not
sure it actually fixes anything) or some other way (set
resolved_sym->backend_decl as in iresolve, ...).
Mikael
diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c
index 3eda42f..0c5c65f 100644
--- a/gcc/fortran/frontend-passes.c
+++ b/gcc/fortran/frontend-passes.c
@@ -2160,6 +2160,7 @@ runtime_error_ne (gfc_expr *e1, gfc_expr *e2, const char *msg)
gfc_check_fe_runtime_error (c->ext.actual);
gfc_resolve_fe_runtime_error (c);
+ c->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_FE_RUNTIME_ERROR);
if_2 = XCNEW (gfc_code);
if_2->op = EXEC_IF;
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 1155481..bed8a1e 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -195,18 +195,14 @@ gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in,
generated code to be ignored. */
static void
-gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
- tree *argarray, int nargs)
+conv_intrinsic_procedure_args (gfc_se *se, gfc_intrinsic_arg *formal,
+ gfc_actual_arglist *actual, tree *argarray,
+ int nargs)
{
- gfc_actual_arglist *actual;
gfc_expr *e;
- gfc_intrinsic_arg *formal;
gfc_se argse;
int curr_arg;
- formal = expr->value.function.isym->formal;
- actual = expr->value.function.actual;
-
for (curr_arg = 0; curr_arg < nargs; curr_arg++,
actual = actual->next,
formal = formal ? formal->next : NULL)
@@ -248,16 +244,29 @@ gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
}
}
+
+static void
+gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
+ tree *argarray, int nargs)
+{
+ gfc_actual_arglist *actual;
+ gfc_intrinsic_arg *formal;
+
+ formal = expr->value.function.isym->formal;
+ actual = expr->value.function.actual;
+ conv_intrinsic_procedure_args (se, formal, actual, argarray, nargs);
+}
+
+
/* Count the number of actual arguments to the intrinsic function EXPR
including any "hidden" string length arguments. */
static unsigned int
-gfc_intrinsic_argument_list_length (gfc_expr *expr)
+intrinsic_argument_list_length (gfc_actual_arglist *actual)
{
int n = 0;
- gfc_actual_arglist *actual;
- for (actual = expr->value.function.actual; actual; actual = actual->next)
+ for (; actual; actual = actual->next)
{
if (!actual->expr)
continue;
@@ -272,6 +281,13 @@ gfc_intrinsic_argument_list_length (gfc_expr *expr)
}
+static unsigned int
+gfc_intrinsic_argument_list_length (gfc_expr *expr)
+{
+ return intrinsic_argument_list_length (expr->value.function.actual);
+}
+
+
/* Conversions between different types are output by the frontend as
intrinsic functions. We implement these directly with inline code. */
@@ -837,17 +853,31 @@ gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
/* Convert an intrinsic function into an external or builtin call. */
static void
-gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
+conv_intrinsic_lib_procedure (gfc_se * se, tree fndecl,
+ gfc_intrinsic_arg * formal,
+ gfc_actual_arglist * actual)
{
- gfc_intrinsic_map_t *m;
- tree fndecl;
tree rettype;
tree *args;
unsigned int num_args;
- gfc_isym_id id;
- id = expr->value.function.isym->id;
- /* Find the entry for this function. */
+ /* Get the decl and generate the call. */
+ num_args = intrinsic_argument_list_length (actual);
+ args = XALLOCAVEC (tree, num_args);
+
+ conv_intrinsic_procedure_args (se, formal, actual, args, num_args);
+ rettype = TREE_TYPE (TREE_TYPE (fndecl));
+
+ fndecl = build_addr (fndecl, current_function_decl);
+ se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
+}
+
+
+static gfc_intrinsic_map_t *
+find_intrinsic_map (enum gfc_isym_id id, const char *name)
+{
+ gfc_intrinsic_map_t *m;
+
for (m = gfc_intrinsic_map;
m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
{
@@ -858,19 +888,32 @@ gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
if (m->id == GFC_ISYM_NONE)
{
gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
- expr->value.function.name, id);
+ name, id);
}
- /* Get the decl and generate the call. */
- num_args = gfc_intrinsic_argument_list_length (expr);
- args = XALLOCAVEC (tree, num_args);
+ return m;
+}
- gfc_conv_intrinsic_function_args (se, expr, args, num_args);
+
+/* Convert an intrinsic function into an external or builtin call. */
+
+static void
+gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
+{
+ gfc_intrinsic_map_t *m;
+ tree fndecl;
+ gfc_isym_id id;
+ gfc_intrinsic_arg *formal;
+ gfc_actual_arglist *actual;
+
+ id = expr->value.function.isym->id;
+ m = find_intrinsic_map (id, expr->value.function.name);
fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
- rettype = TREE_TYPE (TREE_TYPE (fndecl));
- fndecl = build_addr (fndecl, current_function_decl);
- se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
+ formal = expr->value.function.isym->formal;
+ actual = expr->value.function.actual;
+
+ conv_intrinsic_lib_procedure (se, fndecl, formal, actual);
}
@@ -9481,6 +9524,23 @@ conv_intrinsic_move_alloc (gfc_code *code)
}
+static tree
+conv_intrinsic_runtime_error (gfc_code *c)
+{
+ stmtblock_t block;
+ gfc_se se;
+
+ gfc_start_block (&block);
+
+ gfc_init_se (&se, NULL);
+ conv_intrinsic_lib_procedure (&se, gfor_fndecl_runtime_error,
+ c->resolved_isym->formal,
+ c->ext.actual);
+
+ return gfc_finish_block (&block);
+}
+
+
tree
gfc_conv_intrinsic_subroutine (gfc_code *code)
{
@@ -9531,6 +9591,10 @@ gfc_conv_intrinsic_subroutine (gfc_code *code)
res = conv_co_collective (code);
break;
+ case GFC_ISYM_FE_RUNTIME_ERROR:
+ res = conv_intrinsic_runtime_error (code);
+ break;
+
case GFC_ISYM_SYSTEM_CLOCK:
res = conv_intrinsic_system_clock (code);
break;