Question about interpreting a decl dump
Thomas Koenig
tkoenig@netcologne.de
Sat Oct 10 11:11:38 GMT 2020
Am 09.10.20 um 21:34 schrieb Iain Sandoe:
> Hi Thomas,
>
> Thomas Koenig via Fortran <fortran@gcc.gnu.org> wrote:
>>> If the last node in the list is void_list_node (a TREE_LIST node
>>> whose TREE_VALUE is the void_type_ node), then functions of this type
>>> do not take variable arguments. Otherwise, they do take a variable
>>> number of arguments.
>>
>> > HTH
>>
>> That does help, a lot.
>>
>> It means that this decl is correct, and many others are not. I'll do
>> some more digging to see where the void_list_node should have been
>> appended.
>
> .. that is a second issue then :)
... which I am trying to work on, see attached patch.
With this version, I get something I do not understand. With the
test case
program main
! character, dimension(2) :: a
character(2), dimension(2,2) :: b
integer(8) :: i(2)
! a = ["a", "b"]
! i = findloc(a,"b",1,kind=8)
b= reshape(["a","b","c","d"],[2,2])
i = findloc(b,"c")
end
and a compiler where the Fortran parts have been built with -O0,
I get
Starting program: /home/ig25/Gcc/trunk-bin/gcc/f951 findloc.f90
MAIN__
Breakpoint 1, specific_intrinsic_symbol (expr=0x2b99d30) at
../../trunk/gcc/fortran/trans-intrinsic.c:4269
4269 sym = gfc_find_intrinsic_symbol (expr);
(gdb) b gfc_get_function_type
Breakpoint 2 at 0xa53198: file ../../trunk/gcc/fortran/trans-types.c,
line 3010.
(gdb) c
Continuing.
Breakpoint 2, gfc_get_function_type (sym=0x2baf140,
actual_args=0x2b44020) at ../../trunk/gcc/fortran/trans-types.c:3010
3010 vec<tree, va_gc> *typelist = NULL;
(gdb) call debug(sym)
|| symbol: '_gfortran_findloc0_s1'
type spec : (INTEGER 8)
attributes: (PROCEDURE INTRINSIC-PROC DIMENSION EXTERNAL FUNCTION
ALWAYS-EXPLICIT)
Array spec:(1 [0] AS_ASSUMED_SHAPE () () )
result: _gfortran_findloc0_s1
Formal arglist: array value back
so, fine so far. Single step until the line
3187 if (is_varargs)
(gdb)
3190 type = build_function_type_vec (type, typelist);
(gdb) p is_varargs
$1 = false
so that is fine. Furthermore:
gdb) b build_function_type_array
Breakpoint 3 at 0x11d34e0: file ../../trunk/gcc/tree.c, line 8472.
(gdb) c
Continuing.
Breakpoint 3, build_function_type_array (return_type=0x7ffff7126f18,
n=6, arg_types=0x7ffff7118758) at ../../trunk/gcc/tree.c:8472
8472 return build_function_type_array_1 (false, return_type, n,
arg_types);
then step into build_function_type_array_1
build_function_type_array_1 (arg_types=0x7ffff7118758, n=<optimized
out>, return_type=0x7ffff7126f18, vaargs=false) at
../../trunk/gcc/tree.c:8460
8460 t = tree_cons (NULL_TREE, arg_types[i], t);
so vaargs is correctly set to false. However, the value returned
from build_function_type_array_1 does not look correct upon
return:
3190 type = build_function_type_vec (type, typelist);
Value returned is $6 = (tree_node *) 0x7ffff72eb348
(gdb) call debug_tree($6)
<function_type 0x7ffff72eb348
type <void_type 0x7ffff7126f18 void VOID
align:8 warn_if_not_align:0 symtab:0 alias-set -1
canonical-type 0x7ffff7126f18
pointer_to_this <pointer_type 0x7ffff712d000>>
QI
size <integer_cst 0x7ffff7111ca8 type <integer_type 0x7ffff71260a8
bitsizetype> constant 8>
unit-size <integer_cst 0x7ffff7111cc0 type <integer_type
0x7ffff7126000 sizetype> constant 1>
align:8 warn_if_not_align:0 symtab:0 alias-set -1 canonical-type
0x7ffff72eb3f0
arg-types <tree_list 0x7ffff72e6848
value <reference_type 0x7ffff72e9690 type <record_type
0x7ffff72e9150 array01_integer(kind=8)>
unsigned DI
size <integer_cst 0x7ffff7111bb8 constant 64>
unit-size <integer_cst 0x7ffff7111bd0 constant 8>
align:64 warn_if_not_align:0 symtab:0 alias-set -1
canonical-type 0x7ffff72e9738>
chain <tree_list 0x7ffff72e6820 value <reference_type
0x7ffff72e9d20>
chain <tree_list 0x7ffff72e67f8 value <reference_type
0x7ffff72eb2a0>
chain <tree_list 0x7ffff72e67d0 value <boolean_type
0x7ffff7133000 logical(kind=4)>
chain <tree_list 0x7ffff72e67a8 value <integer_type
0x7ffff7126738 integer(kind=8)>
chain <tree_list 0x7ffff72e6780 value
<integer_type 0x7ffff7126738 integer(kind=8)> chain <tree_list
0x7ffff7125b18>>>>>>>>
That seems to be a varargs function, and I am at a loss to understand
why. Could you shed any insight?
Regards
Thomas
-------------- next part --------------
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index 6e265f4520d..416fb5a7bc5 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -53,6 +53,7 @@ static void show_symbol (gfc_symbol *);
static void show_typespec (gfc_typespec *);
static void show_ref (gfc_ref *);
static void show_attr (symbol_attribute *, const char *);
+static void show_actual_arglist (gfc_actual_arglist *);
/* Allow dumping of an expression in the debugger. */
void gfc_debug_expr (gfc_expr *);
@@ -84,6 +85,15 @@ void debug (symbol_attribute attr)
debug (&attr);
}
+void debug (gfc_actual_arglist *a)
+{
+ FILE *tmp = dumpfile;
+ dumpfile = stderr;
+ show_actual_arglist (a);
+ fputc ('\n', dumpfile);
+ dumpfile = tmp;
+}
+
void debug (gfc_expr *e)
{
FILE *tmp = dumpfile;
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index d0cea838444..37fed61a679 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1664,6 +1664,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 */
@@ -3239,7 +3242,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 */
@@ -3264,6 +3267,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);
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index ef33587a774..938a2f3606b 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -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. */
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index df1e8965daa..50b72294345 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -4650,7 +4650,7 @@ add_proc_interface (gfc_symbol *sym, ifsrc source, gfc_formal_arglist *formal)
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 +4677,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)
+ {
+ 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 +4722,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. */
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 8729bc12152..d866d512c5a 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -4238,12 +4238,62 @@ 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. */
+
+void debug_tree (tree);
+
+static 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);
+ debug_tree (sym->backend_decl);
+ fprintf (stderr,"\n");
+ }
+ remove_empty_actual_arguments (&(expr->value.function.actual));
+ // debug (expr);
+ // debug (sym);
+ 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 is_findloc;
gcc_assert (!se->ss || se->ss->info->expr == expr);
@@ -4252,7 +4302,24 @@ 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:
+ is_findloc = true;
+ break;
+ default:
+ is_findloc = false;
+ }
+
+ if (is_findloc)
+ {
+ 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 +4369,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 (is_findloc)
+ gfc_free_expr (expr);
+ else
+ gfc_free_symbol (sym);
}
/* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
@@ -5081,12 +5152,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 +5293,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;
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 17f3ccc1d4e..b15ea667411 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -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;
More information about the Fortran
mailing list