OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Correct decls for functions which do not pass actual arguments.

Browse Source 
A wrong decl for findloc caused segfaults at runtime on
Darwin for ARM; however, this is only a symptom of a larger
disease: The declarations for our library functions are often
inconsistent.  This patch solves that problem for the functions
specifically for the functions for which we do not pass optional
arguments, i.e. findloc and (min|max)loc.

It works by saving the symbols of the specific functions in
gfc_intrinsic_namespace and by generating the formal argument
lists from the actual argument lists.  Because symbols are
re-used, so are the backend decls.

gcc/fortran/ChangeLog:

	PR fortran/97454
	* gfortran.h (gfc_symbol): Add pass_as_value flag.
	(gfc_copy_formal_args_intr): Add optional argument
	copy_type.
	(gfc_get_intrinsic_function_symbol): Add prototype.
	(gfc_find_intrinsic_symbol): Add prototype.
	* intrinsic.c (gfc_get_intrinsic_function_symbol): New function.
	(gfc_find_intrinsic_symbol): New function.
	* symbol.c (gfc_copy_formal_args_intr): Add argument. Handle case
	where the type needs to be copied from the actual argument.
	* trans-intrinsic.c (remove_empty_actual_arguments): New function.
	(specific_intrinsic_symbol): New function.
	(gfc_conv_intrinsic_funcall): Use it.
	(strip_kind_from_actual): Adjust so that the expression pointer
	is set to NULL.
	(gfc_conv_intrinsic_minmaxloc): Likewise.
	(gfc_conv_intrinsic_minmaxval): Adjust removal of dim.
	* trans-types.c (gfc_sym_type): If sym->pass_as_value is set, do
	not pass by reference.
This commit is contained in:
Thomas Koenig 2020-10-25 13:16:16 +01:00
parent d7ddd287ca
commit 47d13acbda
5 changed files with 155 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
gcc/fortran/gfortran.h
View File

@ -1673,6 +1673,9 @@ typedef struct gfc_symbol
/* Set if the dummy argument of a procedure could be an array despite
being called with a scalar actual argument. */
unsigned maybe_array:1;
/* Set if this should be passed by value, but is not a VALUE argument
according to the Fortran standard. */
unsigned pass_as_value:1;
int refs;
struct gfc_namespace *ns; /* namespace containing this symbol */
@ -3248,7 +3251,7 @@ bool gfc_type_is_extension_of (gfc_symbol *, gfc_symbol *);
bool gfc_type_compatible (gfc_typespec *, gfc_typespec *);
void gfc_copy_formal_args_intr (gfc_symbol *, gfc_intrinsic_sym *,
gfc_actual_arglist *);
gfc_actual_arglist *, bool copy_type = false);
void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too */
@ -3273,6 +3276,8 @@ void gfc_intrinsic_done_1 (void);
char gfc_type_letter (bt, bool logical_equals_int = false);
gfc_symbol * gfc_get_intrinsic_sub_symbol (const char *);
gfc_symbol *gfc_get_intrinsic_function_symbol (gfc_expr *);
gfc_symbol *gfc_find_intrinsic_symbol (gfc_expr *);
bool gfc_convert_type (gfc_expr *, gfc_typespec *, int);
bool gfc_convert_type_warn (gfc_expr *, gfc_typespec *, int, int,
bool array = false);

37
gcc/fortran/intrinsic.c
View File

@ -122,6 +122,43 @@ gfc_get_intrinsic_sub_symbol (const char *name)
return sym;
}
/* Get a symbol for a resolved function, with its special name. The
actual argument list needs to be set by the caller. */
gfc_symbol *
gfc_get_intrinsic_function_symbol (gfc_expr *expr)
{
gfc_symbol *sym;
gfc_get_symbol (expr->value.function.name, gfc_intrinsic_namespace, &sym);
sym->attr.external = 1;
sym->attr.function = 1;
sym->attr.always_explicit = 1;
sym->attr.proc = PROC_INTRINSIC;
sym->attr.flavor = FL_PROCEDURE;
sym->result = sym;
if (expr->rank > 0)
{
sym->attr.dimension = 1;
sym->as = gfc_get_array_spec ();
sym->as->type = AS_ASSUMED_SHAPE;
sym->as->rank = expr->rank;
}
return sym;
}
/* Find a symbol for a resolved intrinsic procedure, return NULL if
not found. */
gfc_symbol *
gfc_find_intrinsic_symbol (gfc_expr *expr)
{
gfc_symbol *sym;
gfc_find_symbol (expr->value.function.name, gfc_intrinsic_namespace,
0, &sym);
return sym;
}
/* Return a pointer to the name of a conversion function given two
typespecs. */

25
gcc/fortran/symbol.c
View File

@ -4645,12 +4645,13 @@ add_proc_interface (gfc_symbol *sym, ifsrc source, gfc_formal_arglist *formal)
declaration statement (see match_proc_decl()) to create the formal
args based on the args of a given named interface.
When an actual argument list is provided, skip the absent arguments.
When an actual argument list is provided, skip the absent arguments
unless copy_type is true.
To be used together with gfc_se->ignore_optional. */
void
gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src,
gfc_actual_arglist *actual)
gfc_actual_arglist *actual, bool copy_type)
{
gfc_formal_arglist *head = NULL;
gfc_formal_arglist *tail = NULL;
@ -4677,13 +4678,27 @@ gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src,
act_arg = act_arg->next;
continue;
}
act_arg = act_arg->next;
}
formal_arg = gfc_get_formal_arglist ();
gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
/* May need to copy more info for the symbol. */
formal_arg->sym->ts = curr_arg->ts;
if (copy_type && act_arg->expr != NULL)
{
formal_arg->sym->ts = act_arg->expr->ts;
if (act_arg->expr->rank > 0)
{
formal_arg->sym->attr.dimension = 1;
formal_arg->sym->as = gfc_get_array_spec();
formal_arg->sym->as->rank = -1;
formal_arg->sym->as->type = AS_ASSUMED_RANK;
}
if (act_arg->name && strcmp (act_arg->name, "%VAL") == 0)
formal_arg->sym->pass_as_value = 1;
}
else
formal_arg->sym->ts = curr_arg->ts;
formal_arg->sym->attr.optional = curr_arg->optional;
formal_arg->sym->attr.value = curr_arg->value;
formal_arg->sym->attr.intent = curr_arg->intent;
@ -4708,6 +4723,8 @@ gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src,
/* Validate changes. */
gfc_commit_symbol (formal_arg->sym);
if (actual)
act_arg = act_arg->next;
}
/* Add the interface to the symbol. */

123
gcc/fortran/trans-intrinsic.c
View File

@ -4238,12 +4238,60 @@ gfc_get_symbol_for_expr (gfc_expr * expr, bool ignore_optional)
return sym;
}
/* Remove empty actual arguments. */
static void
remove_empty_actual_arguments (gfc_actual_arglist **ap)
{
while (*ap)
{
if ((*ap)->expr == NULL)
{
gfc_actual_arglist *r = *ap;
*ap = r->next;
r->next = NULL;
gfc_free_actual_arglist (r);
}
else
ap = &((*ap)->next);
}
}
/* Generate the right symbol for the specific intrinsic function and
modify the expr accordingly. This assumes that absent optional
arguments should be removed. FIXME: This should be extended for
procedures which do not ignore optional arguments (PR 97454). */
gfc_symbol *
specific_intrinsic_symbol (gfc_expr *expr)
{
gfc_symbol *sym;
sym = gfc_find_intrinsic_symbol (expr);
if (sym == NULL)
{
sym = gfc_get_intrinsic_function_symbol (expr);
sym->ts = expr->ts;
if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl)
sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
gfc_copy_formal_args_intr (sym, expr->value.function.isym,
expr->value.function.actual, true);
sym->backend_decl
= gfc_get_extern_function_decl (sym, expr->value.function.actual);
}
remove_empty_actual_arguments (&(expr->value.function.actual));
return sym;
}
/* Generate a call to an external intrinsic function. */
static void
gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
{
gfc_symbol *sym;
vec<tree, va_gc> *append_args;
bool specific_symbol;
gcc_assert (!se->ss || se->ss->info->expr == expr);
@ -4252,7 +4300,28 @@ gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
else
gcc_assert (expr->rank == 0);
sym = gfc_get_symbol_for_expr (expr, se->ignore_optional);
switch (expr->value.function.isym->id)
{
case GFC_ISYM_FINDLOC:
case GFC_ISYM_MAXLOC:
case GFC_ISYM_MINLOC:
case GFC_ISYM_MAXVAL:
case GFC_ISYM_MINVAL:
specific_symbol = true;
break;
default:
specific_symbol = false;
}
if (specific_symbol)
{
/* Need to copy here because specific_intrinsic_symbol modifies
expr to omit the absent optional arguments. */
expr = gfc_copy_expr (expr);
sym = specific_intrinsic_symbol (expr);
}
else
sym = gfc_get_symbol_for_expr (expr, se->ignore_optional);
/* Calls to libgfortran_matmul need to be appended special arguments,
to be able to call the BLAS ?gemm functions if required and possible. */
@ -4302,7 +4371,11 @@ gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
append_args);
gfc_free_symbol (sym);
if (specific_symbol)
gfc_free_expr (expr);
else
gfc_free_symbol (sym);
}
/* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
@ -5081,12 +5154,10 @@ strip_kind_from_actual (gfc_actual_arglist * actual)
{
for (gfc_actual_arglist *a = actual; a; a = a->next)
{
gfc_actual_arglist *b = a->next;
if (b && b->name && strcmp (b->name, "kind") == 0)
if (a && a->name && strcmp (a->name, "kind") == 0)
{
a->next = b->next;
b->next = NULL;
gfc_free_actual_arglist (b);
gfc_free_expr (a->expr);
a->expr = NULL;
}
}
}
@ -5224,20 +5295,17 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
if (arrayexpr->ts.type == BT_CHARACTER)
{
gfc_actual_arglist *a, *b;
gfc_actual_arglist *a;
a = actual;
strip_kind_from_actual (a);
while (a->next)
while (a)
{
b = a->next;
if (b->expr == NULL || strcmp (b->name, "dim") == 0)
if (a->name && strcmp (a->name, "dim") == 0)
{
a->next = b->next;
b->next = NULL;
gfc_free_actual_arglist (b);
gfc_free_expr (a->expr);
a->expr = NULL;
}
else
a = b;
a = a->next;
}
gfc_conv_intrinsic_funcall (se, expr);
return;
@ -5996,29 +6064,16 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
if (arrayexpr->ts.type == BT_CHARACTER)
{
gfc_actual_arglist *a2, *a3;
a2 = actual->next; /* dim */
a3 = a2->next; /* mask */
if (a2->expr == NULL || expr->rank == 0)
gfc_actual_arglist *dim = actual->next;
if (expr->rank == 0 && dim->expr != 0)
{
if (a3->expr == NULL)
actual->next = NULL;
else
{
actual->next = a3;
a2->next = NULL;
}
gfc_free_actual_arglist (a2);
gfc_free_expr (dim->expr);
dim->expr = NULL;
}
else
if (a3->expr == NULL)
{
a2->next = NULL;
gfc_free_actual_arglist (a3);
}
gfc_conv_intrinsic_funcall (se, expr);
return;
}
type = gfc_typenode_for_spec (&expr->ts);
/* Initialize the result. */
limit = gfc_create_var (type, "limit");

3
gcc/fortran/trans-types.c
View File

@ -2246,7 +2246,8 @@ gfc_sym_type (gfc_symbol * sym)
else
type = gfc_typenode_for_spec (&sym->ts, sym->attr.codimension);
if (sym->attr.dummy && !sym->attr.function && !sym->attr.value)
if (sym->attr.dummy && !sym->attr.function && !sym->attr.value
&& !sym->pass_as_value)
byref = 1;
else
byref = 0;