[PATCH] Use gfc_add_*_component defines where appropriate

[Bernhard Reutner-Fischer]

A couple of places used gfc_add_component_ref(expr, "string") instead of
the defines from gfortran.h

Regstrapped without regressions, ok for trunk stage3 now / next stage1?

gcc/fortran/ChangeLog

2015-11-29 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* class.c (gfc_add_class_array_ref): Call gfc_add_data_component()
instead of gfc_add_component_ref().
(gfc_get_len_component): Call gfc_add_len_component() instead of
gfc_add_component_ref().
* trans-intrinsic.c (gfc_conv_intrinsic_loc): Call
gfc_add_data_component() instead of gfc_add_component_ref().
* trans.c (gfc_add_finalizer_call): Call
gfc_add_final_component() and gfc_add_size_component() instead
of gfc_add_component_ref.

Signed-off-by: Bernhard Reutner-Fischer <***@gmail.com>
---
gcc/fortran/class.c | 4 ++--
gcc/fortran/trans-intrinsic.c | 2 +-
gcc/fortran/trans.c | 4 ++--
3 files changed, 5 insertions(+), 5 deletions(-)

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 8b49ae9..027cb89 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -258,7 +258,7 @@ gfc_add_class_array_ref (gfc_expr *e)
int rank = CLASS_DATA (e)->as->rank;
gfc_array_spec *as = CLASS_DATA (e)->as;
gfc_ref *ref = NULL;
- gfc_add_component_ref (e, "_data");
+ gfc_add_data_component (e);
e->rank = rank;
for (ref = e->ref; ref; ref = ref->next)
if (!ref->next)
@@ -584,7 +584,7 @@ gfc_get_len_component (gfc_expr *e)
ref = ref->next;
}
/* And replace if with a ref to the _len component. */
- gfc_add_component_ref (ptr, "_len");
+ gfc_add_len_component (ptr);
return ptr;
}

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 1dabc26..2ef0709 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -7112,7 +7112,7 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
if (arg_expr->rank == 0)
{
if (arg_expr->ts.type == BT_CLASS)
- gfc_add_component_ref (arg_expr, "_data");
+ gfc_add_data_component (arg_expr);
gfc_conv_expr_reference (se, arg_expr);
}
else
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 2a91c35..14dad0f 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1132,11 +1132,11 @@ gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2)

final_expr = gfc_copy_expr (expr);
gfc_add_vptr_component (final_expr);
- gfc_add_component_ref (final_expr, "_final");
+ gfc_add_final_component (final_expr);

elem_size = gfc_copy_expr (expr);
gfc_add_vptr_component (elem_size);
- gfc_add_component_ref (elem_size, "_size");
+ gfc_add_size_component (elem_size);
}

gcc_assert (final_expr->expr_type == EXPR_VARIABLE);

[Bernhard Reutner-Fischer]

These three function used a hardcoded buffer of 100 but would be better
off to base off GFC_MAX_SYMBOL_LEN which denotes the maximum length of a
name in any of our supported standards (63 as of f2003 ff.).

Regstrapped without regressions, ok for trunk stage3 now / next stage1?

gcc/fortran/ChangeLog

2015-11-29 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* interface.c (check_sym_interfaces, check_uop_interfaces,
gfc_check_interfaces): Base interface_name buffer off
GFC_MAX_SYMBOL_LEN.

Signed-off-by: Bernhard Reutner-Fischer <***@gmail.com>
---
gcc/fortran/interface.c | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index dcf3eae..30cc522 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1696,7 +1696,7 @@ check_interface1 (gfc_interface *p, gfc_interface *q0,
static void
check_sym_interfaces (gfc_symbol *sym)
{
- char interface_name[100];
+ char interface_name[GFC_MAX_SYMBOL_LEN + sizeof("generic interface ''")];
gfc_interface *p;

if (sym->ns != gfc_current_ns)
@@ -1733,7 +1733,7 @@ check_sym_interfaces (gfc_symbol *sym)
static void
check_uop_interfaces (gfc_user_op *uop)
{
- char interface_name[100];
+ char interface_name[GFC_MAX_SYMBOL_LEN + sizeof("operator interface ''")];
gfc_user_op *uop2;
gfc_namespace *ns;

@@ -1810,7 +1810,7 @@ void
gfc_check_interfaces (gfc_namespace *ns)
{
gfc_namespace *old_ns, *ns2;
- char interface_name[100];
+ char interface_name[GFC_MAX_SYMBOL_LEN + sizeof("intrinsic '' operator")];
int i;

old_ns = gfc_current_ns;

[Janne Blomqvist]

On Tue, Dec 1, 2015 at 2:54 PM, Bernhard Reutner-Fischer

Post by Bernhard Reutner-Fischer
These three function used a hardcoded buffer of 100 but would be better
off to base off GFC_MAX_SYMBOL_LEN which denotes the maximum length of a
name in any of our supported standards (63 as of f2003 ff.).

Please use xasprintf() instead (and free the result, or course). One
of my backburner projects is to get rid of these static symbol
buffers, and use dynamic buffers (or the symbol table) instead. We
IIRC already have some ugly hacks by using hashing to get around
GFC_MAX_SYMBOL_LEN when handling mangled symbols. Your patch doesn't
make the situation worse per se, but if you're going to fix it, lets
do it properly.

Ok for GCC 7 stage1 with these changes. I don't think it's worth
putting it into GCC 6 at this point anymore, unless this is actually
fixing some bugs that are visible to users?

[Bernhard Reutner-Fischer]

Post by Janne Blomqvist
On Tue, Dec 1, 2015 at 2:54 PM, Bernhard Reutner-Fischer

Post by Bernhard Reutner-Fischer
These three function used a hardcoded buffer of 100 but would be better
off to base off GFC_MAX_SYMBOL_LEN which denotes the maximum length of a
name in any of our supported standards (63 as of f2003 ff.).

Please use xasprintf() instead (and free the result, or course). One
of my backburner projects is to get rid of these static symbol
buffers, and use dynamic buffers (or the symbol table) instead. We
IIRC already have some ugly hacks by using hashing to get around
GFC_MAX_SYMBOL_LEN when handling mangled symbols. Your patch doesn't
make the situation worse per se, but if you're going to fix it, lets
do it properly.

I see.

/scratch/src/gcc-6.0.mine/gcc/fortran$ git grep
"^[[:space:]]*char[[:space:]][[:space:]]*[^[;[:space:]]*\[" | wc -l
142
/scratch/src/gcc-6.0.mine/gcc/fortran$ git grep "xasprintf" | wc -l
32

What about memory fragmentation when switching to heap-based allocation?
Or is there consensus that these are in the noise compared to other
parts of the compiler?

BTW:
$ git grep APO
io.c: static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
io.c: static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };

Post by Janne Blomqvist
Ok for GCC 7 stage1 with these changes. I don't think it's worth
putting it into GCC 6 at this point anymore, unless this is actually
fixing some bugs that are visible to users?

Not visible, no, can wait easily.

[Janne Blomqvist]

On Tue, Dec 1, 2015 at 6:51 PM, Bernhard Reutner-Fischer

Post by Bernhard Reutner-Fischer

Post by Janne Blomqvist
On Tue, Dec 1, 2015 at 2:54 PM, Bernhard Reutner-Fischer

Post by Bernhard Reutner-Fischer
These three function used a hardcoded buffer of 100 but would be better
off to base off GFC_MAX_SYMBOL_LEN which denotes the maximum length of a
name in any of our supported standards (63 as of f2003 ff.).

Please use xasprintf() instead (and free the result, or course). One
of my backburner projects is to get rid of these static symbol
buffers, and use dynamic buffers (or the symbol table) instead. We
IIRC already have some ugly hacks by using hashing to get around
GFC_MAX_SYMBOL_LEN when handling mangled symbols. Your patch doesn't
make the situation worse per se, but if you're going to fix it, lets
do it properly.

I see.
/scratch/src/gcc-6.0.mine/gcc/fortran$ git grep
"^[[:space:]]*char[[:space:]][[:space:]]*[^[;[:space:]]*\[" | wc -l
142
/scratch/src/gcc-6.0.mine/gcc/fortran$ git grep "xasprintf" | wc -l
32

Yes, that's why it's on the TODO-list rather than on the DONE-list. :)

Post by Bernhard Reutner-Fischer
What about memory fragmentation when switching to heap-based allocation?
Or is there consensus that these are in the noise compared to other
parts of the compiler?

Heap fragmentation is an issue, yes. I'm not sure it's that
performance-critical, but I don't think there is any consensus. I just
want to avoid ugly hacks like symbol hashing to fit within some fixed
buffer. Perhaps an good compromise would be something like std::string
with small string optimization, but as you have seen there is some
resistance to C++. But this is more relevant for mangled symbols, so
GFC_MAX_MANGLED_SYMBOL_LEN is more relevant here, and there's only a
few of them left. So, well, if you're sure that mangled symbols are
never copied into the buffers your patch modifies, please consider
your original patch Ok as well. Whichever you prefer.

Performance-wise I think a bigger benefit would be to use the symbol
table more and then e.g. be able to do pointer comparisons rather than
strcmp(). But that is certainly much more work.

Post by Bernhard Reutner-Fischer
$ git grep APO
io.c: static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };
io.c: static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE", NULL };

? What are you saying?

[Bernhard Reutner-Fischer]

Post by Janne Blomqvist
On Tue, Dec 1, 2015 at 6:51 PM, Bernhard Reutner-Fischer

On 1 December 2015 at 15:52, Janne Blomqvist

Post by Janne Blomqvist
On Tue, Dec 1, 2015 at 2:54 PM, Bernhard Reutner-Fischer

Post by Bernhard Reutner-Fischer
These three function used a hardcoded buffer of 100 but would be

better

Post by Janne Blomqvist

Post by Bernhard Reutner-Fischer
off to base off GFC_MAX_SYMBOL_LEN which denotes the maximum length

of a

Post by Janne Blomqvist

Post by Bernhard Reutner-Fischer
name in any of our supported standards (63 as of f2003 ff.).

Please use xasprintf() instead (and free the result, or course). One
of my backburner projects is to get rid of these static symbol
buffers, and use dynamic buffers (or the symbol table) instead. We
IIRC already have some ugly hacks by using hashing to get around
GFC_MAX_SYMBOL_LEN when handling mangled symbols. Your patch doesn't
make the situation worse per se, but if you're going to fix it, lets
do it properly.

I see.
/scratch/src/gcc-6.0.mine/gcc/fortran$ git grep
"^[[:space:]]*char[[:space:]][[:space:]]*[^[;[:space:]]*\[" | wc -l
142
/scratch/src/gcc-6.0.mine/gcc/fortran$ git grep "xasprintf" | wc -l
32

Yes, that's why it's on the TODO-list rather than on the DONE-list. :)

What about memory fragmentation when switching to heap-based

allocation?

Or is there consensus that these are in the noise compared to other
parts of the compiler?

Heap fragmentation is an issue, yes. I'm not sure it's that
performance-critical, but I don't think there is any consensus. I just
want to avoid ugly hacks like symbol hashing to fit within some fixed
buffer. Perhaps an good compromise would be something like std::string
with small string optimization, but as you have seen there is some
resistance to C++. But this is more relevant for mangled symbols, so
GFC_MAX_MANGLED_SYMBOL_LEN is more relevant here, and there's only a
few of them left. So, well, if you're sure that mangled symbols are
never copied into the buffers your patch modifies, please consider
your original patch Ok as well. Whichever you prefer.
Performance-wise I think a bigger benefit would be to use the symbol
table more and then e.g. be able to do pointer comparisons rather than
strcmp(). But that is certainly much more work.

Hm, worth a look indeed since that would certainly be a step in the right direction.

Post by Janne Blomqvist

$ git grep APO
io.c: static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE",

NULL };

io.c: static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE",

NULL };
? What are you saying?

delim is duplicated, we should remove one instance.
thanks,

[Bernhard Reutner-Fischer]

Post by Bernhard Reutner-Fischer

Post by Janne Blomqvist
On Tue, Dec 1, 2015 at 6:51 PM, Bernhard Reutner-Fischer

On 1 December 2015 at 15:52, Janne Blomqvist

Post by Janne Blomqvist
On Tue, Dec 1, 2015 at 2:54 PM, Bernhard Reutner-Fischer

Post by Bernhard Reutner-Fischer
These three function used a hardcoded buffer of 100 but would be

better

Post by Janne Blomqvist

Post by Bernhard Reutner-Fischer
off to base off GFC_MAX_SYMBOL_LEN which denotes the maximum length

of a

Post by Janne Blomqvist

Post by Bernhard Reutner-Fischer
name in any of our supported standards (63 as of f2003 ff.).

Please use xasprintf() instead (and free the result, or course). One
of my backburner projects is to get rid of these static symbol
buffers, and use dynamic buffers (or the symbol table) instead. We
IIRC already have some ugly hacks by using hashing to get around
GFC_MAX_SYMBOL_LEN when handling mangled symbols. Your patch doesn't
make the situation worse per se, but if you're going to fix it, lets
do it properly.

I see.
/scratch/src/gcc-6.0.mine/gcc/fortran$ git grep
"^[[:space:]]*char[[:space:]][[:space:]]*[^[;[:space:]]*\[" | wc -l
142
/scratch/src/gcc-6.0.mine/gcc/fortran$ git grep "xasprintf" | wc -l
32

Yes, that's why it's on the TODO-list rather than on the DONE-list. :)

What about memory fragmentation when switching to heap-based

allocation?

Or is there consensus that these are in the noise compared to other
parts of the compiler?

Heap fragmentation is an issue, yes. I'm not sure it's that
performance-critical, but I don't think there is any consensus. I just
want to avoid ugly hacks like symbol hashing to fit within some fixed
buffer. Perhaps an good compromise would be something like std::string
with small string optimization, but as you have seen there is some
resistance to C++. But this is more relevant for mangled symbols, so
GFC_MAX_MANGLED_SYMBOL_LEN is more relevant here, and there's only a
few of them left. So, well, if you're sure that mangled symbols are
never copied into the buffers your patch modifies, please consider
your original patch Ok as well. Whichever you prefer.
Performance-wise I think a bigger benefit would be to use the symbol
table more and then e.g. be able to do pointer comparisons rather than
strcmp(). But that is certainly much more work.

Hm, worth a look indeed since that would certainly be a step in the right direction.

Installed the initial patch as intermediate step as r253881 for now.

thanks,

Post by Bernhard Reutner-Fischer

Post by Janne Blomqvist

$ git grep APO
io.c: static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE",

NULL };

io.c: static const char *delim[] = { "APOSTROPHE", "QUOTE", "NONE",

NULL };
? What are you saying?

delim is duplicated, we should remove one instance.
thanks,

[Bernhard Reutner-Fischer]

Post by Bernhard Reutner-Fischer

On December 3, 2015 10:46:09 AM GMT+01:00, Janne Blomqvist

Post by Janne Blomqvist
On Tue, Dec 1, 2015 at 6:51 PM, Bernhard Reutner-Fischer

On 1 December 2015 at 15:52, Janne Blomqvist

Post by Janne Blomqvist
On Tue, Dec 1, 2015 at 2:54 PM, Bernhard Reutner-Fischer

Post by Bernhard Reutner-Fischer
These three function used a hardcoded buffer of 100 but would be

better

Post by Janne Blomqvist

Post by Bernhard Reutner-Fischer
off to base off GFC_MAX_SYMBOL_LEN which denotes the maximum

length

Post by Janne Blomqvist
of a

Post by Janne Blomqvist

Post by Bernhard Reutner-Fischer
name in any of our supported standards (63 as of f2003 ff.).

Please use xasprintf() instead (and free the result, or course).

One

Post by Janne Blomqvist

Post by Janne Blomqvist
of my backburner projects is to get rid of these static symbol
buffers, and use dynamic buffers (or the symbol table) instead.

We

Post by Janne Blomqvist

Post by Janne Blomqvist
IIRC already have some ugly hacks by using hashing to get around
GFC_MAX_SYMBOL_LEN when handling mangled symbols. Your patch

doesn't

Post by Janne Blomqvist

Post by Janne Blomqvist
make the situation worse per se, but if you're going to fix it,

lets

Post by Janne Blomqvist

Post by Janne Blomqvist
do it properly.

I see.
/scratch/src/gcc-6.0.mine/gcc/fortran$ git grep
"^[[:space:]]*char[[:space:]][[:space:]]*[^[;[:space:]]*\[" | wc

-l

Post by Janne Blomqvist

142
/scratch/src/gcc-6.0.mine/gcc/fortran$ git grep "xasprintf" | wc

-l

Post by Janne Blomqvist

32

Yes, that's why it's on the TODO-list rather than on the DONE-list.

:)

Post by Janne Blomqvist

What about memory fragmentation when switching to heap-based

allocation?

Or is there consensus that these are in the noise compared to

other

Post by Janne Blomqvist

parts of the compiler?

Heap fragmentation is an issue, yes. I'm not sure it's that
performance-critical, but I don't think there is any consensus. I

just

Post by Janne Blomqvist
want to avoid ugly hacks like symbol hashing to fit within some

fixed

Post by Janne Blomqvist
buffer. Perhaps an good compromise would be something like

std::string

Post by Janne Blomqvist
with small string optimization, but as you have seen there is some
resistance to C++. But this is more relevant for mangled symbols, so
GFC_MAX_MANGLED_SYMBOL_LEN is more relevant here, and there's only a
few of them left. So, well, if you're sure that mangled symbols are
never copied into the buffers your patch modifies, please consider
your original patch Ok as well. Whichever you prefer.
Performance-wise I think a bigger benefit would be to use the symbol
table more and then e.g. be able to do pointer comparisons rather

than

Post by Janne Blomqvist
strcmp(). But that is certainly much more work.

Hm, worth a look indeed since that would certainly be a step in the

right direction.
Installed the initial patch as intermediate step as r253881 for now.

JFYI I'm contemplating to move the stack-based allocations to heap-based ones now, starting with gfc_match_name and gradually moving to pointer comparisons with the stringpool based identifiers. I'll strive to suggest something for discussion in smallish steps when it's ready.

Cheers,

Post by Bernhard Reutner-Fischer
thanks,

Post by Janne Blomqvist

$ git grep APO
io.c: static const char *delim[] = { "APOSTROPHE", "QUOTE",

"NONE",

Post by Janne Blomqvist
NULL };

io.c: static const char *delim[] = { "APOSTROPHE", "QUOTE",

"NONE",

Post by Janne Blomqvist
NULL };
? What are you saying?

delim is duplicated, we should remove one instance.
thanks,

[Thomas Koenig]

Hi Bernhard,

Post by Bernhard Reutner-Fischer
JFYI I'm contemplating to move the stack-based allocations
to heap-based ones now, starting with gfc_match_name and
gradually moving to pointer comparisons with the stringpool based
identifiers. I'll strive to suggest something for discussion in
smallish steps when it's ready.

What is the driver behind this change? Code clarity? Speed?


Regards

Thomas

[Bernhard Reutner-Fischer]

Post by Paul Richard Thomas
Hi Bernhard,

Post by Bernhard Reutner-Fischer
JFYI I'm contemplating to move the stack-based allocations
to heap-based ones now, starting with gfc_match_name and
gradually moving to pointer comparisons with the stringpool based
identifiers. I'll strive to suggest something for discussion in
smallish steps when it's ready.

What is the driver behind this change? Code clarity? Speed?

The idea is to replace string-comparison with pointer comparison which
should help speed.
See Janne's suggestion to do this earlier in this thread.
It's more or less janitorial work. IIRC the C family of FEs switched
to this scheme many years ago for good measure and nobody had time to
take care of the fortran FE. At least that's my understanding.

thanks,

[Bernhard Reutner-Fischer]

Post by Bernhard Reutner-Fischer
JFYI I'm contemplating to move the stack-based allocations
to heap-based ones now, starting with gfc_match_name and
gradually moving to pointer comparisons with the stringpool based
identifiers. I'll strive to suggest something for discussion in
smallish steps when it's ready.

So i'm mostly through this.

One thing that is still missing is to hash keywords like basic types,
"ppr@" (decl.c), "kind", "null", module_natures (intrinsic /
non_intrinsic), the "ieee_" stuff in expr.c, things like inquiry_func_f95
and inquiry_func_f2003 in expr.c, intrinsic operators, c_interop_kinds_table
etc, etc.

I initially thought about just hashing just all minit()ed data and maybe
i'll end up doing this anyway. We will then have to add a helper in the
initialization to setup the stringpool nodes. It would be easiest to
just do all (or most) of the minit()ed data and integral types in one
place unless you prefer to push this down to appropriate places where
applicable, like add e.g. the basic type nodes and the "kind" node
in gfc_init_types. Whatever is deemed to be more appropriate. WDYT?

thanks

[Bernhard Reutner-Fischer]

On Tue, 31 Oct 2017 at 21:35, Bernhard Reutner-Fischer

Post by Bernhard Reutner-Fischer

Post by Bernhard Reutner-Fischer
JFYI I'm contemplating to move the stack-based allocations
to heap-based ones now, starting with gfc_match_name and
gradually moving to pointer comparisons with the stringpool based
identifiers. I'll strive to suggest something for discussion in
smallish steps when it's ready.

So i'm mostly through this.
One thing that is still missing is to hash keywords like basic types,
non_intrinsic), the "ieee_" stuff in expr.c, things like inquiry_func_f95
and inquiry_func_f2003 in expr.c, intrinsic operators, c_interop_kinds_table
etc, etc.

FWIW:
I've saved away a checkpoint that regtests cleanly (against
***@264039 from yesterday):
https://gcc.gnu.org/git/?p=gcc.git;a=shortlog;h=refs/heads/aldot/fortran-fe-stringpool

Please disregard the first 4 patches, they do not belong to this
series and will be dropped.

There are some more places left to switch.
Not yet included is a patch to switch the symtree to a hash_map, which
i think is what we may ultimately want to do.
AFAIR doing so was running into GC issues which i did not tackle yet.

cheers,

Post by Bernhard Reutner-Fischer
I initially thought about just hashing just all minit()ed data and maybe
i'll end up doing this anyway. We will then have to add a helper in the
initialization to setup the stringpool nodes. It would be easiest to
just do all (or most) of the minit()ed data and integral types in one
place unless you prefer to push this down to appropriate places where
applicable, like add e.g. the basic type nodes and the "kind" node
in gfc_init_types. Whatever is deemed to be more appropriate. WDYT?

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

Aids debugging the fortran FE.

gcc/ChangeLog:

2017-11-12 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* gdbinit.in: Break on gfc_internal_error.
---
gcc/gdbinit.in | 1 +
1 file changed, 1 insertion(+)

diff --git a/gcc/gdbinit.in b/gcc/gdbinit.in
index 4db977f0bab..ac4d7c42e21 100644
--- a/gcc/gdbinit.in
+++ b/gcc/gdbinit.in
@@ -227,6 +227,7 @@ b fancy_abort

# Put a breakpoint on internal_error to help with debugging ICEs.
b internal_error
+b gfc_internal_error

set complaints 0
# Don't let abort actually run, as it will make

[Bernhard Reutner-Fischer]

Hi,

The fortran frontend still uses stack-based handling of (symbol) names
with fixed-sized buffers. Furthermore these buffers often are too small
when dealing with F2003 identifiers which can be up to, including 63
bytes long.

Other frontends use the stringpool since many years.
This janitorial series is a first step towards using the stringpool in
the frontend.
Consequently this allows us to use pointer-comparison to see if two
given "names" are identical instead of doing lots and lots of string
comparisons.


Part 1 switches most of the fortran FE. An eventual part 2 would
continue to switch the few remaining stack-based identifier
manipulations to use the stringpool. My initial plan was to also see if
switching gfc_symtree from treap to a hash_map would bring us any
measurable benefit, but that, too, is left for an eventual part 2.

Bootstrapped and regtested on x86_64-foo-linux.

I'd appreciate if someone could double check for regressions on other
setups. Git branch:
https://gcc.gnu.org/git/?p=gcc.git;a=log;h=refs/heads/aldot/fortran-fe-stringpool

Ok for trunk?

Bernhard Reutner-Fischer (29):
gdbinit: break on gfc_internal_error
Use stringpool for gfc_match_defined_op_name()
Use stringpool for gfc_get_name
Use stringpool for gfc_match_generic_spec
Use stringpool for gfc_match("%n")
Use stringpool for association_list
Use stringpool for some gfc_code2string return values
Add uop/name helpers
Use stringpool for modules
Do not copy name for check_function_name
Do pointer comparison instead of strcmp
Use stringpool for remaining names
Use stringpool for intrinsics and common
Fix write_omp_udr for user-operator REDUCTIONs
Use stringpool for iso_c_binding module names
Do pointer comparison in iso_c_binding_module
Use stringpool for iso_fortran_env
Use stringpool for charkind
Use stringpool and unified uppercase handling for types
Use stringpool in class et al
Use stringpool for module tbp
Use stringpool in class and procedure-pointer result
Use stringpool for module binding_label
Use stringpool for intrinsic functions
Use stringpool on loading module symbols
Use stringpool for mangled common names
Use stringpool for OMP clause reduction code
Free type-bound procedure structs
PR87103: Remove max symbol length check from gfc_new_symbol

gcc/fortran/check.c | 2 +-
gcc/fortran/class.c | 96 +++++------
gcc/fortran/decl.c | 265 ++++++++++++++---------------
gcc/fortran/expr.c | 4 +-
gcc/fortran/frontend-passes.c | 16 +-
gcc/fortran/gfortran.h | 18 +-
gcc/fortran/interface.c | 109 ++++++------
gcc/fortran/intrinsic.c | 11 +-
gcc/fortran/io.c | 10 +-
gcc/fortran/iresolve.c | 35 ++--
gcc/fortran/match.c | 143 ++++++++--------
gcc/fortran/match.h | 9 +-
gcc/fortran/matchexp.c | 22 ++-
gcc/fortran/misc.c | 2 +-
gcc/fortran/module.c | 311 ++++++++++++++--------------------
gcc/fortran/openmp.c | 120 +++++++------
gcc/fortran/parse.c | 23 ++-
gcc/fortran/primary.c | 58 ++++---
gcc/fortran/resolve.c | 81 +++++----
gcc/fortran/symbol.c | 58 ++++---
gcc/fortran/trans-array.c | 4 +-
gcc/fortran/trans-common.c | 10 +-
gcc/fortran/trans-decl.c | 38 ++---
gcc/fortran/trans-expr.c | 11 +-
gcc/fortran/trans-openmp.c | 1 +
gcc/fortran/trans-types.c | 20 +--
gcc/fortran/trans.c | 6 +-
gcc/gdbinit.in | 1 +
28 files changed, 719 insertions(+), 765 deletions(-)

[Janne Blomqvist]

On Wed, Sep 5, 2018 at 5:58 PM Bernhard Reutner-Fischer <

Post by Bernhard Reutner-Fischer
Hi,
The fortran frontend still uses stack-based handling of (symbol) names
with fixed-sized buffers. Furthermore these buffers often are too small
when dealing with F2003 identifiers which can be up to, including 63
bytes long.
Other frontends use the stringpool since many years.
This janitorial series is a first step towards using the stringpool in
the frontend.
Consequently this allows us to use pointer-comparison to see if two
given "names" are identical instead of doing lots and lots of string
comparisons.
Part 1 switches most of the fortran FE. An eventual part 2 would
continue to switch the few remaining stack-based identifier
manipulations to use the stringpool. My initial plan was to also see if
switching gfc_symtree from treap to a hash_map would bring us any
measurable benefit, but that, too, is left for an eventual part 2.
Bootstrapped and regtested on x86_64-foo-linux.
I'd appreciate if someone could double check for regressions on other
https://gcc.gnu.org/git/?p=gcc.git;a=log;h=refs/heads/aldot/fortran-fe-stringpool
Ok for trunk?

Hi,

this is quite an impressive patch set. I have looked through all the
patches, and on the surface they all look ok.

Unfortunately I don't have any exotic target to test on either, so I think
you just have to commit it and check for regression reports. Though I don't
see this set doing anything which would work differently on other targets,
but you never know..

I'd say wait a few days in case anybody else wants to comment on it, then
commit it to trunk.

Thanks for doing all this!

[Bernhard Reutner-Fischer]

Post by Bernhard Reutner-Fischer
Bootstrapped and regtested on x86_64-foo-linux.
I'd appreciate if someone could double check for regressions on other
https://gcc.gnu.org/git/?p=gcc.git;a=log;h=refs/heads/aldot/fortran-fe-stringpool
Ok for trunk?

Hi,
this is quite an impressive patch set. I have looked through all the patches, and on the surface they all look ok.

Thanks alot for your appreciation!

Unfortunately I don't have any exotic target to test on either, so I think you just have to commit it and check for regression reports. Though I don't see this set doing anything which would work differently on other targets, but you never know..
I'd say wait a few days in case anybody else wants to comment on it, then commit it to trunk.

Upon further testing i encountered a regression in module writing,
manifesting itself in a failure to compile ieee_8.f90 (and only this).
f951: Fatal Error: Reading module ‘foo’ at line 4310 column 25: Expected string
where we write the following garbage:
366 ''''''''''''''''res'BLE IN UNKNOWN-PROC UNKNOWN UNKNOWN 0 0

End of last year when i wrote these patches i diffed each and every
module in my regtests and all these were identical, so it must be some
recent "regression" in that area.
Sorry for that, I'll have another look during the weekend.

thanks,

[Bernhard Reutner-Fischer]

On Fri, 7 Sep 2018 at 10:07, Bernhard Reutner-Fischer

Post by Bernhard Reutner-Fischer

Post by Bernhard Reutner-Fischer
Bootstrapped and regtested on x86_64-foo-linux.
I'd appreciate if someone could double check for regressions on other
https://gcc.gnu.org/git/?p=gcc.git;a=log;h=refs/heads/aldot/fortran-fe-stringpool
Ok for trunk?

Hi,
this is quite an impressive patch set. I have looked through all the patches, and on the surface they all look ok.

Thanks alot for your appreciation!

Unfortunately I don't have any exotic target to test on either, so I think you just have to commit it and check for regression reports. Though I don't see this set doing anything which would work differently on other targets, but you never know..
I'd say wait a few days in case anybody else wants to comment on it, then commit it to trunk.

Upon further testing i encountered a regression in module writing,
manifesting itself in a failure to compile ieee_8.f90 (and only this).
Sorry for that, I'll have another look during the weekend.

so in free_pi_tree we should not free true_name nor module:

@@ -239,12 +239,6 @@ free_pi_tree (pointer_info *p)
free_pi_tree (p->left);
free_pi_tree (p->right);

- if (iomode == IO_INPUT)
- {
- XDELETEVEC (p->u.rsym.true_name);
- XDELETEVEC (p->u.rsym.module);
- }
-
free (p);
}

This fixes the module writing but leaks, obviously.
Now the reason why i initially did not use mio_pool_string for both
rsym.module and rsym.true_name was that mio_pool_string sets the name
to NULL if the string is empty.
Currently these are read by read_string() [which we should get rid of
entirely, the 2 mentioned fields are the last two who use
read_string()] which does not nullify the empty string but returns
just the pointer. For e.g. ieee_8.f90 using mio_pool_string gives us a
NULL module which leads to gfc_use_module -> load_needed ->
gfc_find_symbol -> gfc_find_sym_tree -> gfc_find_symtree which tries
to c = strcmp (name, st->name); where name is NULL.

The main culprits seem to be class finalization wrapper variables so
i'm adding modules to those now.
Which leaves me with regressions like allocate_with_source_14.f03.
"Fixing" these by falling back to gfc_current_ns->proc_name->name in
load_needed for !ns->proc_name if the rsym->module is NULL seems to
work.

Now there are a number of issues with names of fixups. Like the 9 in e.g.:

$ zcat /tmp/n/m.mod | egrep -v "^(\(\)|\(\(\)|$)"
GFORTRAN module version '15' created from generic_27.f90
(('testif' 'm' 2 3))
(4 'm' 'm' '' 1 ((MODULE UNKNOWN-INTENT UNKNOWN-PROC UNKNOWN UNKNOWN 0 0)
3 'test1' 'm' '' 1 ((PROCEDURE UNKNOWN-INTENT MODULE-PROC DECL UNKNOWN 0
0 FUNCTION) () (REAL 4 0 0 0 REAL ()) 5 0 (6) () 3 () () () 0 0)
2 'test2' 'm' '' 1 ((PROCEDURE UNKNOWN-INTENT MODULE-PROC DECL UNKNOWN 0
0 FUNCTION ARRAY_OUTER_DEPENDENCY) () (REAL 4 0 0 0 REAL ()) 7 0 (8) ()
2 () () () 0 0)
6 'obj' '' '' 5 ((VARIABLE UNKNOWN-INTENT UNKNOWN-PROC UNKNOWN UNKNOWN 0
0 DUMMY) () (REAL 4 0 0 0 REAL ()) 0 0 () () 0 () () () 0 0)
8 'pr' '' '' 7 ((PROCEDURE UNKNOWN-INTENT DUMMY-PROC UNKNOWN UNKNOWN 0 0
EXTERNAL DUMMY FUNCTION PROCEDURE ARRAY_OUTER_DEPENDENCY) () (REAL 4 9 0
0 REAL ()) 0 0 () () 8 () () () 0 0)
9 '' '' '' 7 ((PROCEDURE UNKNOWN-INTENT UNKNOWN-PROC UNKNOWN UNKNOWN 0 0
FUNCTION) () (REAL 4 0 0 0 REAL ()) 0 0 () () 0 () () () 0 0)
)
('m' 0 4 'test1' 0 3 'test2' 0 2)

which is a bit of a complication since we need them to verify proper
interface types and attributes etc, etc.
generic_27.f90 would then warn in check_proc_interface() that
"Interface %qs at %L must be explicit".
To bypass this warning i suggest to flag these as artificial like so:
@@ -6679,10 +6683,12 @@ match_procedure_decl (void)
return MATCH_ERROR;
sym->ts.interface = gfc_new_symbol ("", gfc_current_ns);
sym->ts.interface->ts = current_ts;
sym->ts.interface->attr.flavor = FL_PROCEDURE;
sym->ts.interface->attr.function = 1;
+ /* Suppress warnings about explicit interface */
+ sym->ts.interface->attr.artificial = 1;
sym->attr.function = 1;
sym->attr.if_source = IFSRC_UNKNOWN;
}

if (gfc_match (" =>") == MATCH_YES)
@@ -6818,10 +6824,12 @@ match_ppc_decl (void)
c->ts.interface = gfc_new_symbol ("", gfc_current_ns);
c->ts.interface->result = c->ts.interface;
c->ts.interface->ts = ts;
c->ts.interface->attr.flavor = FL_PROCEDURE;
c->ts.interface->attr.function = 1;
+ /* Suppress warnings about explicit interface */
+ c->ts.interface->attr.artificial = 1;
c->attr.function = 1;
c->attr.if_source = IFSRC_UNKNOWN;
}

if (gfc_match (" =>") == MATCH_YES)

and then not exclude ""-names but attr.artificial for the "must be
explicit" warning. This works fine.

Another spot where we encounter trouble with NULL module in the sym is
generic_1.f90 where we would be unable to distinguish interface sub
arguments during true_name lookup.
We find x in true names and consequently use this one sym for both the
REAL as well as the INTEGER variable which of course doesn't work when
resolving.
As it turns out we get away with punting true_name lookup if the module is NULL.

The next hintch are unlimited polymorphic component class containers
as in select_type_36.f03 when used in module context.
gfc_find_gsymbol() around the "upe" really wants a module that is
non-NULL which we luckily have at hand. This just extends the
proc_name-hack.

@@ -4061,6 +4061,10 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int
implicit_flag)
upe->refs++;
upe->ts.type = BT_VOID;
upe->attr.unlimited_polymorphic = 1;
+ /* Make sure gfc_find_gsymbol sees a (non-NULL) name to
+ * search for by plugging in some module name. */
+ if (gfc_current_ns->proc_name != NULL)
+ upe->module = gfc_current_ns->proc_name->name;
/* This is essential to force the construction of
unlimited polymorphic component class containers. */
upe->attr.zero_comp = 1;

The area of true_name and pi_root handling is a bit unpleasant to work
with, i must admit. But then i do not volunteer to rip it all out ;)
I think we will be able to remove some of these proc_name-hacks as
soon as we switch the symbol finding to pointer comparison, at least.

I'm cleaning up the above for a final test and will send it as
alternative, extended approach intended to replace the
"[PATCH,FORTRAN 25/29] Use stringpool on loading module symbols" (
https://gcc.gnu.org/ml/fortran/2018-09/msg00039.html )

patch, fwiw.

thanks,

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

Introduce a helper to construct a user operator from a name and the
reverse operation, i.e. a helper to construct a name from a user
operator.

gcc/fortran/ChangeLog:

2017-10-29 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* gfortran.h (gfc_get_uop_from_name):
(gfc_get_name_from_uop): Declare.
* symbol.c (gfc_get_uop_from_name):
(gfc_get_name_from_uop): Define.
* module.c (load_omp_udrs): Use them.
---
gcc/fortran/gfortran.h | 2 ++
gcc/fortran/module.c | 21 +++------------------
gcc/fortran/symbol.c | 21 +++++++++++++++++++++
3 files changed, 26 insertions(+), 18 deletions(-)

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index ff42b39b453..6c32b8ac71f 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3019,6 +3019,8 @@ void gfc_delete_symtree (gfc_symtree **, const char *);
gfc_symtree *gfc_get_unique_symtree (gfc_namespace *);
gfc_user_op *gfc_get_uop (const char *);
gfc_user_op *gfc_find_uop (const char *, gfc_namespace *);
+const char *gfc_get_uop_from_name (const char*);
+const char *gfc_get_name_from_uop (const char*);
void gfc_free_symbol (gfc_symbol *);
void gfc_release_symbol (gfc_symbol *);
gfc_symbol *gfc_new_symbol (const char *, gfc_namespace *);
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 8628f3aeda9..b3f68b8803f 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -4785,7 +4785,7 @@ load_omp_udrs (void)
while (peek_atom () != ATOM_RPAREN)
{
const char *name = NULL, *newname;
- char *altname;
+ const char *altname = NULL;
gfc_typespec ts;
gfc_symtree *st;
gfc_omp_reduction_op rop = OMP_REDUCTION_USER;
@@ -4812,15 +4812,8 @@ load_omp_udrs (void)
else if (strcmp (p, ".neqv.") == 0)
rop = OMP_REDUCTION_NEQV;
}
- altname = NULL;
if (rop == OMP_REDUCTION_USER && name[0] == '.')
- {
- size_t len = strlen (name + 1);
- altname = XALLOCAVEC (char, len);
- gcc_assert (name[len] == '.');
- memcpy (altname, name + 1, len - 1);
- altname[len - 1] = '\0';
- }
+ altname = gfc_get_name_from_uop (name);
newname = name;
if (rop == OMP_REDUCTION_USER)
newname = find_use_name (altname ? altname : name, !!altname);
@@ -4832,15 +4825,7 @@ load_omp_udrs (void)
continue;
}
if (altname && newname != altname)
- {
- size_t len = strlen (newname);
- altname = XALLOCAVEC (char, len + 3);
- altname[0] = '.';
- memcpy (altname + 1, newname, len);
- altname[len + 1] = '.';
- altname[len + 2] = '\0';
- name = gfc_get_string ("%s", altname);
- }
+ name = altname = gfc_get_uop_from_name (newname);
st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
gfc_omp_udr *udr = gfc_omp_udr_find (st, &ts);
if (udr)
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 0a4f7c1711b..a8f841185f1 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -3026,6 +3026,27 @@ gfc_find_uop (const char *name, gfc_namespace *ns)
return (st == NULL) ? NULL : st->n.uop;
}

+/* Given a name return a string usable as user operator name. */
+const char *
+gfc_get_uop_from_name (const char* name) {
+ gcc_assert (name[0] != '.');
+ return gfc_get_string (".%s.", name);
+}
+
+/* Given a user operator name return a string usable as name. */
+const char *
+gfc_get_name_from_uop (const char* name) {
+ gcc_assert (name[0] == '.');
+ const size_t len = strlen (name) - 1;
+ gcc_assert (len > 1);
+ gcc_assert (name[len] == '.');
+ char *buffer = XNEWVEC (char, len);
+ memcpy (buffer, name + 1, len - 1);
+ buffer[len - 1] = '\0';
+ const char *ret = gfc_get_string ("%s", buffer);
+ XDELETEVEC (buffer);
+ return ret;
+}

/* Update a symbol's common_block field, and take care of the associated
memory management. */

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

The openmp part will be cleaned up later in this series.

gcc/fortran/ChangeLog:

2017-10-22 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* match.h (gfc_match_defined_op_name): Adjust prototype and add
a parameter USER_OPERATOR.
* matchexp.c (gfc_match_defined_op_name): Use gfc_get_string and
return a user operator if USER_OPERATOR is true.
(match_defined_operator): Update calls to gfc_match_defined_op_name.
* interface.c (gfc_match_generic_spec): Likewise.
* openmp.c (gfc_match_omp_clauses): Likewise. Use gfc_get_string
where appropriate.
(gfc_match_omp_declare_reduction): Likewise.
---
gcc/fortran/interface.c | 5 +++--
gcc/fortran/match.h | 2 +-
gcc/fortran/matchexp.c | 18 ++++++++++++------
gcc/fortran/openmp.c | 31 +++++++++++++++++--------------
4 files changed, 33 insertions(+), 23 deletions(-)

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index f85c76bad0f..14137cebd6c 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -160,7 +160,8 @@ gfc_match_generic_spec (interface_type *type,
*op = INTRINSIC_NONE;
if (gfc_match (" operator ( ") == MATCH_YES)
{
- m = gfc_match_defined_op_name (buffer, 1);
+ const char *oper = NULL;
+ m = gfc_match_defined_op_name (oper, 1, 0);
if (m == MATCH_NO)
goto syntax;
if (m != MATCH_YES)
@@ -172,7 +173,7 @@ gfc_match_generic_spec (interface_type *type,
if (m != MATCH_YES)
return MATCH_ERROR;

- strcpy (name, buffer);
+ strcpy (name, oper);
*type = INTERFACE_USER_OP;
return MATCH_YES;
}
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 418542bd5a6..b3ced3f8454 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -315,7 +315,7 @@ match gfc_match_write (void);
match gfc_match_print (void);

/* matchexp.c. */
-match gfc_match_defined_op_name (char *, int);
+match gfc_match_defined_op_name (const char *&, int, bool);
match gfc_match_expr (gfc_expr **);

/* module.c. */
diff --git a/gcc/fortran/matchexp.c b/gcc/fortran/matchexp.c
index fb81e10a6c2..bb01af9f636 100644
--- a/gcc/fortran/matchexp.c
+++ b/gcc/fortran/matchexp.c
@@ -30,10 +30,14 @@ static const char expression_syntax[] = N_("Syntax error in expression at %C");

/* Match a user-defined operator name. This is a normal name with a
few restrictions. The error_flag controls whether an error is
- raised if 'true' or 'false' are used or not. */
+ raised if 'true' or 'false' are used or not.
+ If USER_OPERATOR is true, a user operator is returned in RESULT
+ upon success.
+ */

match
-gfc_match_defined_op_name (char *result, int error_flag)
+gfc_match_defined_op_name (const char *&result, int error_flag,
+ bool user_operator)
{
static const char * const badops[] = {
"and", "or", "not", "eqv", "neqv", "eq", "ne", "ge", "le", "lt", "gt",
@@ -72,8 +76,10 @@ gfc_match_defined_op_name (char *result, int error_flag)
gfc_error ("Bad character %qc in OPERATOR name at %C", name[i]);
return MATCH_ERROR;
}
-
- strcpy (result, name);
+ if (user_operator)
+ result = gfc_get_string (".%s.", name);
+ else
+ result = gfc_get_string ("%s", name);
return MATCH_YES;

error:
@@ -91,10 +97,10 @@ error:
static match
match_defined_operator (gfc_user_op **result)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
match m;

- m = gfc_match_defined_op_name (name, 0);
+ m = gfc_match_defined_op_name (name, 0, 0);
if (m != MATCH_YES)
return m;

diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index 94a7f7eaa50..a852fc490db 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -1581,6 +1581,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
{
gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
char buffer[GFC_MAX_SYMBOL_LEN + 3];
+ const char *op = NULL;
if (gfc_match_char ('+') == MATCH_YES)
rop = OMP_REDUCTION_PLUS;
else if (gfc_match_char ('*') == MATCH_YES)
@@ -1596,13 +1597,10 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
else if (gfc_match (".neqv.") == MATCH_YES)
rop = OMP_REDUCTION_NEQV;
if (rop != OMP_REDUCTION_NONE)
- snprintf (buffer, sizeof buffer, "operator %s",
+ op = gfc_get_string ("operator %s",
gfc_op2string ((gfc_intrinsic_op) rop));
- else if (gfc_match_defined_op_name (buffer + 1, 1) == MATCH_YES)
- {
- buffer[0] = '.';
- strcat (buffer, ".");
- }
+ else if (gfc_match_defined_op_name (op, 1, 1) == MATCH_YES)
+ ;
else if (gfc_match_name (buffer) == MATCH_YES)
{
gfc_symbol *sym;
@@ -1660,9 +1658,13 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
}
else
buffer[0] = '\0';
- gfc_omp_udr *udr
- = (buffer[0]
- ? gfc_find_omp_udr (gfc_current_ns, buffer, NULL) : NULL);
+ gfc_omp_udr *udr;
+ if (op != NULL)
+ udr = gfc_find_omp_udr (gfc_current_ns, op, NULL);
+ else if (buffer[0])
+ udr = gfc_find_omp_udr (gfc_current_ns, buffer, NULL);
+ else
+ udr = NULL;
gfc_omp_namelist **head = NULL;
if (rop == OMP_REDUCTION_NONE && udr)
rop = OMP_REDUCTION_USER;
@@ -1678,7 +1680,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
n = *head;
*head = NULL;
gfc_error_now ("!$OMP DECLARE REDUCTION %s not found "
- "at %L", buffer, &old_loc);
+ "at %L", op ? op : buffer, &old_loc);
gfc_free_omp_namelist (n);
}
else
@@ -2801,6 +2803,7 @@ gfc_match_omp_declare_reduction (void)
match m;
gfc_intrinsic_op op;
char name[GFC_MAX_SYMBOL_LEN + 3];
+ const char *oper = NULL;
auto_vec<gfc_typespec, 5> tss;
gfc_typespec ts;
unsigned int i;
@@ -2818,20 +2821,20 @@ gfc_match_omp_declare_reduction (void)
return MATCH_ERROR;
if (m == MATCH_YES)
{
- snprintf (name, sizeof name, "operator %s", gfc_op2string (op));
+ oper = gfc_get_string ("operator %s", gfc_op2string (op));
+ strcpy (name, oper);
rop = (gfc_omp_reduction_op) op;
}
else
{
- m = gfc_match_defined_op_name (name + 1, 1);
+ m = gfc_match_defined_op_name (oper, 1, 1);
if (m == MATCH_ERROR)
return MATCH_ERROR;
if (m == MATCH_YES)
{
- name[0] = '.';
- strcat (name, ".");
if (gfc_match (" : ") != MATCH_YES)
return MATCH_ERROR;
+ strcpy (name, oper);
}
else
{

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

Use a stringpool-node for those gfc_code2string values that are used as
names.

gcc/fortran/ChangeLog:

2017-10-26 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* interface.c (gfc_match_generic_spec, gfc_check_dtio_interfaces,
gfc_find_typebound_dtio_proc, gfc_find_specific_dtio_proc): Use
stringpool node for those return values of gfc_code2string that
are used as names.
---
gcc/fortran/interface.c | 50 ++++++++++++++++-------------------------
1 file changed, 19 insertions(+), 31 deletions(-)

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 19a0eb28edd..8716813b7b2 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -182,12 +182,12 @@ gfc_match_generic_spec (interface_type *type,
*op = dtio_op (name);
if (*op == INTRINSIC_FORMATTED)
{
- name = gfc_code2string (dtio_procs, DTIO_RF);
+ name = gfc_get_string ("%s", gfc_code2string (dtio_procs, DTIO_RF));
*type = INTERFACE_DTIO;
}
if (*op == INTRINSIC_UNFORMATTED)
{
- name = gfc_code2string (dtio_procs, DTIO_RUF);
+ name = gfc_get_string ("%s", gfc_code2string (dtio_procs, DTIO_RUF));
*type = INTERFACE_DTIO;
}
if (*op != INTRINSIC_NONE)
@@ -199,12 +199,12 @@ gfc_match_generic_spec (interface_type *type,
*op = dtio_op (name);
if (*op == INTRINSIC_FORMATTED)
{
- name = gfc_code2string (dtio_procs, DTIO_WF);
+ name = gfc_get_string ("%s", gfc_code2string (dtio_procs, DTIO_WF));
*type = INTERFACE_DTIO;
}
if (*op == INTRINSIC_UNFORMATTED)
{
- name = gfc_code2string (dtio_procs, DTIO_WUF);
+ name = gfc_get_string ("%s", gfc_code2string (dtio_procs, DTIO_WUF));
*type = INTERFACE_DTIO;
}
if (*op != INTRINSIC_NONE)
@@ -4927,8 +4927,8 @@ gfc_check_dtio_interfaces (gfc_symbol *derived)
|| ((dtio_codes)code == DTIO_WF);

tb_io_st = gfc_find_typebound_proc (derived, &t,
- gfc_code2string (dtio_procs, code),
- true, &derived->declared_at);
+ gfc_get_string ("%s", gfc_code2string (dtio_procs, code)),
+ true, &derived->declared_at);
if (tb_io_st != NULL)
check_dtio_interface1 (derived, tb_io_st, true, formatted, code);
}
@@ -4940,7 +4940,7 @@ gfc_check_dtio_interfaces (gfc_symbol *derived)
|| ((dtio_codes)code == DTIO_WF);

tb_io_st = gfc_find_symtree (derived->ns->sym_root,
- gfc_code2string (dtio_procs, code));
+ gfc_get_string ("%s", gfc_code2string (dtio_procs, code)));
if (tb_io_st != NULL)
check_dtio_interface1 (derived, tb_io_st, false, formatted, code);
}
@@ -4961,31 +4961,23 @@ gfc_find_typebound_dtio_proc (gfc_symbol *derived, bool write, bool formatted)
{
if (write == true)
tb_io_st = gfc_find_typebound_proc (derived, &t,
- gfc_code2string (dtio_procs,
- DTIO_WF),
- true,
- &derived->declared_at);
+ gfc_get_string ("%s", gfc_code2string (dtio_procs, DTIO_WF)),
+ true, &derived->declared_at);
else
tb_io_st = gfc_find_typebound_proc (derived, &t,
- gfc_code2string (dtio_procs,
- DTIO_RF),
- true,
- &derived->declared_at);
+ gfc_get_string ("%s", gfc_code2string (dtio_procs, DTIO_RF)),
+ true, &derived->declared_at);
}
else
{
if (write == true)
tb_io_st = gfc_find_typebound_proc (derived, &t,
- gfc_code2string (dtio_procs,
- DTIO_WUF),
- true,
- &derived->declared_at);
+ gfc_get_string ("%s", gfc_code2string (dtio_procs, DTIO_WUF)),
+ true, &derived->declared_at);
else
tb_io_st = gfc_find_typebound_proc (derived, &t,
- gfc_code2string (dtio_procs,
- DTIO_RUF),
- true,
- &derived->declared_at);
+ gfc_get_string ("%s", gfc_code2string (dtio_procs, DTIO_RUF)),
+ true, &derived->declared_at);
}
return tb_io_st;
}
@@ -5041,23 +5033,19 @@ gfc_find_specific_dtio_proc (gfc_symbol *derived, bool write, bool formatted)
{
if (write == true)
tb_io_st = gfc_find_symtree (extended->ns->sym_root,
- gfc_code2string (dtio_procs,
- DTIO_WF));
+ gfc_get_string ("%s", gfc_code2string (dtio_procs, DTIO_WF)));
else
tb_io_st = gfc_find_symtree (extended->ns->sym_root,
- gfc_code2string (dtio_procs,
- DTIO_RF));
+ gfc_get_string ("%s", gfc_code2string (dtio_procs, DTIO_RF)));
}
else
{
if (write == true)
tb_io_st = gfc_find_symtree (extended->ns->sym_root,
- gfc_code2string (dtio_procs,
- DTIO_WUF));
+ gfc_get_string ("%s", gfc_code2string (dtio_procs, DTIO_WUF)));
else
tb_io_st = gfc_find_symtree (extended->ns->sym_root,
- gfc_code2string (dtio_procs,
- DTIO_RUF));
+ gfc_get_string ("%s", gfc_code2string (dtio_procs, DTIO_RUF)));
}

if (tb_io_st != NULL

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

2017-10-26 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* gfortran.h (struct gfc_association_list): Change name to
pointer.
* match.c (gfc_match_associate): Adjust.
---
gcc/fortran/gfortran.h | 2 +-
gcc/fortran/match.c | 6 ++----
2 files changed, 3 insertions(+), 5 deletions(-)

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 774a6de6168..ff42b39b453 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2482,7 +2482,7 @@ typedef struct gfc_association_list
/* True when the rank of the target expression is guessed during parsing. */
unsigned rankguessed:1;

- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name;
gfc_symtree *st; /* Symtree corresponding to name. */
locus where;

diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 1b03e7251a5..38827ed4637 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1891,8 +1891,7 @@ gfc_match_associate (void)
gfc_association_list* a;

/* Match the next association. */
- const char *name_hack = NULL;
- if (gfc_match (" %n =>", &name_hack) != MATCH_YES)
+ if (gfc_match (" %n =>", &newAssoc->name) != MATCH_YES)
{
gfc_error ("Expected association at %C");
goto assocListError;
@@ -1909,12 +1908,11 @@ gfc_match_associate (void)
}
gfc_matching_procptr_assignment = 0;
}
- strcpy (newAssoc->name, name_hack);
newAssoc->where = gfc_current_locus;

/* Check that the current name is not yet in the list. */
for (a = new_st.ext.block.assoc; a; a = a->next)
- if (!strcmp (a->name, newAssoc->name))
+ if (a->name == newAssoc->name)
{
gfc_error ("Duplicate name %qs in association at %C",
newAssoc->name);

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

Ideally we would populate mstrings structs with strings obtained through
the stringpool. Doing so by means of minit wouldn't work out too well
though, see comment in gfortran.h. We could replace the initialized
strings in gfc_init_1 but that's for a later patch.

gcc/fortran/ChangeLog:

2017-10-23 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* match.h (gfc_match_generic_spec): Pass argument name by reference.
Adjust all callers.
* decl.c (access_attr_decl): Adjust.
(gfc_match_generic): Adjust.
* interface.c (gfc_match_generic_spec, gfc_match_interface,
gfc_match_end_interface): Adjust.
* module.c (gfc_match_use): Adjust.
---
gcc/fortran/decl.c | 11 +++++------
gcc/fortran/gfortran.h | 5 +++++
gcc/fortran/interface.c | 20 +++++++++-----------
gcc/fortran/match.h | 3 ++-
gcc/fortran/module.c | 16 +++++++++-------
5 files changed, 30 insertions(+), 25 deletions(-)

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index f0ff5138ca1..2f8d2aca695 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -8582,7 +8582,7 @@ gfc_match_target (void)
static match
access_attr_decl (gfc_statement st)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
interface_type type;
gfc_user_op *uop;
gfc_symbol *sym, *dt_sym;
@@ -10768,7 +10768,7 @@ syntax:
match
gfc_match_generic (void)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...). */
gfc_symbol* block;
gfc_typebound_proc tbattr; /* Used for match_binding_attributes. */
@@ -10931,9 +10931,8 @@ gfc_match_generic (void)
{
gfc_symtree* target_st;
gfc_tbp_generic* target;
- const char *name2 = NULL;

- m = gfc_match_name (&name2);
+ m = gfc_match_name (&name);
if (m == MATCH_ERROR)
goto error;
if (m == MATCH_NO)
@@ -10942,14 +10941,14 @@ gfc_match_generic (void)
goto error;
}

- target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name2);
+ target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name);

/* See if this is a duplicate specification. */
for (target = tb->u.generic; target; target = target->next)
if (target_st == target->specific_st)
{
gfc_error ("%qs already defined as specific binding for the"
- " generic %qs at %C", name2, bind_name);
+ " generic %qs at %C", name, bind_name);
goto error;
}

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 04b0024a992..774a6de6168 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -95,6 +95,11 @@ not after.

/* Macro to initialize an mstring structure. */
#define minit(s, t) { s, NULL, t }
+/* Ideally we would want that to be
+ { IDENTIFIER_POINTER (get_identifier_with_length (s, sizeof(s)-1)), NULL, t }
+ but stringpool's hash table is not allocated yet and we would have to do
+ tricks to have a ctor to initialize it. And even that wouldn't work too
+ well as toplevel would later on wipe ident_hash. */

/* Structure for storing strings to be matched by gfc_match_string. */
typedef struct
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index de58eed23f0..6a5fe928b93 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -136,11 +136,10 @@ dtio_op (char* mode)

match
gfc_match_generic_spec (interface_type *type,
- char *name,
+ const char *&name,
gfc_intrinsic_op *op)
{
char buffer[GFC_MAX_SYMBOL_LEN + 1];
- const char *name2 = NULL;
match m;
gfc_intrinsic_op i;

@@ -174,7 +173,7 @@ gfc_match_generic_spec (interface_type *type,
if (m != MATCH_YES)
return MATCH_ERROR;

- strcpy (name, oper);
+ name = oper;
*type = INTERFACE_USER_OP;
return MATCH_YES;
}
@@ -184,12 +183,12 @@ gfc_match_generic_spec (interface_type *type,
*op = dtio_op (buffer);
if (*op == INTRINSIC_FORMATTED)
{
- strcpy (name, gfc_code2string (dtio_procs, DTIO_RF));
+ name = gfc_code2string (dtio_procs, DTIO_RF);
*type = INTERFACE_DTIO;
}
if (*op == INTRINSIC_UNFORMATTED)
{
- strcpy (name, gfc_code2string (dtio_procs, DTIO_RUF));
+ name = gfc_code2string (dtio_procs, DTIO_RUF);
*type = INTERFACE_DTIO;
}
if (*op != INTRINSIC_NONE)
@@ -201,21 +200,20 @@ gfc_match_generic_spec (interface_type *type,
*op = dtio_op (buffer);
if (*op == INTRINSIC_FORMATTED)
{
- strcpy (name, gfc_code2string (dtio_procs, DTIO_WF));
+ name = gfc_code2string (dtio_procs, DTIO_WF);
*type = INTERFACE_DTIO;
}
if (*op == INTRINSIC_UNFORMATTED)
{
- strcpy (name, gfc_code2string (dtio_procs, DTIO_WUF));
+ name = gfc_code2string (dtio_procs, DTIO_WUF);
*type = INTERFACE_DTIO;
}
if (*op != INTRINSIC_NONE)
return MATCH_YES;
}

- if (gfc_match_name (&name2) == MATCH_YES)
+ if (gfc_match_name (&name) == MATCH_YES)
{
- strcpy (name, name2);
*type = INTERFACE_GENERIC;
return MATCH_YES;
}
@@ -235,7 +233,7 @@ syntax:
match
gfc_match_interface (void)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
interface_type type;
gfc_symbol *sym;
gfc_intrinsic_op op;
@@ -327,7 +325,7 @@ gfc_match_abstract_interface (void)
match
gfc_match_end_interface (void)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
interface_type type;
gfc_intrinsic_op op;
match m;
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 62554d9667e..75e0d9204d7 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -296,7 +296,8 @@ match gfc_match_array_constructor (gfc_expr **);

/* interface.c. */
match gfc_match_abstract_interface (void);
-match gfc_match_generic_spec (interface_type *, char *, gfc_intrinsic_op *);
+match gfc_match_generic_spec (interface_type *, const char *&,
+ gfc_intrinsic_op *);
match gfc_match_interface (void);
match gfc_match_end_interface (void);

diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index f31677b3b5e..1064f3c80cb 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -68,9 +68,9 @@ along with GCC; see the file COPYING3. If not see
#include "system.h"
#include "coretypes.h"
#include "options.h"
+#include "stringpool.h"
#include "tree.h"
#include "gfortran.h"
-#include "stringpool.h"
#include "arith.h"
#include "match.h"
#include "parse.h" /* FIXME */
@@ -519,8 +519,8 @@ free_rename (gfc_use_rename *list)
match
gfc_match_use (void)
{
- char name[GFC_MAX_SYMBOL_LEN + 1], module_nature[GFC_MAX_SYMBOL_LEN + 1];
- const char *name2 = NULL;
+ char module_nature[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_use_rename *tail = NULL, *new_use;
interface_type type, type2;
gfc_intrinsic_op op;
@@ -584,14 +584,14 @@ gfc_match_use (void)

use_list->where = gfc_current_locus;

- m = gfc_match_name (&name2);
+ m = gfc_match_name (&name);
if (m != MATCH_YES)
{
free (use_list);
return m;
}

- use_list->module_name = name2;
+ use_list->module_name = name;

if (gfc_match_eos () == MATCH_YES)
goto done;
@@ -650,13 +650,14 @@ gfc_match_use (void)
else
{
strcpy (new_use->local_name, name);
- m = gfc_match_generic_spec (&type2, new_use->use_name, &op);
+ m = gfc_match_generic_spec (&type2, name, &op);
if (type != type2)
goto syntax;
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
goto cleanup;
+ strcpy (new_use->use_name, name);
}
}
else
@@ -665,13 +666,14 @@ gfc_match_use (void)
goto syntax;
strcpy (new_use->local_name, name);

- m = gfc_match_generic_spec (&type2, new_use->use_name, &op);
+ m = gfc_match_generic_spec (&type2, name, &op);
if (type != type2)
goto syntax;
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
goto cleanup;
+ strcpy (new_use->use_name, name);
}

if (strcmp (new_use->use_name, use_list->module_name) == 0

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

gcc/fortran/ChangeLog:

2017-10-29 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* gfortran.h (struct gfc_use_rename): Use pointers for
local_name and use_name.
* match.c (gfc_match): Set name to NULL on failed match.
* module.c (gfc_match_use): Use pointer comparison instead of
string comparison.
(find_use_name_n): Likewise.
(mio_internal_string): Delete.
(mio_expr): Simplify INTRINSIC_USER handling.
(load_operator_interfaces): Use pointer for name and module.
(load_generic_interfaces): Likewise.
(load_commons): Use pointer for name.
(load_needed): Use pointer comparison instead of string
comparison.
(read_module): Use pointer for name. Use pointer comparison
instead if string comparison.
(import_iso_c_binding_module): Adjust to struct gfc_use_rename
changes.
(use_iso_fortran_env_module): Likewise.
* symbol.c (generate_isocbinding_symbol): Likewise.
* trans-decl.c (gfc_trans_use_stmts): Likewise.
---
gcc/fortran/gfortran.h | 3 +-
gcc/fortran/match.c | 11 +++-
gcc/fortran/module.c | 115 ++++++++++++++-------------------------
gcc/fortran/symbol.c | 2 +-
gcc/fortran/trans-decl.c | 8 +--
5 files changed, 56 insertions(+), 83 deletions(-)

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 6c32b8ac71f..cb9195d393e 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1673,7 +1673,8 @@ gfc_entry_list;

typedef struct gfc_use_rename
{
- char local_name[GFC_MAX_SYMBOL_LEN + 1], use_name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *local_name;
+ const char *use_name;
struct gfc_use_rename *next;
int found;
gfc_intrinsic_op op;
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 38827ed4637..6596bd87c09 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1274,15 +1274,22 @@ not_yes:
case '%':
matches++;
break; /* Skip. */
+#if 0
+ /* If everybody is disciplined we do not need to reset this. */
+ case 'n':
+ vp = va_arg (argp, void **); /* FORNOW: NULL shouldn't be */
+ *vp = NULL;
+ break;
+#else
+ case 'n':
+#endif

/* Matches that don't have to be undone */
case 'o':
case 'l':
- case 'n':
case 's':
(void) va_arg (argp, void **);
break;
-
case 'e':
case 'v':
vp = va_arg (argp, void **);
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index b3f68b8803f..3ad47f57930 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -646,10 +646,10 @@ gfc_match_use (void)
if (use_list->only_flag)
{
if (m != MATCH_YES)
- strcpy (new_use->use_name, name);
+ new_use->use_name = name;
else
{
- strcpy (new_use->local_name, name);
+ new_use->local_name = name;
m = gfc_match_generic_spec (&type2, name, &op);
if (type != type2)
goto syntax;
@@ -657,15 +657,14 @@ gfc_match_use (void)
goto syntax;
if (m == MATCH_ERROR)
goto cleanup;
- strcpy (new_use->use_name, name);
+ new_use->use_name = name;
}
}
else
{
if (m != MATCH_YES)
goto syntax;
- strcpy (new_use->local_name, name);
-
+ new_use->local_name = name;
m = gfc_match_generic_spec (&type2, name, &op);
if (type != type2)
goto syntax;
@@ -673,11 +672,11 @@ gfc_match_use (void)
goto syntax;
if (m == MATCH_ERROR)
goto cleanup;
- strcpy (new_use->use_name, name);
+ new_use->use_name = name;
}

- if (strcmp (new_use->use_name, use_list->module_name) == 0
- || strcmp (new_use->local_name, use_list->module_name) == 0)
+ if (new_use->use_name == use_list->module_name
+ || new_use->local_name == use_list->module_name)
{
gfc_error ("The name %qs at %C has already been used as "
"an external module name", use_list->module_name);
@@ -848,8 +847,8 @@ find_use_name_n (const char *name, int *inst, bool interface)
i = 0;
for (u = gfc_rename_list; u; u = u->next)
{
- if ((!low_name && strcmp (u->use_name, name) != 0)
- || (low_name && strcmp (u->use_name, low_name) != 0)
+ if ((!low_name && u->use_name != name)
+ || (low_name && u->use_name != low_name)
|| (u->op == INTRINSIC_USER && !interface)
|| (u->op != INTRINSIC_USER && interface))
continue;
@@ -870,12 +869,11 @@ find_use_name_n (const char *name, int *inst, bool interface)

if (low_name)
{
- if (u->local_name[0] == '\0')
+ if (u->local_name == NULL)
return name;
return gfc_dt_upper_string (u->local_name);
}
-
- return (u->local_name[0] != '\0') ? u->local_name : name;
+ return u->local_name != NULL ? u->local_name : name;
}


@@ -1980,24 +1978,6 @@ mio_pool_string (const char **stringp)
}
}

-
-/* Read or write a string that is inside of some already-allocated
- structure. */
-
-static void
-mio_internal_string (char *string)
-{
- if (iomode == IO_OUTPUT)
- write_atom (ATOM_STRING, string);
- else
- {
- require_atom (ATOM_STRING);
- strcpy (string, atom_string);
- free (atom_string);
- }
-}
-
-
enum ab_attribute
{ AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
AB_POINTER, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA,
@@ -3536,20 +3516,12 @@ mio_expr (gfc_expr **ep)
write_atom (ATOM_STRING, e->value.op.uop->name);
else
{
- char *name = read_string ();
+ const char *name;
+ mio_pool_string (&name);
const char *uop_name = find_use_name (name, true);
if (uop_name == NULL)
- {
- size_t len = strlen (name);
- char *name2 = XCNEWVEC (char, len + 2);
- memcpy (name2, name, len);
- name2[len] = ' ';
- name2[len + 1] = '\0';
- free (name);
- uop_name = name = name2;
- }
+ uop_name = name = gfc_get_string ("%s ", name);
e->value.op.uop = gfc_get_uop (uop_name);
- free (name);
}
mio_expr (&e->value.op.op1);
mio_expr (&e->value.op.op2);
@@ -4481,7 +4453,7 @@ static void
load_operator_interfaces (void)
{
const char *p;
- char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL, *module = NULL;
gfc_user_op *uop;
pointer_info *pi = NULL;
int n, i;
@@ -4492,8 +4464,8 @@ load_operator_interfaces (void)
{
mio_lparen ();

- mio_internal_string (name);
- mio_internal_string (module);
+ mio_pool_string (&name);
+ mio_pool_string (&module);

n = number_use_names (name, true);
n = n ? n : 1;
@@ -4537,7 +4509,7 @@ static void
load_generic_interfaces (void)
{
const char *p;
- char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL, *module = NULL;
gfc_symbol *sym;
gfc_interface *generic = NULL, *gen = NULL;
int n, i, renamed;
@@ -4549,8 +4521,8 @@ load_generic_interfaces (void)
{
mio_lparen ();

- mio_internal_string (name);
- mio_internal_string (module);
+ mio_pool_string (&name);
+ mio_pool_string (&module);

n = number_use_names (name, false);
renamed = n ? 1 : 0;
@@ -4667,7 +4639,7 @@ load_generic_interfaces (void)
static void
load_commons (void)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_common_head *p;

mio_lparen ();
@@ -4677,7 +4649,7 @@ load_commons (void)
int flags;
char* label;
mio_lparen ();
- mio_internal_string (name);
+ mio_pool_string (&name);

p = gfc_get_common (name, 1);

@@ -4955,7 +4927,7 @@ load_needed (pointer_info *p)
found, mark it. */
for (u = gfc_rename_list; u; u = u->next)
{
- if (strcmp (u->use_name, sym->name) == 0)
+ if (u->use_name == sym->name)
{
sym->attr.use_only = 1;
break;
@@ -5073,7 +5045,7 @@ read_module (void)
{
module_locus operator_interfaces, user_operators, omp_udrs;
const char *p;
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
int i;
/* Workaround -Wmaybe-uninitialized false positive during
profiledbootstrap by initializing them. */
@@ -5197,7 +5169,7 @@ read_module (void)

while (peek_atom () != ATOM_RPAREN)
{
- mio_internal_string (name);
+ mio_pool_string (&name);
mio_integer (&ambiguous);
mio_integer (&symbol);

@@ -5216,7 +5188,7 @@ read_module (void)
/* Get the jth local name for this symbol. */
p = find_use_name_n (name, &j, false);

- if (p == NULL && strcmp (name, module_name) == 0)
+ if (p == NULL && name == module_name)
p = name;

/* Exception: Always import vtabs & vtypes. */
@@ -5246,7 +5218,7 @@ read_module (void)
added to the namespace(11.3.2). Note that find_symbol
only returns the first occurrence that it finds. */
if (!only_flag && !info->u.rsym.renamed
- && strcmp (name, module_name) != 0
+ && name != module_name
&& find_symbol (gfc_current_ns->sym_root, name,
module_name, 0))
continue;
@@ -5303,7 +5275,7 @@ read_module (void)
st->n.sym = sym;
st->n.sym->refs++;

- if (strcmp (name, p) != 0)
+ if (name != p)
sym->attr.use_rename = 1;

if (name[0] != '_'
@@ -6349,22 +6321,15 @@ import_iso_c_binding_module (void)
u->use_name) == 0)
{
c_ptr = generate_isocbinding_symbol (iso_c_module_name,
- (iso_c_binding_symbol)
- ISOCBINDING_PTR,
- u->local_name[0] ? u->local_name
- : u->use_name,
- NULL, false);
+ (iso_c_binding_symbol) ISOCBINDING_PTR,
+ u->local_name ? u->local_name : u->use_name, NULL, false);
}
else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNPTR].name,
u->use_name) == 0)
{
- c_funptr
- = generate_isocbinding_symbol (iso_c_module_name,
- (iso_c_binding_symbol)
- ISOCBINDING_FUNPTR,
- u->local_name[0] ? u->local_name
- : u->use_name,
- NULL, false);
+ c_funptr = generate_isocbinding_symbol (iso_c_module_name,
+ (iso_c_binding_symbol) ISOCBINDING_FUNPTR,
+ u->local_name ? u->local_name : u->use_name, NULL, false);
}
}

@@ -6442,7 +6407,7 @@ import_iso_c_binding_module (void)
return_type = c_funptr->n.sym; \
else \
return_type = NULL; \
- create_intrinsic_function (u->local_name[0] \
+ create_intrinsic_function (u->local_name \
? u->local_name : u->use_name, \
a, iso_c_module_name, \
INTMOD_ISO_C_BINDING, false, \
@@ -6450,7 +6415,7 @@ import_iso_c_binding_module (void)
break;
#define NAMED_SUBROUTINE(a,b,c,d) \
case a: \
- create_intrinsic_function (u->local_name[0] ? u->local_name \
+ create_intrinsic_function (u->local_name ? u->local_name \
: u->use_name, \
a, iso_c_module_name, \
INTMOD_ISO_C_BINDING, true, NULL); \
@@ -6470,7 +6435,7 @@ import_iso_c_binding_module (void)
tmp_symtree = NULL;
generate_isocbinding_symbol (iso_c_module_name,
(iso_c_binding_symbol) i,
- u->local_name[0]
+ u->local_name
? u->local_name : u->use_name,
tmp_symtree, false);
}
@@ -6790,7 +6755,7 @@ use_iso_fortran_env_module (void)
#define NAMED_INTCST(a,b,c,d) \
case a:
#include "iso-fortran-env.def"
- create_int_parameter (u->local_name[0] ? u->local_name
+ create_int_parameter (u->local_name ? u->local_name
: u->use_name,
symbol[i].value, mod,
INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
@@ -6805,7 +6770,7 @@ use_iso_fortran_env_module (void)
gfc_constructor_append_expr (&expr->value.constructor, \
gfc_get_int_expr (gfc_default_integer_kind, NULL, \
KINDS[j].kind), NULL); \
- create_int_parameter_array (u->local_name[0] ? u->local_name \
+ create_int_parameter_array (u->local_name ? u->local_name \
: u->use_name, \
j, expr, mod, \
INTMOD_ISO_FORTRAN_ENV, \
@@ -6816,7 +6781,7 @@ use_iso_fortran_env_module (void)
#define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
case a:
#include "iso-fortran-env.def"
- create_derived_type (u->local_name[0] ? u->local_name
+ create_derived_type (u->local_name ? u->local_name
: u->use_name,
mod, INTMOD_ISO_FORTRAN_ENV,
symbol[i].id);
@@ -6825,7 +6790,7 @@ use_iso_fortran_env_module (void)
#define NAMED_FUNCTION(a,b,c,d) \
case a:
#include "iso-fortran-env.def"
- create_intrinsic_function (u->local_name[0] ? u->local_name
+ create_intrinsic_function (u->local_name ? u->local_name
: u->use_name,
symbol[i].id, mod,
INTMOD_ISO_FORTRAN_ENV, false,
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index a8f841185f1..e576bc1cb69 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -4761,7 +4761,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
const char *local_name, gfc_symtree *dt_symtree,
bool hidden)
{
- const char *const name = (local_name && local_name[0])
+ const char *const name = local_name
? local_name : c_interop_kinds_table[s].name;
gfc_symtree *tmp_symtree;
gfc_symbol *tmp_sym = NULL;
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index eea6b81ebfa..e2adfa2e2db 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -5040,7 +5040,7 @@ gfc_trans_use_stmts (gfc_namespace * ns)
if (rent->op != INTRINSIC_NONE)
continue;

- hashval_t hash = htab_hash_string (rent->use_name);
+ hashval_t hash = htab_hash_string (rent->use_name);
tree *slot = entry->decls->find_slot_with_hash (rent->use_name, hash,
INSERT);
if (*slot == NULL)
@@ -5048,14 +5048,14 @@ gfc_trans_use_stmts (gfc_namespace * ns)
gfc_symtree *st;

st = gfc_find_symtree (ns->sym_root,
- rent->local_name[0]
+ rent->local_name
? rent->local_name : rent->use_name);

/* The following can happen if a derived type is renamed. */
if (!st)
{
char *name;
- name = xstrdup (rent->local_name[0]
+ name = xstrdup (rent->local_name
? rent->local_name : rent->use_name);
name[0] = (char) TOUPPER ((unsigned char) name[0]);
st = gfc_find_symtree (ns->sym_root, name);
@@ -5102,7 +5102,7 @@ gfc_trans_use_stmts (gfc_namespace * ns)
*slot = decl;
}
decl = (tree) *slot;
- if (rent->local_name[0])
+ if (rent->local_name)
local_name = get_identifier (rent->local_name);
else
local_name = NULL_TREE;

[Janne Blomqvist]

On Wed, Sep 5, 2018 at 6:00 PM Bernhard Reutner-Fischer <

Post by Bernhard Reutner-Fischer
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 38827ed4637..6596bd87c09 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
matches++;
break; /* Skip. */
+#if 0
+ /* If everybody is disciplined we do not need to reset this.
*/
+ vp = va_arg (argp, void **); /* FORNOW: NULL shouldn't be */
+ *vp = NULL;
+ break;
+#else
+#endif

Some debugging leftover that should be removed?

[Bernhard Reutner-Fischer]

Post by Janne Blomqvist
On Wed, Sep 5, 2018 at 6:00 PM Bernhard Reutner-Fischer <

Post by Bernhard Reutner-Fischer
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 38827ed4637..6596bd87c09 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
matches++;
break; /* Skip. */
+#if 0
+ /* If everybody is disciplined we do not need to reset

this.

Post by Bernhard Reutner-Fischer
*/
+ vp = va_arg (argp, void **); /* FORNOW: NULL shouldn't

be */

Post by Bernhard Reutner-Fischer
+ *vp = NULL;
+ break;
+#else
+#endif

Some debugging leftover that should be removed?

Well AFAIR this still blew up at some point. It's possible that this would work out fine now that all %n should be converted.
I'll have another look.

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

Occurrences of name2 in this patch will be fixed later in this series.

gcc/fortran/ChangeLog:

2017-10-23 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* match.h (gfc_match_name): Pass argument by reference. Adjust
all callers.
(match_common_name): Likewise.
* match.c (gfc_match_name): Set result to IDENTIFIER_POINTER of
stringpool node.
(gfc_match_member_sep, gfc_match_sym_tree, gfc_match,
gfc_match_else, gfc_match_elseif, match_common_name,
gfc_match_common, gfc_match_ptr_fcn_assign, match_case_eos,
gfc_match_elsewhere): Adjust.
* decl.c (variable_decl): Set name via gfc_get_string() and
adjust calls to gfc_match_name.
(match_data_constant, check_function_name, get_bind_c_idents,
gfc_match_formal_arglist, match_result, match_procedure_interface,
match_ppc_decl, match_procedure_in_interface, gfc_match_entry,
gfc_match_end, attr_decl1, gfc_match_modproc, gfc_match_type,
enumerator_decl, match_procedure_in_type, gfc_match_generic,
gfc_match_final_decl, gfc_match_gcc_attributes): Adjust.
* interface.c (gfc_match_generic_spec): Adjust.
* io.c (match_io): Adjust.
* module.c (gfc_match_use): Adjust.
* openmp.c (gfc_match_omp_clauses, gfc_match_oacc_routine): Adjust.
* primary.c (match_kind_param, match_sym_complex_part,
match_actual_arg, match_keyword_arg, gfc_match_varspec,
gfc_match_rvalue): Adjust.
---
gcc/fortran/decl.c | 95 +++++++++++++++++++++--------------------
gcc/fortran/interface.c | 5 ++-
gcc/fortran/io.c | 6 +--
gcc/fortran/match.c | 56 +++++++++++++-----------
gcc/fortran/match.h | 4 +-
gcc/fortran/module.c | 5 ++-
gcc/fortran/openmp.c | 25 +++++------
gcc/fortran/primary.c | 31 +++++++-------
8 files changed, 116 insertions(+), 111 deletions(-)

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 03298833c98..f0ff5138ca1 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -352,7 +352,7 @@ syntax:
static match
match_data_constant (gfc_expr **result)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_symbol *sym, *dt_sym = NULL;
gfc_expr *expr;
match m;
@@ -404,7 +404,7 @@ match_data_constant (gfc_expr **result)

gfc_current_locus = old_loc;

- m = gfc_match_name (name);
+ m = gfc_match_name (&name);
if (m != MATCH_YES)
return m;

@@ -2261,7 +2261,7 @@ match_pointer_init (gfc_expr **init, int procptr)


static bool
-check_function_name (char *name)
+check_function_name (const char *name)
{
/* In functions that have a RESULT variable defined, the function name always
refers to function calls. Therefore, the name is not allowed to appear in
@@ -2294,7 +2294,7 @@ check_function_name (char *name)
static match
variable_decl (int elem)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
static unsigned int fill_id = 0;
gfc_expr *initializer, *char_len;
gfc_array_spec *as;
@@ -2326,7 +2326,7 @@ variable_decl (int elem)

if (m != MATCH_YES)
{
- m = gfc_match_name (name);
+ m = gfc_match_name (&name);
if (m != MATCH_YES)
goto cleanup;
}
@@ -2351,7 +2351,7 @@ variable_decl (int elem)
}

/* %FILL components are given invalid fortran names. */
- snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "%%FILL%u", fill_id++);
+ name = gfc_get_string ("%%FILL%u", fill_id++);
m = MATCH_YES;
}

@@ -2584,13 +2584,13 @@ variable_decl (int elem)
if (gfc_current_state () == COMP_FUNCTION
&& strcmp ("ppr@", gfc_current_block ()->name) == 0
&& strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0)
- strcpy (name, "ppr@");
+ name = gfc_get_string ("%s", "ppr@");

if (gfc_current_state () == COMP_FUNCTION
&& strcmp (name, gfc_current_block ()->name) == 0
&& gfc_current_block ()->result
&& strcmp ("ppr@", gfc_current_block ()->result->name) == 0)
- strcpy (name, "ppr@");
+ name = gfc_get_string ("%s", "ppr@");

/* OK, we've successfully matched the declaration. Now put the
symbol in the current namespace, because it might be used in the
@@ -5694,13 +5694,13 @@ set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
bool
get_bind_c_idents (void)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
int num_idents = 0;
gfc_symbol *tmp_sym = NULL;
match found_id;
gfc_common_head *com_block = NULL;

- if (gfc_match_name (name) == MATCH_YES)
+ if (gfc_match_name (&name) == MATCH_YES)
{
found_id = MATCH_YES;
gfc_get_ha_symbol (name, &tmp_sym);
@@ -5745,7 +5745,7 @@ get_bind_c_idents (void)
found_id = MATCH_NO;
else if (gfc_match_char (',') != MATCH_YES)
found_id = MATCH_NO;
- else if (gfc_match_name (name) == MATCH_YES)
+ else if (gfc_match_name (&name) == MATCH_YES)
{
found_id = MATCH_YES;
gfc_get_ha_symbol (name, &tmp_sym);
@@ -6126,7 +6126,7 @@ gfc_match_formal_arglist (gfc_symbol *progname, int st_flag,
int null_flag, bool typeparam)
{
gfc_formal_arglist *head, *tail, *p, *q;
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_symbol *sym;
match m;
gfc_formal_arglist *formal = NULL;
@@ -6173,7 +6173,7 @@ gfc_match_formal_arglist (gfc_symbol *progname, int st_flag,
}
else
{
- m = gfc_match_name (name);
+ m = gfc_match_name (&name);
if (m != MATCH_YES)
{
if(typeparam)
@@ -6317,14 +6317,14 @@ cleanup:
static match
match_result (gfc_symbol *function, gfc_symbol **result)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_symbol *r;
match m;

if (gfc_match (" result (") != MATCH_YES)
return MATCH_NO;

- m = gfc_match_name (name);
+ m = gfc_match_name (&name);
if (m != MATCH_YES)
return m;

@@ -6515,7 +6515,7 @@ match_procedure_interface (gfc_symbol **proc_if)
gfc_symtree *st;
locus old_loc, entry_loc;
gfc_namespace *old_ns = gfc_current_ns;
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;

old_loc = entry_loc = gfc_current_locus;
gfc_clear_ts (&current_ts);
@@ -6538,7 +6538,7 @@ match_procedure_interface (gfc_symbol **proc_if)

/* Procedure interface is itself a procedure. */
gfc_current_locus = old_loc;
- m = gfc_match_name (name);
+ m = gfc_match_name (&name);

/* First look to see if it is already accessible in the current
namespace because it is use associated or contained. */
@@ -6737,7 +6737,7 @@ match_ppc_decl (void)
gfc_component *c;
gfc_expr *initializer = NULL;
gfc_typebound_proc* tb;
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;

/* Parse interface (with brackets). */
m = match_procedure_interface (&proc_if);
@@ -6778,7 +6778,7 @@ match_ppc_decl (void)
ts = current_ts;
for(num=1;;num++)
{
- m = gfc_match_name (name);
+ m = gfc_match_name (&name);
if (m == MATCH_NO)
goto syntax;
else if (m == MATCH_ERROR)
@@ -6855,7 +6855,7 @@ match_procedure_in_interface (void)
{
match m;
gfc_symbol *sym;
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
locus old_locus;

if (current_interface.type == INTERFACE_NAMELESS
@@ -6879,7 +6879,7 @@ match_procedure_in_interface (void)

for(;;)
{
- m = gfc_match_name (name);
+ m = gfc_match_name (&name);
if (m == MATCH_NO)
goto syntax;
else if (m == MATCH_ERROR)
@@ -7180,7 +7180,7 @@ gfc_match_entry (void)
gfc_symbol *proc;
gfc_symbol *result;
gfc_symbol *entry;
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_compile_state state;
match m;
gfc_entry_list *el;
@@ -7189,7 +7189,7 @@ gfc_match_entry (void)
char peek_char;
match is_bind_c;

- m = gfc_match_name (name);
+ m = gfc_match_name (&name);
if (m != MATCH_YES)
return m;

@@ -7787,7 +7787,7 @@ set_enum_kind(void)
match
gfc_match_end (gfc_statement *st)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_compile_state state;
locus old_loc;
const char *block_name;
@@ -8031,7 +8031,7 @@ gfc_match_end (gfc_statement *st)
end-name. */
m = gfc_match_space ();
if (m == MATCH_YES)
- m = gfc_match_name (name);
+ m = gfc_match_name (&name);

if (m == MATCH_NO)
gfc_error ("Expected terminating name at %C");
@@ -8113,7 +8113,7 @@ cleanup:
static match
attr_decl1 (void)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_array_spec *as;

/* Workaround -Wmaybe-uninitialized false positive during
@@ -8124,7 +8124,7 @@ attr_decl1 (void)

as = NULL;

- m = gfc_match_name (name);
+ m = gfc_match_name (&name);
if (m != MATCH_YES)
goto cleanup;

@@ -9384,7 +9384,7 @@ cleanup:
match
gfc_match_modproc (void)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_symbol *sym;
match m;
locus old_locus;
@@ -9433,7 +9433,7 @@ gfc_match_modproc (void)
bool last = false;
old_locus = gfc_current_locus;

- m = gfc_match_name (name);
+ m = gfc_match_name (&name);
if (m == MATCH_NO)
goto syntax;
if (m != MATCH_YES)
@@ -9818,7 +9818,7 @@ gfc_match_structure_decl (void)
match
gfc_match_type (gfc_statement *st)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
match m;
locus old_loc;

@@ -9844,7 +9844,7 @@ gfc_match_type (gfc_statement *st)

/* By now "TYPE" has already been matched. If we do not see a name, this may
* be something like "TYPE *" or "TYPE <fmt>". */
- m = gfc_match_name (name);
+ m = gfc_match_name (&name);
if (m != MATCH_YES)
{
/* Let print match if it can, otherwise throw an error from
@@ -10236,7 +10236,7 @@ enum_initializer (gfc_expr *last_initializer, locus where)
static match
enumerator_decl (void)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_expr *initializer;
gfc_array_spec *as = NULL;
gfc_symbol *sym;
@@ -10251,7 +10251,7 @@ enumerator_decl (void)
/* When we get here, we've just matched a list of attributes and
maybe a type and a double colon. The next thing we expect to see
is the name of the symbol. */
- m = gfc_match_name (name);
+ m = gfc_match_name (&name);
if (m != MATCH_YES)
goto cleanup;

@@ -10591,9 +10591,9 @@ error:
static match
match_procedure_in_type (void)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
- char target_buf[GFC_MAX_SYMBOL_LEN + 1];
- char* target = NULL, *ifc = NULL;
+ const char *name = NULL;
+ const char *target_buf = NULL;
+ const char *target = NULL, *ifc = NULL;
gfc_typebound_proc tb;
bool seen_colons;
bool seen_attrs;
@@ -10611,7 +10611,7 @@ match_procedure_in_type (void)
/* Try to match PROCEDURE(interface). */
if (gfc_match (" (") == MATCH_YES)
{
- m = gfc_match_name (target_buf);
+ m = gfc_match_name (&target_buf);
if (m == MATCH_ERROR)
return m;
if (m != MATCH_YES)
@@ -10665,7 +10665,7 @@ match_procedure_in_type (void)
/* Match the binding names. */
for(num=1;;num++)
{
- m = gfc_match_name (name);
+ m = gfc_match_name (&name);
if (m == MATCH_ERROR)
return m;
if (m == MATCH_NO)
@@ -10697,7 +10697,7 @@ match_procedure_in_type (void)
return MATCH_ERROR;
}

- m = gfc_match_name (target_buf);
+ m = gfc_match_name (&target_buf);
if (m == MATCH_ERROR)
return m;
if (m == MATCH_NO)
@@ -10931,8 +10931,9 @@ gfc_match_generic (void)
{
gfc_symtree* target_st;
gfc_tbp_generic* target;
+ const char *name2 = NULL;

- m = gfc_match_name (name);
+ m = gfc_match_name (&name2);
if (m == MATCH_ERROR)
goto error;
if (m == MATCH_NO)
@@ -10941,14 +10942,14 @@ gfc_match_generic (void)
goto error;
}

- target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name);
+ target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name2);

/* See if this is a duplicate specification. */
for (target = tb->u.generic; target; target = target->next)
if (target_st == target->specific_st)
{
gfc_error ("%qs already defined as specific binding for the"
- " generic %qs at %C", name, bind_name);
+ " generic %qs at %C", name2, bind_name);
goto error;
}

@@ -10981,7 +10982,7 @@ error:
match
gfc_match_final_decl (void)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_symbol* sym;
match m;
gfc_namespace* module_ns;
@@ -11037,7 +11038,7 @@ gfc_match_final_decl (void)
return MATCH_ERROR;
}

- m = gfc_match_name (name);
+ m = gfc_match_name (&name);
if (m == MATCH_NO)
{
gfc_error ("Expected module procedure name at %C");
@@ -11120,7 +11121,7 @@ match
gfc_match_gcc_attributes (void)
{
symbol_attribute attr;
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
unsigned id;
gfc_symbol *sym;
match m;
@@ -11130,7 +11131,7 @@ gfc_match_gcc_attributes (void)
{
char ch;

- if (gfc_match_name (name) != MATCH_YES)
+ if (gfc_match_name (&name) != MATCH_YES)
return MATCH_ERROR;

for (id = 0; id < EXT_ATTR_LAST; id++)
@@ -11166,7 +11167,7 @@ gfc_match_gcc_attributes (void)

for(;;)
{
- m = gfc_match_name (name);
+ m = gfc_match_name (&name);
if (m != MATCH_YES)
return m;

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 14137cebd6c..de58eed23f0 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -140,6 +140,7 @@ gfc_match_generic_spec (interface_type *type,
gfc_intrinsic_op *op)
{
char buffer[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name2 = NULL;
match m;
gfc_intrinsic_op i;

@@ -212,9 +213,9 @@ gfc_match_generic_spec (interface_type *type,
return MATCH_YES;
}

- if (gfc_match_name (buffer) == MATCH_YES)
+ if (gfc_match_name (&name2) == MATCH_YES)
{
- strcpy (name, buffer);
+ strcpy (name, name2);
*type = INTERFACE_GENERIC;
return MATCH_YES;
}
diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index 0aa31bb6a4f..1d07076c377 100644
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -4071,7 +4071,7 @@ if (condition) \
static match
match_io (io_kind k)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_code *io_code;
gfc_symbol *sym;
int comma_flag;
@@ -4093,7 +4093,7 @@ match_io (io_kind k)
{
/* Treat the non-standard case of PRINT namelist. */
if ((gfc_current_form == FORM_FIXED || gfc_peek_ascii_char () == ' ')
- && gfc_match_name (name) == MATCH_YES)
+ && gfc_match_name (&name) == MATCH_YES)
{
gfc_find_symbol (name, NULL, 1, &sym);
if (sym && sym->attr.flavor == FL_NAMELIST)
@@ -4219,7 +4219,7 @@ match_io (io_kind k)

where = gfc_current_locus;

- m = gfc_match_name (name);
+ m = gfc_match_name (&name);
if (m == MATCH_YES)
{
gfc_find_symbol (name, NULL, 1, &sym);
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 85247dd8334..f3ad91a07c0 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -25,6 +25,8 @@ along with GCC; see the file COPYING3. If not see
#include "gfortran.h"
#include "match.h"
#include "parse.h"
+#include "stringpool.h"
+#include "tree.h"

int gfc_matching_ptr_assignment = 0;
int gfc_matching_procptr_assignment = 0;
@@ -150,7 +152,7 @@ gfc_op2string (gfc_intrinsic_op op)
match
gfc_match_member_sep(gfc_symbol *sym)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
locus dot_loc, start_loc;
gfc_intrinsic_op iop;
match m;
@@ -176,7 +178,6 @@ gfc_match_member_sep(gfc_symbol *sym)
tsym = sym->ts.u.derived;

iop = INTRINSIC_NONE;
- name[0] = '\0';
m = MATCH_NO;

/* If we have to reject come back here later. */
@@ -190,7 +191,7 @@ gfc_match_member_sep(gfc_symbol *sym)
dot_loc = gfc_current_locus;

/* Try to match a symbol name following the dot. */
- if (gfc_match_name (name) != MATCH_YES)
+ if (gfc_match_name (&name) != MATCH_YES)
{
gfc_error ("Expected structure component or operator name "
"after '.' at %C");
@@ -634,17 +635,18 @@ gfc_match_label (void)
}


-/* See if the current input looks like a name of some sort. Modifies
- the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
+/* See if the current input looks like a name of some sort.
+ Upon success RESULT is set to the matched name and MATCH_YES is returned.
Note that options.c restricts max_identifier_length to not more
than GFC_MAX_SYMBOL_LEN. */

match
-gfc_match_name (char *buffer)
+gfc_match_name (const char **result)
{
locus old_loc;
int i;
char c;
+ char buffer[GFC_MAX_SYMBOL_LEN + 1];

old_loc = gfc_current_locus;
gfc_gobble_whitespace ();
@@ -685,7 +687,7 @@ gfc_match_name (char *buffer)
return MATCH_ERROR;
}

- buffer[i] = '\0';
+ *result = IDENTIFIER_POINTER (get_identifier_with_length (buffer, i));
gfc_current_locus = old_loc;

return MATCH_YES;
@@ -698,10 +700,10 @@ gfc_match_name (char *buffer)
match
gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc)
{
- char buffer[GFC_MAX_SYMBOL_LEN + 1];
+ const char *buffer = NULL;
match m;

- m = gfc_match_name (buffer);
+ m = gfc_match_name (&buffer);
if (m != MATCH_YES)
return m;

@@ -1123,6 +1125,7 @@ gfc_match (const char *target, ...)
locus old_loc;
va_list argp;
char c, *np;
+ const char *name2_hack = NULL;
match m, n;
void **vp;
const char *p;
@@ -1186,12 +1189,13 @@ loop:

case 'n':
np = va_arg (argp, char *);
- n = gfc_match_name (np);
+ n = gfc_match_name (&name2_hack);
if (n != MATCH_YES)
{
m = n;
goto not_yes;
}
+ strcpy (np, name2_hack);

matches++;
goto loop;
@@ -1694,12 +1698,12 @@ got_match:
match
gfc_match_else (void)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;

if (gfc_match_eos () == MATCH_YES)
return MATCH_YES;

- if (gfc_match_name (name) != MATCH_YES
+ if (gfc_match_name (&name) != MATCH_YES
|| gfc_current_block () == NULL
|| gfc_match_eos () != MATCH_YES)
{
@@ -1723,7 +1727,7 @@ gfc_match_else (void)
match
gfc_match_elseif (void)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_expr *expr;
match m;

@@ -1734,7 +1738,7 @@ gfc_match_elseif (void)
if (gfc_match_eos () == MATCH_YES)
goto done;

- if (gfc_match_name (name) != MATCH_YES
+ if (gfc_match_name (&name) != MATCH_YES
|| gfc_current_block () == NULL
|| gfc_match_eos () != MATCH_YES)
{
@@ -5029,23 +5033,23 @@ gfc_get_common (const char *name, int from_module)

/* Match a common block name. */

-match match_common_name (char *name)
+match match_common_name (const char *&name)
{
match m;

if (gfc_match_char ('/') == MATCH_NO)
{
- name[0] = '\0';
+ name = NULL;
return MATCH_YES;
}

if (gfc_match_char ('/') == MATCH_YES)
{
- name[0] = '\0';
+ name = NULL;
return MATCH_YES;
}

- m = gfc_match_name (name);
+ m = gfc_match_name (&name);

if (m == MATCH_ERROR)
return MATCH_ERROR;
@@ -5063,7 +5067,7 @@ match
gfc_match_common (void)
{
gfc_symbol *sym, **head, *tail, *other;
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_common_head *t;
gfc_array_spec *as;
gfc_equiv *e1, *e2;
@@ -5077,7 +5081,7 @@ gfc_match_common (void)
if (m == MATCH_ERROR)
goto cleanup;

- if (name[0] == '\0')
+ if (name == NULL)
{
t = &gfc_current_ns->blank_common;
if (t->head == NULL)
@@ -5736,10 +5740,10 @@ gfc_match_ptr_fcn_assign (void)
gfc_symbol *sym;
gfc_expr *expr;
match m;
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;

old_loc = gfc_current_locus;
- m = gfc_match_name (name);
+ m = gfc_match_name (&name);
if (m != MATCH_YES)
return m;

@@ -5888,7 +5892,7 @@ cleanup:
static match
match_case_eos (void)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
match m;

if (gfc_match_eos () == MATCH_YES)
@@ -5901,7 +5905,7 @@ match_case_eos (void)

gfc_gobble_whitespace ();

- m = gfc_match_name (name);
+ m = gfc_match_name (&name);
if (m != MATCH_YES)
return m;

@@ -6589,7 +6593,7 @@ gfc_match_where (gfc_statement *st)
match
gfc_match_elsewhere (void)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_expr *expr;
match m;

@@ -6622,7 +6626,7 @@ gfc_match_elsewhere (void)
goto cleanup;
}
/* Better be a name at this point. */
- m = gfc_match_name (name);
+ m = gfc_match_name (&name);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index b3ced3f8454..62554d9667e 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -50,7 +50,7 @@ match gfc_match_st_label (gfc_st_label **);
match gfc_match_label (void);
match gfc_match_small_int (int *);
match gfc_match_small_int_expr (int *, gfc_expr **);
-match gfc_match_name (char *);
+match gfc_match_name (const char **);
match gfc_match_name_C (const char **buffer);
match gfc_match_symbol (gfc_symbol **, int);
match gfc_match_sym_tree (gfc_symtree **, int);
@@ -107,7 +107,7 @@ match gfc_match_call (void);

TODO: should probably rename this now that it'll be globally seen to
gfc_match_common_name. */
-match match_common_name (char *name);
+match match_common_name (const char *&name);

match gfc_match_common (void);
match gfc_match_block_data (void);
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 993ea9f16b9..f31677b3b5e 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -520,6 +520,7 @@ match
gfc_match_use (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1], module_nature[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name2 = NULL;
gfc_use_rename *tail = NULL, *new_use;
interface_type type, type2;
gfc_intrinsic_op op;
@@ -583,14 +584,14 @@ gfc_match_use (void)

use_list->where = gfc_current_locus;

- m = gfc_match_name (name);
+ m = gfc_match_name (&name2);
if (m != MATCH_YES)
{
free (use_list);
return m;
}

- use_list->module_name = gfc_get_string ("%s", name);
+ use_list->module_name = name2;

if (gfc_match_eos () == MATCH_YES)
goto done;
diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index a852fc490db..10a5df92e61 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -1580,8 +1580,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
&& gfc_match ("reduction ( ") == MATCH_YES)
{
gfc_omp_reduction_op rop = OMP_REDUCTION_NONE;
- char buffer[GFC_MAX_SYMBOL_LEN + 3];
- const char *op = NULL;
+ const char *buffer = NULL;
if (gfc_match_char ('+') == MATCH_YES)
rop = OMP_REDUCTION_PLUS;
else if (gfc_match_char ('*') == MATCH_YES)
@@ -1597,11 +1596,11 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
else if (gfc_match (".neqv.") == MATCH_YES)
rop = OMP_REDUCTION_NEQV;
if (rop != OMP_REDUCTION_NONE)
- op = gfc_get_string ("operator %s",
+ buffer = gfc_get_string ("operator %s",
gfc_op2string ((gfc_intrinsic_op) rop));
- else if (gfc_match_defined_op_name (op, 1, 1) == MATCH_YES)
+ else if (gfc_match_defined_op_name (buffer, 1, 1) == MATCH_YES)
;
- else if (gfc_match_name (buffer) == MATCH_YES)
+ else if (gfc_match_name (&buffer) == MATCH_YES)
{
gfc_symbol *sym;
const char *n = buffer;
@@ -1657,11 +1656,9 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
rop = OMP_REDUCTION_NONE;
}
else
- buffer[0] = '\0';
+ buffer = NULL;
gfc_omp_udr *udr;
- if (op != NULL)
- udr = gfc_find_omp_udr (gfc_current_ns, op, NULL);
- else if (buffer[0])
+ if (buffer != NULL)
udr = gfc_find_omp_udr (gfc_current_ns, buffer, NULL);
else
udr = NULL;
@@ -1680,7 +1677,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
n = *head;
*head = NULL;
gfc_error_now ("!$OMP DECLARE REDUCTION %s not found "
- "at %L", op ? op : buffer, &old_loc);
+ "at %L", buffer, &old_loc);
gfc_free_omp_namelist (n);
}
else
@@ -2290,13 +2287,13 @@ gfc_match_oacc_routine (void)

if (m == MATCH_YES)
{
- char buffer[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_symtree *st;

- m = gfc_match_name (buffer);
+ m = gfc_match_name (&name);
if (m == MATCH_YES)
{
- st = gfc_find_symtree (gfc_current_ns->sym_root, buffer);
+ st = gfc_find_symtree (gfc_current_ns->sym_root, name);
if (st)
{
sym = st->n.sym;
@@ -2313,7 +2310,7 @@ gfc_match_oacc_routine (void)
{
gfc_error ("Syntax error in !$ACC ROUTINE ( NAME ) at %C, "
"invalid function name %s",
- (sym) ? sym->name : buffer);
+ (sym) ? sym->name : name);
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index 094f2101bbc..b30938ef61c 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -39,7 +39,7 @@ int matching_actual_arglist = 0;
static match
match_kind_param (int *kind, int *is_iso_c)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_symbol *sym;
match m;

@@ -49,7 +49,7 @@ match_kind_param (int *kind, int *is_iso_c)
if (m != MATCH_NO)
return m;

- m = gfc_match_name (name);
+ m = gfc_match_name (&name);
if (m != MATCH_YES)
return m;

@@ -1234,12 +1234,12 @@ match_logical_constant (gfc_expr **result)
static match
match_sym_complex_part (gfc_expr **result)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_symbol *sym;
gfc_expr *e;
match m;

- m = gfc_match_name (name);
+ m = gfc_match_name (&name);
if (m != MATCH_YES)
return m;

@@ -1525,7 +1525,7 @@ gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns)
static match
match_actual_arg (gfc_expr **result)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_symtree *symtree;
locus where, w;
gfc_expr *e;
@@ -1534,7 +1534,7 @@ match_actual_arg (gfc_expr **result)
gfc_gobble_whitespace ();
where = gfc_current_locus;

- switch (gfc_match_name (name))
+ switch (gfc_match_name (&name))
{
case MATCH_ERROR:
return MATCH_ERROR;
@@ -1629,13 +1629,13 @@ match_actual_arg (gfc_expr **result)
static match
match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base, bool pdt)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_actual_arglist *a;
locus name_locus;
match m;

name_locus = gfc_current_locus;
- m = gfc_match_name (name);
+ m = gfc_match_name (&name);

if (m != MATCH_YES)
goto cleanup;
@@ -1667,7 +1667,7 @@ match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base, bool pd

/* Make sure this name has not appeared yet. */
add_name:
- if (name[0] != '\0')
+ if (name != NULL)
{
for (a = base; a; a = a->next)
if (a->name != NULL && strcmp (a->name, name) == 0)
@@ -1678,7 +1678,7 @@ add_name:
}
}

- actual->name = gfc_get_string ("%s", name);
+ actual->name = name;
return MATCH_YES;

cleanup:
@@ -1948,7 +1948,7 @@ match
gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
bool ppc_arg)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_ref *substring, *tail, *tmp;
gfc_component *component;
gfc_symbol *sym = primary->symtree->n.sym;
@@ -2136,7 +2136,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
bool t;
gfc_symtree *tbp;

- m = gfc_match_name (name);
+ m = gfc_match_name (&name);
if (m == MATCH_NO)
gfc_error ("Expected structure component name at %C");
if (m != MATCH_YES)
@@ -3144,7 +3144,8 @@ match
gfc_match_rvalue (gfc_expr **result)
{
gfc_actual_arglist *actual_arglist;
- char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
+ char argname[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_state_data *st;
gfc_symbol *sym;
gfc_symtree *symtree;
@@ -3161,12 +3162,12 @@ gfc_match_rvalue (gfc_expr **result)
{
if (!gfc_notify_std (GFC_STD_LEGACY, "%%LOC() as an rvalue at %C"))
return MATCH_ERROR;
- strncpy (name, "loc", 4);
+ name = gfc_get_string ("%s", "loc");
}

else
{
- m = gfc_match_name (name);
+ m = gfc_match_name (&name);
if (m != MATCH_YES)
return m;
}

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

gcc/fortran/ChangeLog:

2017-11-15 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* gfortran.h (struct gfc_common_head, struct gfc_intrinsic_arg):
Make name a pointer.
* intrinsic.c (add_sym): Use stringpool for name.
* match.c (gfc_get_common): Likewise.
* symbol.c (set_symbol_common_block): Likewise.
* trans-common.c (gfc_sym_mangled_common_id): Likewise.
(finish_equivalences): Likewise.
(gfc_trans_common): Likewise.
---
gcc/fortran/gfortran.h | 4 ++--
gcc/fortran/intrinsic.c | 11 +++--------
gcc/fortran/match.c | 2 +-
gcc/fortran/symbol.c | 2 +-
gcc/fortran/trans-common.c | 10 +++++-----
5 files changed, 12 insertions(+), 17 deletions(-)

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index cb9195d393e..039719644ea 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1641,7 +1641,7 @@ typedef struct gfc_common_head
char use_assoc, saved, threadprivate;
unsigned char omp_declare_target : 1;
unsigned char omp_declare_target_link : 1;
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name;
struct gfc_symbol *head;
const char* binding_label;
int is_bind_c;
@@ -1978,7 +1978,7 @@ gfc_ref;
/* Structures representing intrinsic symbols and their arguments lists. */
typedef struct gfc_intrinsic_arg
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name;

gfc_typespec ts;
unsigned optional:1, value:1;
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 609668613a7..3a32a7824bf 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -317,7 +317,6 @@ add_sym (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type
int standard, gfc_check_f check, gfc_simplify_f simplify,
gfc_resolve_f resolve, ...)
{
- char buf[GFC_MAX_SYMBOL_LEN + 11]; /* 10 for '_gfortran_', 1 for '\0' */
int optional, first_flag;
sym_intent intent;
va_list argp;
@@ -334,11 +333,7 @@ add_sym (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type

case SZ_NOTHING:
next_sym->name = gfc_get_string ("%s", name);
-
- strcpy (buf, "_gfortran_");
- strcat (buf, name);
- next_sym->lib_name = gfc_get_string ("%s", buf);
-
+ next_sym->lib_name = gfc_get_string ("_gfortran_%s", name);
next_sym->pure = (cl != CLASS_IMPURE);
next_sym->elemental = (cl == CLASS_ELEMENTAL);
next_sym->inquiry = (cl == CLASS_INQUIRY);
@@ -388,7 +383,7 @@ add_sym (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type

first_flag = 0;

- strcpy (next_arg->name, name);
+ next_arg->name = gfc_get_string ("%s", name);
next_arg->ts.type = type;
next_arg->ts.kind = kind;
next_arg->optional = optional;
@@ -4145,7 +4140,7 @@ keywords:
for (; a; a = a->next)
{
for (f = formal; f; f = f->next)
- if (strcmp (a->name, f->name) == 0)
+ if (a->name == f->name)
break;

if (f == NULL)
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 2c4d6e8228c..fd91e280b93 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -5029,7 +5029,7 @@ gfc_get_common (const char *name, int from_module)
{
st->n.common = gfc_get_common_head ();
st->n.common->where = gfc_current_locus;
- strcpy (st->n.common->name, name);
+ st->n.common->name = name;
}

return st->n.common;
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 00a178772df..cc9d4e3f9d8 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -3057,7 +3057,7 @@ set_symbol_common_block (gfc_symbol *sym, gfc_common_head *common_block)
if (sym->common_block == common_block)
return;

- if (sym->common_block && sym->common_block->name[0] != '\0')
+ if (sym->common_block && sym->common_block->name != NULL)
{
sym->common_block->refs--;
if (sym->common_block->refs == 0)
diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c
index bd9721dee41..18f87e00320 100644
--- a/gcc/fortran/trans-common.c
+++ b/gcc/fortran/trans-common.c
@@ -243,16 +243,16 @@ gfc_sym_mangled_common_id (gfc_common_head *com)
{
int has_underscore;
char mangled_name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name;

/* Get the name out of the common block pointer. */
- strcpy (name, com->name);
+ name = com->name;

/* If we're suppose to do a bind(c). */
if (com->is_bind_c == 1 && com->binding_label)
return get_identifier (com->binding_label);

- if (strcmp (name, BLANK_COMMON_NAME) == 0)
+ if (name == gfc_get_string (BLANK_COMMON_NAME))
return get_identifier (name);

if (flag_underscoring)
@@ -1252,7 +1252,7 @@ finish_equivalences (gfc_namespace *ns)
c->where = ns->proc_name->declared_at;
else if (ns->is_block_data)
c->where = ns->sym_root->n.sym->declared_at;
- strcpy (c->name, z->module);
+ c->name = z->module;
}
else
c = NULL;
@@ -1286,7 +1286,7 @@ gfc_trans_common (gfc_namespace *ns)
{
c = gfc_get_common_head ();
c->where = ns->blank_common.head->common_head->where;
- strcpy (c->name, BLANK_COMMON_NAME);
+ c->name = gfc_get_string (BLANK_COMMON_NAME);
translate_common (c, ns->blank_common.head);
}

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

Due to a typo a user operator used in a reduction was not found in the
symtree so would have been written multiple times (in theory).

E.g. user operator ".add." was looked up as ".ad" instead of "add".

For gcc-8 branch and earlier one would
- memcpy (name, udr->name, len - 1);
+ memcpy (name, udr->name + 1, len - 1);

but for gcc-9 we have an appropriate helper already.
Jakub, please take care of non-trunk branches if you want it fixed
there.

gcc/fortran/ChangeLog:

2017-11-16 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* module.c (write_omp_udr): Use gfc_get_name_from_uop.
---
gcc/fortran/module.c | 8 ++------
1 file changed, 2 insertions(+), 6 deletions(-)

diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index fe5ae34dd13..b94411ac68b 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -5685,12 +5685,8 @@ write_omp_udr (gfc_omp_udr *udr)
return;
else
{
- gfc_symtree *st;
- size_t len = strlen (udr->name + 1);
- char *name = XALLOCAVEC (char, len);
- memcpy (name, udr->name, len - 1);
- name[len - 1] = '\0';
- st = gfc_find_symtree (gfc_current_ns->uop_root, name);
+ const char *name = gfc_get_name_from_uop (udr->name);
+ gfc_symtree *st = gfc_find_symtree (gfc_current_ns->uop_root, name);
/* If corresponding user operator is private, don't write
the UDR. */
if (st != NULL)

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

gcc/fortran/ChangeLog:

2017-11-29 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* match.c (gfc_get_common): Use stringpool for mangled name.
---
gcc/fortran/match.c | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index fd91e280b93..8d073f28f67 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -5008,13 +5008,13 @@ gfc_get_common (const char *name, int from_module)
{
gfc_symtree *st;
static int serial = 0;
- char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *mangled_name;

if (from_module)
{
/* A use associated common block is only needed to correctly layout
the variables it contains. */
- snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
+ mangled_name = gfc_get_string ("_%d_%s", serial++, name);
st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
}
else

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

Copying the sym->name ruins pointer equality checks and first and
foremost is not needed nowadays.

gcc/fortran/ChangeLog:

2018-09-02 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* decl.c (gfc_match_volatile, gfc_match_asynchronous): Do not
copy sym->name.
---
gcc/fortran/decl.c | 10 ++--------
1 file changed, 2 insertions(+), 8 deletions(-)

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 2667c2281f8..b0c45b88505 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -9167,7 +9167,6 @@ match
gfc_match_volatile (void)
{
gfc_symbol *sym;
- char *name;
match m;

if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE statement at %C"))
@@ -9189,9 +9188,7 @@ gfc_match_volatile (void)
switch (m)
{
case MATCH_YES:
- name = XCNEWVAR (char, strlen (sym->name) + 1);
- strcpy (name, sym->name);
- if (!check_function_name (name))
+ if (!check_function_name (sym->name))
return MATCH_ERROR;
/* F2008, C560+C561. VOLATILE for host-/use-associated variable or
for variable in a BLOCK which is defined outside of the BLOCK. */
@@ -9231,7 +9228,6 @@ match
gfc_match_asynchronous (void)
{
gfc_symbol *sym;
- char *name;
match m;

if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS statement at %C"))
@@ -9253,9 +9249,7 @@ gfc_match_asynchronous (void)
switch (m)
{
case MATCH_YES:
- name = XCNEWVAR (char, strlen (sym->name) + 1);
- strcpy (name, sym->name);
- if (!check_function_name (name))
+ if (!check_function_name (sym->name))
return MATCH_ERROR;
if (!gfc_add_asynchronous (&sym->attr, sym->name, &gfc_current_locus))
return MATCH_ERROR;

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

gcc/fortran/ChangeLog:

2017-11-29 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* iresolve.c (gfc_resolve_ctime_sub): Use stringpool for
intrinsic subroutine name.
(gfc_resolve_fdate_sub): Likewise.
(gfc_resolve_gerror): Likewise.
(gfc_resolve_getlog): Likewise.
(gfc_resolve_perror): Likewise.
(gfc_resolve_fseek_sub): Likewise.
(gfc_resolve_ttynam_sub): Likewise.
---
gcc/fortran/iresolve.c | 24 ++++++++++++++++--------
1 file changed, 16 insertions(+), 8 deletions(-)

diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index f22e0da54c9..61663fec7e5 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -3787,6 +3787,7 @@ gfc_resolve_flush (gfc_code *c)
void
gfc_resolve_ctime_sub (gfc_code *c)
{
+ const char *name;
gfc_typespec ts;
gfc_clear_ts (&ts);

@@ -3800,28 +3801,32 @@ gfc_resolve_ctime_sub (gfc_code *c)
gfc_convert_type (c->ext.actual->expr, &ts, 2);
}

- c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ctime_sub"));
+ name = gfc_get_string (PREFIX ("ctime_sub"));
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}


void
gfc_resolve_fdate_sub (gfc_code *c)
{
- c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fdate_sub"));
+ const char *name = gfc_get_string (PREFIX ("fdate_sub"));
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}


void
gfc_resolve_gerror (gfc_code *c)
{
- c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
+ const char *name = gfc_get_string (PREFIX ("gerror"));
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}


void
gfc_resolve_getlog (gfc_code *c)
{
- c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
+ const char *name = gfc_get_string (PREFIX ("getlog"));
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}


@@ -3844,7 +3849,8 @@ gfc_resolve_hostnm_sub (gfc_code *c)
void
gfc_resolve_perror (gfc_code *c)
{
- c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
+ const char *name = gfc_get_string (PREFIX ("perror_sub"));
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}

/* Resolve the STAT and FSTAT intrinsic subroutines. */
@@ -3976,6 +3982,7 @@ gfc_resolve_fput_sub (gfc_code *c)
void
gfc_resolve_fseek_sub (gfc_code *c)
{
+ const char *name;
gfc_expr *unit;
gfc_expr *offset;
gfc_expr *whence;
@@ -4012,8 +4019,8 @@ gfc_resolve_fseek_sub (gfc_code *c)
ts.u.cl = NULL;
gfc_convert_type (whence, &ts, 2);
}
-
- c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("fseek_sub"));
+ name = gfc_get_string (PREFIX ("fseek_sub"));
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}

void
@@ -4045,6 +4052,7 @@ gfc_resolve_ftell_sub (gfc_code *c)
void
gfc_resolve_ttynam_sub (gfc_code *c)
{
+ const char *name = gfc_get_string (PREFIX ("ttynam_sub"));
gfc_typespec ts;
gfc_clear_ts (&ts);

@@ -4057,7 +4065,7 @@ gfc_resolve_ttynam_sub (gfc_code *c)
gfc_convert_type (c->ext.actual->expr, &ts, 2);
}

- c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("ttynam_sub"));
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

Switch type bound procedures to use the stringpool.

gcc/fortran/ChangeLog:

2017-11-24 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* decl.c (gfc_match_decl_type_spec): Use stringpool.
* module.c (mio_expr): Likewise.
(mio_typebound_proc): Likewise.
(mio_full_typebound_tree): Likewise.
(mio_omp_udr_expr): Likewise.
---
gcc/fortran/decl.c | 9 +++++----
gcc/fortran/module.c | 24 ++++++++++++------------
2 files changed, 17 insertions(+), 16 deletions(-)

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index d6a6538f769..cc14a871dfd 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -4049,12 +4049,13 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
{
gfc_symbol *upe;
gfc_symtree *st;
+ const char *star_name = gfc_get_string ("%s", "STAR");
ts->type = BT_CLASS;
- gfc_find_symbol ("STAR", gfc_current_ns, 1, &upe);
+ gfc_find_symbol (star_name, gfc_current_ns, 1, &upe);
if (upe == NULL)
{
- upe = gfc_new_symbol ("STAR", gfc_current_ns);
- st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR");
+ upe = gfc_new_symbol (star_name, gfc_current_ns);
+ st = gfc_new_symtree (&gfc_current_ns->sym_root, star_name);
st->n.sym = upe;
gfc_set_sym_referenced (upe);
upe->refs++;
@@ -4069,7 +4070,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
}
else
{
- st = gfc_get_tbp_symtree (&gfc_current_ns->sym_root, "STAR");
+ st = gfc_get_tbp_symtree (&gfc_current_ns->sym_root, star_name);
st->n.sym = upe;
upe->refs++;
}
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 3b644234921..24e48c94c76 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -3585,9 +3585,9 @@ mio_expr (gfc_expr **ep)
case 3:
break;
default:
- require_atom (ATOM_STRING);
- e->value.function.isym = gfc_find_function (atom_string);
- free (atom_string);
+ const char *name;
+ mio_pool_string (&name);
+ e->value.function.isym = gfc_find_function (name);
}
}

@@ -3872,6 +3872,7 @@ mio_typebound_proc (gfc_typebound_proc** proc)
while (peek_atom () != ATOM_RPAREN)
{
gfc_symtree** sym_root;
+ const char *name;

g = gfc_get_tbp_generic ();
g->specific = NULL;
@@ -3879,10 +3880,9 @@ mio_typebound_proc (gfc_typebound_proc** proc)
mio_integer (&iop);
g->is_operator = (bool) iop;

- require_atom (ATOM_STRING);
+ mio_pool_string (&name);
sym_root = &current_f2k_derived->tb_sym_root;
- g->specific_st = gfc_get_tbp_symtree (sym_root, atom_string);
- free (atom_string);
+ g->specific_st = gfc_get_tbp_symtree (sym_root, name);

g->next = (*proc)->u.generic;
(*proc)->u.generic = g;
@@ -3928,12 +3928,12 @@ mio_full_typebound_tree (gfc_symtree** root)
while (peek_atom () == ATOM_LPAREN)
{
gfc_symtree* st;
+ const char *name;

mio_lparen ();

- require_atom (ATOM_STRING);
- st = gfc_get_tbp_symtree (root, atom_string);
- free (atom_string);
+ mio_pool_string (&name);
+ st = gfc_get_tbp_symtree (root, name);

mio_typebound_symtree (st);
}
@@ -4267,9 +4267,9 @@ mio_omp_udr_expr (gfc_omp_udr *udr, gfc_symbol **sym1, gfc_symbol **sym2,
mio_integer (&flag);
if (flag)
{
- require_atom (ATOM_STRING);
- ns->code->resolved_isym = gfc_find_subroutine (atom_string);
- free (atom_string);
+ const char *name;
+ mio_pool_string (&name);
+ ns->code->resolved_isym = gfc_find_subroutine (name);
}
else
mio_symbol_ref (&ns->code->resolved_sym);

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

Add matched names into the stringpool.

gcc/fortran/ChangeLog:

2017-10-26 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* match.c (gfc_match): Use pointer to pointer when matching a
name via "%n" format. Adjust all callers.
(gfc_match_label, gfc_match_iterator, gfc_match_char,
gfc_match_associate, match_derived_type_spec, gfc_match_type_spec,
match_exit_cycle, gfc_match_allocate, gfc_match_call,
gfc_match_block_data, select_type_set_tmp,
gfc_match_select_type): Adjust.
* decl.c (gfc_match_null, match_record_decl, gfc_match_decl_type_spec,
gfc_match_implicit_none, gfc_match_import, gfc_match_function_decl,
gfc_match_subroutine, gfc_match_save, gfc_match_submod_proc,
check_extended_derived_type, gfc_get_type_attr_spec,
gfc_match_structure_decl, gfc_match_derived_decl,
match_binding_attributes): Adjust.
* interface.c (dtio_op, gfc_match_generic_spec): Adjust.
* io.c (match_dt_element): Adjust.
* matchexp.c (gfc_match_defined_op_name): Adjust.
* module.c (gfc_match_use, gfc_match_submodule): Adjust.
* primary.c (match_arg_list_function, gfc_match_rvalue): Adjust.
* openmp.c (gfc_match_omp_variable_list, gfc_match_omp_to_link,
gfc_match_oacc_clause_link, match_udr_expr,
gfc_match_omp_declare_reduction, gfc_match_omp_threadprivate): Adjust.
(gfc_match_omp_critical): Adjust. Do not strdup critical_name.
(gfc_free_omp_clauses): Do not free critical_name.
(gfc_match_omp_end_critical): Adjust. Do not strdup omp_name.
* parse.c (parse_omp_structured_block): Do not free omp_name.
(match_deferred_characteristics): Adjust.
---
gcc/fortran/decl.c | 81 ++++++++++++++++++++---------------------
gcc/fortran/interface.c | 11 +++---
gcc/fortran/io.c | 4 +-
gcc/fortran/match.c | 62 +++++++++++++++----------------
gcc/fortran/matchexp.c | 4 +-
gcc/fortran/module.c | 12 +++---
gcc/fortran/openmp.c | 70 ++++++++++++++++-------------------
gcc/fortran/parse.c | 5 +--
gcc/fortran/primary.c | 8 ++--
9 files changed, 123 insertions(+), 134 deletions(-)

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 2f8d2aca695..2667c2281f8 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -2169,16 +2169,16 @@ gfc_match_null (gfc_expr **result)
if (m == MATCH_NO)
{
locus old_loc;
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;

if ((m2 = gfc_match (" null (")) != MATCH_YES)
return m2;

old_loc = gfc_current_locus;
- if ((m2 = gfc_match (" %n ) ", name)) == MATCH_ERROR)
+ if ((m2 = gfc_match (" %n ) ", &name)) == MATCH_ERROR)
return MATCH_ERROR;
if (m2 != MATCH_YES
- && ((m2 = gfc_match (" mold = %n )", name)) == MATCH_ERROR))
+ && ((m2 = gfc_match (" mold = %n )", &name)) == MATCH_ERROR))
return MATCH_ERROR;
if (m2 == MATCH_NO)
{
@@ -3307,7 +3307,7 @@ done:
/* Matches a RECORD declaration. */

static match
-match_record_decl (char *name)
+match_record_decl (const char **name)
{
locus old_loc;
old_loc = gfc_current_locus;
@@ -3824,7 +3824,7 @@ error_return:
match
gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_symbol *sym, *dt_sym;
match m;
char c;
@@ -3883,7 +3883,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
return MATCH_YES;
}

- m = gfc_match ("%n", name);
+ m = gfc_match ("%n", &name);
matched_type = (m == MATCH_YES);
}

@@ -3989,7 +3989,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
}

if (m != MATCH_YES)
- m = match_record_decl (name);
+ m = match_record_decl (&name);

if (matched_type || m == MATCH_YES)
{
@@ -4011,7 +4011,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
return m;
gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
ts->u.derived = sym;
- strcpy (name, gfc_dt_lower_string (sym->name));
+ name = gfc_dt_lower_string (sym->name);
}

if (sym && sym->attr.flavor == FL_STRUCT)
@@ -4085,7 +4085,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
m = gfc_match (" class (");

if (m == MATCH_YES)
- m = gfc_match ("%n", name);
+ m = gfc_match ("%n", &name);
else
return m;

@@ -4190,7 +4190,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
return m;
gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
ts->u.derived = sym;
- strcpy (name, gfc_dt_lower_string (sym->name));
+ name = gfc_dt_lower_string (sym->name);
}

gfc_save_symbol_data (sym);
@@ -4306,7 +4306,7 @@ gfc_match_implicit_none (void)
{
char c;
match m;
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
bool type = false;
bool external = false;
locus cur_loc = gfc_current_locus;
@@ -4335,7 +4335,7 @@ gfc_match_implicit_none (void)
else
for(;;)
{
- m = gfc_match (" %n", name);
+ m = gfc_match (" %n", &name);
if (m != MATCH_YES)
return MATCH_ERROR;

@@ -4589,7 +4589,7 @@ error:
match
gfc_match_import (void)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
match m;
gfc_symbol *sym;
gfc_symtree *st;
@@ -4631,7 +4631,7 @@ gfc_match_import (void)
for(;;)
{
sym = NULL;
- m = gfc_match (" %n", name);
+ m = gfc_match (" %n", &name);
switch (m)
{
case MATCH_YES:
@@ -6969,7 +6969,7 @@ do_warn_intrinsic_shadow (const gfc_symbol* sym, bool func)
match
gfc_match_function_decl (void)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_symbol *sym, *result;
locus old_loc;
match m;
@@ -6992,7 +6992,7 @@ gfc_match_function_decl (void)
return m;
}

- if (gfc_match ("function% %n", name) != MATCH_YES)
+ if (gfc_match ("function% %n", &name) != MATCH_YES)
{
gfc_current_locus = old_loc;
return MATCH_NO;
@@ -7438,7 +7438,7 @@ gfc_match_entry (void)
match
gfc_match_subroutine (void)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_symbol *sym;
match m;
match is_bind_c;
@@ -7454,7 +7454,7 @@ gfc_match_subroutine (void)
if (m != MATCH_YES)
return m;

- m = gfc_match ("subroutine% %n", name);
+ m = gfc_match ("subroutine% %n", &name);
if (m != MATCH_YES)
return m;

@@ -9036,7 +9036,7 @@ syntax:
match
gfc_match_save (void)
{
- char n[GFC_MAX_SYMBOL_LEN+1];
+ const char *name = NULL;
gfc_common_head *c;
gfc_symbol *sym;
match m;
@@ -9081,13 +9081,13 @@ gfc_match_save (void)
return MATCH_ERROR;
}

- m = gfc_match (" / %n /", &n);
+ m = gfc_match (" / %n /", &name);
if (m == MATCH_ERROR)
return MATCH_ERROR;
if (m == MATCH_NO)
goto syntax;

- c = gfc_get_common (n, 0);
+ c = gfc_get_common (name, 0);
c->saved = 1;

gfc_current_ns->seen_save = 1;
@@ -9288,7 +9288,7 @@ syntax:
match
gfc_match_submod_proc (void)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_symbol *sym, *fsym;
match m;
gfc_formal_arglist *formal, *head, *tail;
@@ -9299,7 +9299,7 @@ gfc_match_submod_proc (void)
|| gfc_state_stack->previous->state == COMP_MODULE)))
return MATCH_NO;

- m = gfc_match (" module% procedure% %n", name);
+ m = gfc_match (" module% procedure% %n", &name);
if (m != MATCH_YES)
return m;

@@ -9497,7 +9497,7 @@ syntax:
/* Check a derived type that is being extended. */

static gfc_symbol*
-check_extended_derived_type (char *name)
+check_extended_derived_type (const char * const name)
{
gfc_symbol *extended;

@@ -9548,7 +9548,7 @@ check_extended_derived_type (char *name)
checking on attribute conflicts needs to be done. */

match
-gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
+gfc_get_type_attr_spec (symbol_attribute *attr, const char **name)
{
/* See if the derived type is marked as private. */
if (gfc_match (" , private") == MATCH_YES)
@@ -9594,7 +9594,7 @@ gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
if (!gfc_add_abstract (attr, &gfc_current_locus))
return MATCH_ERROR;
}
- else if (name && gfc_match (" , extends ( %n )", name) == MATCH_YES)
+ else if (gfc_match (" , extends ( %n )", name) == MATCH_YES)
{
if (!gfc_add_extension (attr, &gfc_current_locus))
return MATCH_ERROR;
@@ -9748,7 +9748,7 @@ gfc_match_structure_decl (void)
{
/* Counter used to give unique internal names to anonymous structures. */
static unsigned int gfc_structure_id = 0;
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_symbol *sym;
match m;
locus where;
@@ -9761,9 +9761,7 @@ gfc_match_structure_decl (void)
return MATCH_ERROR;
}

- name[0] = '\0';
-
- m = gfc_match (" /%n/", name);
+ m = gfc_match (" /%n/", &name);
if (m != MATCH_YES)
{
/* Non-nested structure declarations require a structure name. */
@@ -9779,8 +9777,9 @@ gfc_match_structure_decl (void)
and setting gfc_new_symbol, which is immediately used by
parse_structure () and variable_decl () to add components of
this type. */
- snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "SS$%u", gfc_structure_id++);
+ name = gfc_get_string ("SS$%u", gfc_structure_id++);
}
+ /* FIXME: should move gfc_is_intrinsic_typename to else branch here! */

where = gfc_current_locus;
/* No field list allowed after non-nested structure declaration. */
@@ -9912,8 +9911,8 @@ typeis:
match
gfc_match_derived_decl (void)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
- char parent[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
+ const char *parent = NULL;
symbol_attribute attr;
gfc_symbol *sym, *gensym;
gfc_symbol *extended;
@@ -9927,14 +9926,12 @@ gfc_match_derived_decl (void)
if (gfc_comp_struct (gfc_current_state ()))
return MATCH_NO;

- name[0] = '\0';
- parent[0] = '\0';
gfc_clear_attr (&attr);
extended = NULL;

do
{
- is_type_attr_spec = gfc_get_type_attr_spec (&attr, parent);
+ is_type_attr_spec = gfc_get_type_attr_spec (&attr, &parent);
if (is_type_attr_spec == MATCH_ERROR)
return MATCH_ERROR;
if (is_type_attr_spec == MATCH_YES)
@@ -9944,10 +9941,10 @@ gfc_match_derived_decl (void)
/* Deal with derived type extensions. The extension attribute has
been added to 'attr' but now the parent type must be found and
checked. */
- if (parent[0])
+ if (parent != NULL)
extended = check_extended_derived_type (parent);

- if (parent[0] && !extended)
+ if (parent != NULL && !extended)
return MATCH_ERROR;

m = gfc_match (" ::");
@@ -9961,7 +9958,7 @@ gfc_match_derived_decl (void)
return MATCH_ERROR;
}

- m = gfc_match (" %n ", name);
+ m = gfc_match (" %n ", &name);
if (m != MATCH_YES)
return m;

@@ -10474,7 +10471,7 @@ match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc)
goto error;
if (m == MATCH_YES)
{
- char arg[GFC_MAX_SYMBOL_LEN + 1];
+ const char *arg = NULL;

if (found_passing)
{
@@ -10483,11 +10480,11 @@ match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc)
goto error;
}

- m = gfc_match (" ( %n )", arg);
+ m = gfc_match (" ( %n )", &arg);
if (m == MATCH_ERROR)
goto error;
if (m == MATCH_YES)
- ba->pass_arg = gfc_get_string ("%s", arg);
+ ba->pass_arg = arg;
gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));

found_passing = true;
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 6a5fe928b93..19a0eb28edd 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -120,7 +120,7 @@ fold_unary_intrinsic (gfc_intrinsic_op op)
beyond GFC_INTRINSIC_END in gfortran.h:enum gfc_intrinsic_op. */

static gfc_intrinsic_op
-dtio_op (char* mode)
+dtio_op (const char* mode)
{
if (strncmp (mode, "formatted", 9) == 0)
return INTRINSIC_FORMATTED;
@@ -139,7 +139,6 @@ gfc_match_generic_spec (interface_type *type,
const char *&name,
gfc_intrinsic_op *op)
{
- char buffer[GFC_MAX_SYMBOL_LEN + 1];
match m;
gfc_intrinsic_op i;

@@ -178,9 +177,9 @@ gfc_match_generic_spec (interface_type *type,
return MATCH_YES;
}

- if (gfc_match (" read ( %n )", buffer) == MATCH_YES)
+ if (gfc_match (" read ( %n )", &name) == MATCH_YES)
{
- *op = dtio_op (buffer);
+ *op = dtio_op (name);
if (*op == INTRINSIC_FORMATTED)
{
name = gfc_code2string (dtio_procs, DTIO_RF);
@@ -195,9 +194,9 @@ gfc_match_generic_spec (interface_type *type,
return MATCH_YES;
}

- if (gfc_match (" write ( %n )", buffer) == MATCH_YES)
+ if (gfc_match (" write ( %n )", &name) == MATCH_YES)
{
- *op = dtio_op (buffer);
+ *op = dtio_op (name);
if (*op == INTRINSIC_FORMATTED)
{
name = gfc_code2string (dtio_procs, DTIO_WF);
diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index 1d07076c377..ab7e0f7bd04 100644
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -3077,7 +3077,7 @@ check_namelist (gfc_symbol *sym)
static match
match_dt_element (io_kind k, gfc_dt *dt)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_symbol *sym;
match m;

@@ -3095,7 +3095,7 @@ match_dt_element (io_kind k, gfc_dt *dt)
return m;
}

- if (gfc_match (" nml = %n", name) == MATCH_YES)
+ if (gfc_match (" nml = %n", &name) == MATCH_YES)
{
if (dt->namelist != NULL)
{
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index f3ad91a07c0..1b03e7251a5 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -606,12 +606,12 @@ cleanup:
match
gfc_match_label (void)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
match m;

gfc_new_block = NULL;

- m = gfc_match (" %n :", name);
+ m = gfc_match (" %n :", &name);
if (m != MATCH_YES)
return m;

@@ -991,7 +991,7 @@ gfc_match_intrinsic_op (gfc_intrinsic_op *result)
match
gfc_match_iterator (gfc_iterator *iter, int init_flag)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_expr *var, *e1, *e2, *e3;
locus start;
match m;
@@ -1001,7 +1001,7 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag)
/* Match the start of an iterator without affecting the symbol table. */

start = gfc_current_locus;
- m = gfc_match (" %n =", name);
+ m = gfc_match (" %n =", &name);
gfc_current_locus = start;

if (m != MATCH_YES)
@@ -1110,7 +1110,7 @@ gfc_match_char (char c)
%% Literal percent sign
%e Expression, pointer to a pointer is set
%s Symbol, pointer to the symbol is set
- %n Name, character buffer is set to name
+ %n Name, pointer to pointer is set
%t Matches end of statement.
%o Matches an intrinsic operator, returned as an INTRINSIC enum.
%l Matches a statement label
@@ -1124,8 +1124,7 @@ gfc_match (const char *target, ...)
int matches, *ip;
locus old_loc;
va_list argp;
- char c, *np;
- const char *name2_hack = NULL;
+ char c;
match m, n;
void **vp;
const char *p;
@@ -1188,14 +1187,13 @@ loop:
goto loop;

case 'n':
- np = va_arg (argp, char *);
- n = gfc_match_name (&name2_hack);
+ vp = va_arg (argp, void **);
+ n = gfc_match_name ((const char **) vp);
if (n != MATCH_YES)
{
m = n;
goto not_yes;
}
- strcpy (np, name2_hack);

matches++;
goto loop;
@@ -1893,7 +1891,8 @@ gfc_match_associate (void)
gfc_association_list* a;

/* Match the next association. */
- if (gfc_match (" %n =>", newAssoc->name) != MATCH_YES)
+ const char *name_hack = NULL;
+ if (gfc_match (" %n =>", &name_hack) != MATCH_YES)
{
gfc_error ("Expected association at %C");
goto assocListError;
@@ -1910,6 +1909,7 @@ gfc_match_associate (void)
}
gfc_matching_procptr_assignment = 0;
}
+ strcpy (newAssoc->name, name_hack);
newAssoc->where = gfc_current_locus;

/* Check that the current name is not yet in the list. */
@@ -1978,7 +1978,7 @@ error:
static match
match_derived_type_spec (gfc_typespec *ts)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
locus old_locus;
gfc_symbol *derived, *der_type;
match m = MATCH_YES;
@@ -1987,7 +1987,7 @@ match_derived_type_spec (gfc_typespec *ts)

old_locus = gfc_current_locus;

- if (gfc_match ("%n", name) != MATCH_YES)
+ if (gfc_match ("%n", &name) != MATCH_YES)
{
gfc_current_locus = old_locus;
return MATCH_NO;
@@ -2064,7 +2064,8 @@ gfc_match_type_spec (gfc_typespec *ts)
{
match m;
locus old_locus;
- char c, name[GFC_MAX_SYMBOL_LEN + 1];
+ char c;
+ const char *name = NULL;

gfc_clear_ts (ts);
gfc_gobble_whitespace ();
@@ -2131,7 +2132,7 @@ gfc_match_type_spec (gfc_typespec *ts)
written the use of LOGICAL as a type-spec or intrinsic subprogram
was overlooked. */

- m = gfc_match (" %n", name);
+ m = gfc_match (" %n", &name);
if (m == MATCH_YES
&& (strcmp (name, "real") == 0 || strcmp (name, "logical") == 0))
{
@@ -2173,7 +2174,7 @@ gfc_match_type_spec (gfc_typespec *ts)

/* Look for the optional KIND=. */
where = gfc_current_locus;
- m = gfc_match ("%n", name);
+ m = gfc_match ("%n", &name); /* ??? maybe don't hash into identifier ?*/
if (m == MATCH_YES)
{
gfc_gobble_whitespace ();
@@ -2710,10 +2711,10 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op)
sym = NULL;
else
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_symtree* stree;

- m = gfc_match ("% %n%t", name);
+ m = gfc_match ("% %n%t", &name);
if (m == MATCH_ERROR)
return MATCH_ERROR;
if (m == MATCH_NO)
@@ -4130,9 +4131,9 @@ gfc_match_allocate (void)
goto cleanup;
else if (m == MATCH_NO)
{
- char name[GFC_MAX_SYMBOL_LEN + 3];
+ const char *name = NULL;

- if (gfc_match ("%n :: ", name) == MATCH_YES)
+ if (gfc_match ("%n :: ", &name) == MATCH_YES)
{
gfc_error ("Error in type-spec at %L", &old_locus);
goto cleanup;
@@ -4856,7 +4857,7 @@ match_typebound_call (gfc_symtree* varst)
match
gfc_match_call (void)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_actual_arglist *a, *arglist;
gfc_case *new_case;
gfc_symbol *sym;
@@ -4867,7 +4868,7 @@ gfc_match_call (void)

arglist = NULL;

- m = gfc_match ("% %n", name);
+ m = gfc_match ("% %n", &name);
if (m == MATCH_NO)
goto syntax;
if (m != MATCH_YES)
@@ -4937,10 +4938,9 @@ gfc_match_call (void)
{
gfc_symtree *select_st;
gfc_symbol *select_sym;
- char name[GFC_MAX_SYMBOL_LEN + 1];

new_st.next = c = gfc_get_code (EXEC_SELECT);
- sprintf (name, "_result_%s", sym->name);
+ name = gfc_get_string ("_result_%s", sym->name);
gfc_get_ha_sym_tree (name, &select_st); /* Can't fail. */

select_sym = select_st->n.sym;
@@ -5263,7 +5263,7 @@ cleanup:
match
gfc_match_block_data (void)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_symbol *sym;
match m;

@@ -5277,7 +5277,7 @@ gfc_match_block_data (void)
return MATCH_YES;
}

- m = gfc_match ("% %n%t", name);
+ m = gfc_match ("% %n%t", &name);
if (m != MATCH_YES)
return MATCH_ERROR;

@@ -6095,7 +6095,7 @@ select_intrinsic_set_tmp (gfc_typespec *ts)
static void
select_type_set_tmp (gfc_typespec *ts)
{
- char name[GFC_MAX_SYMBOL_LEN];
+ const char *name = NULL;
gfc_symtree *tmp = NULL;

if (!ts)
@@ -6112,9 +6112,9 @@ select_type_set_tmp (gfc_typespec *ts)
return;

if (ts->type == BT_CLASS)
- sprintf (name, "__tmp_class_%s", ts->u.derived->name);
+ name = gfc_get_string ("__tmp_class_%s", ts->u.derived->name);
else
- sprintf (name, "__tmp_type_%s", ts->u.derived->name);
+ name = gfc_get_string ("__tmp_type_%s", ts->u.derived->name);
gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
gfc_add_type (tmp->n.sym, ts, NULL);

@@ -6163,7 +6163,7 @@ gfc_match_select_type (void)
{
gfc_expr *expr1, *expr2 = NULL;
match m;
- char name[GFC_MAX_SYMBOL_LEN];
+ const char *name = NULL;
bool class_array;
gfc_symbol *sym;
gfc_namespace *ns = gfc_current_ns;
@@ -6177,7 +6177,7 @@ gfc_match_select_type (void)
return m;

gfc_current_ns = gfc_build_block_ns (ns);
- m = gfc_match (" %n => %e", name, &expr2);
+ m = gfc_match (" %n => %e", &name, &expr2);
if (m == MATCH_YES)
{
expr1 = gfc_get_expr ();
diff --git a/gcc/fortran/matchexp.c b/gcc/fortran/matchexp.c
index bb01af9f636..6e82f5c3ca5 100644
--- a/gcc/fortran/matchexp.c
+++ b/gcc/fortran/matchexp.c
@@ -44,14 +44,14 @@ gfc_match_defined_op_name (const char *&result, int error_flag,
NULL
};

- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
locus old_loc;
match m;
int i;

old_loc = gfc_current_locus;

- m = gfc_match (" . %n .", name);
+ m = gfc_match (" . %n .", &name);
if (m != MATCH_YES)
return m;

diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 1064f3c80cb..8628f3aeda9 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -519,7 +519,7 @@ free_rename (gfc_use_rename *list)
match
gfc_match_use (void)
{
- char module_nature[GFC_MAX_SYMBOL_LEN + 1];
+ const char *module_nature = NULL;
const char *name = NULL;
gfc_use_rename *tail = NULL, *new_use;
interface_type type, type2;
@@ -531,7 +531,7 @@ gfc_match_use (void)

if (gfc_match (" , ") == MATCH_YES)
{
- if ((m = gfc_match (" %n ::", module_nature)) == MATCH_YES)
+ if ((m = gfc_match (" %n ::", &module_nature)) == MATCH_YES)
{
if (!gfc_notify_std (GFC_STD_F2003, "module "
"nature in USE statement at %C"))
@@ -555,7 +555,7 @@ gfc_match_use (void)
{
/* Help output a better error message than "Unclassifiable
statement". */
- gfc_match (" %n", module_nature);
+ gfc_match (" %n", &module_nature);
if (strcmp (module_nature, "intrinsic") == 0
|| strcmp (module_nature, "non_intrinsic") == 0)
gfc_error ("\"::\" was expected after module nature at %C "
@@ -738,7 +738,7 @@ match
gfc_match_submodule (void)
{
match m;
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
gfc_use_list *use_list;
bool seen_colon = false;

@@ -760,7 +760,7 @@ gfc_match_submodule (void)

while (1)
{
- m = gfc_match (" %n", name);
+ m = gfc_match (" %n", &name);
if (m != MATCH_YES)
goto syntax;

@@ -781,7 +781,7 @@ gfc_match_submodule (void)
else
{
module_list = use_list;
- use_list->module_name = gfc_get_string ("%s", name);
+ use_list->module_name = name;
use_list->submodule_name = use_list->module_name;
}

diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index 10a5df92e61..08bc05cbc28 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -94,7 +94,6 @@ gfc_free_omp_clauses (gfc_omp_clauses *c)
gfc_free_omp_namelist (c->lists[i]);
gfc_free_expr_list (c->wait_list);
gfc_free_expr_list (c->tile_list);
- free (CONST_CAST (char *, c->critical_name));
free (c);
}

@@ -226,7 +225,7 @@ gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
{
gfc_omp_namelist *head, *tail, *p;
locus old_loc, cur_loc;
- char n[GFC_MAX_SYMBOL_LEN+1];
+ const char *name = NULL;
gfc_symbol *sym;
match m;
gfc_symtree *st;
@@ -284,16 +283,16 @@ gfc_match_omp_variable_list (const char *str, gfc_omp_namelist **list,
if (!allow_common)
goto syntax;

- m = gfc_match (" / %n /", n);
+ m = gfc_match (" / %n /", &name);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto syntax;

- st = gfc_find_symtree (gfc_current_ns->common_root, n);
+ st = gfc_find_symtree (gfc_current_ns->common_root, name);
if (st == NULL)
{
- gfc_error ("COMMON block /%s/ not found at %C", n);
+ gfc_error ("COMMON block /%s/ not found at %C", name);
goto cleanup;
}
for (sym = st->n.common->head; sym; sym = sym->common_next)
@@ -348,7 +347,7 @@ gfc_match_omp_to_link (const char *str, gfc_omp_namelist **list)
{
gfc_omp_namelist *head, *tail, *p;
locus old_loc, cur_loc;
- char n[GFC_MAX_SYMBOL_LEN+1];
+ const char *name = NULL;
gfc_symbol *sym;
match m;
gfc_symtree *st;
@@ -385,16 +384,16 @@ gfc_match_omp_to_link (const char *str, gfc_omp_namelist **list)
goto cleanup;
}

- m = gfc_match (" / %n /", n);
+ m = gfc_match (" / %n /", &name);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto syntax;

- st = gfc_find_symtree (gfc_current_ns->common_root, n);
+ st = gfc_find_symtree (gfc_current_ns->common_root, name);
if (st == NULL)
{
- gfc_error ("COMMON block /%s/ not found at %C", n);
+ gfc_error ("COMMON block /%s/ not found at %C", name);
goto cleanup;
}
p = gfc_get_omp_namelist ();
@@ -636,7 +635,7 @@ gfc_match_oacc_clause_link (const char *str, gfc_omp_namelist **list)
gfc_omp_namelist *head = NULL;
gfc_omp_namelist *tail, *p;
locus old_loc;
- char n[GFC_MAX_SYMBOL_LEN+1];
+ const char *name = NULL;
gfc_symbol *sym;
match m;
gfc_symtree *st;
@@ -680,16 +679,16 @@ gfc_match_oacc_clause_link (const char *str, gfc_omp_namelist **list)
goto cleanup;
}

- m = gfc_match (" / %n /", n);
+ m = gfc_match (" / %n /", &name);
if (m == MATCH_ERROR)
goto cleanup;
- if (m == MATCH_NO || n[0] == '\0')
+ if (m == MATCH_NO)
goto syntax;

- st = gfc_find_symtree (gfc_current_ns->common_root, n);
+ st = gfc_find_symtree (gfc_current_ns->common_root, name);
if (st == NULL)
{
- gfc_error ("COMMON block /%s/ not found at %C", n);
+ gfc_error ("COMMON block /%s/ not found at %C", name);
goto cleanup;
}

@@ -2451,12 +2450,11 @@ match_omp (gfc_exec_op op, const omp_mask mask)
match
gfc_match_omp_critical (void)
{
- char n[GFC_MAX_SYMBOL_LEN+1];
+ const char *name = NULL;
gfc_omp_clauses *c = NULL;

- if (gfc_match (" ( %n )", n) != MATCH_YES)
+ if (gfc_match (" ( %n )", &name) != MATCH_YES)
{
- n[0] = '\0';
if (gfc_match_omp_eos () != MATCH_YES)
{
gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
@@ -2468,8 +2466,8 @@ gfc_match_omp_critical (void)

new_st.op = EXEC_OMP_CRITICAL;
new_st.ext.omp_clauses = c;
- if (n[0])
- c->critical_name = xstrdup (n);
+ if (name != NULL)
+ c->critical_name = name;
return MATCH_YES;
}

@@ -2477,10 +2475,9 @@ gfc_match_omp_critical (void)
match
gfc_match_omp_end_critical (void)
{
- char n[GFC_MAX_SYMBOL_LEN+1];
+ const char *name = NULL;

- if (gfc_match (" ( %n )", n) != MATCH_YES)
- n[0] = '\0';
+ gfc_match (" ( %n )", &name);
if (gfc_match_omp_eos () != MATCH_YES)
{
gfc_error ("Unexpected junk after $OMP CRITICAL statement at %C");
@@ -2488,7 +2485,7 @@ gfc_match_omp_end_critical (void)
}

new_st.op = EXEC_OMP_END_CRITICAL;
- new_st.ext.omp_name = n[0] ? xstrdup (n) : NULL;
+ new_st.ext.omp_name = name;
return MATCH_YES;
}

@@ -2601,7 +2598,7 @@ match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
{
match m;
locus old_loc = gfc_current_locus;
- char sname[GFC_MAX_SYMBOL_LEN + 1];
+ const char *sname = NULL;
gfc_symbol *sym;
gfc_namespace *ns = gfc_current_ns;
gfc_expr *lvalue = NULL, *rvalue = NULL;
@@ -2627,7 +2624,7 @@ match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
gfc_free_expr (lvalue);
}

- m = gfc_match (" %n", sname);
+ m = gfc_match (" %n", &sname);
if (m != MATCH_YES)
return false;

@@ -2799,8 +2796,7 @@ gfc_match_omp_declare_reduction (void)
{
match m;
gfc_intrinsic_op op;
- char name[GFC_MAX_SYMBOL_LEN + 3];
- const char *oper = NULL;
+ const char *name = NULL;
auto_vec<gfc_typespec, 5> tss;
gfc_typespec ts;
unsigned int i;
@@ -2818,24 +2814,22 @@ gfc_match_omp_declare_reduction (void)
return MATCH_ERROR;
if (m == MATCH_YES)
{
- oper = gfc_get_string ("operator %s", gfc_op2string (op));
- strcpy (name, oper);
+ name = gfc_get_string ("operator %s", gfc_op2string (op));
rop = (gfc_omp_reduction_op) op;
}
else
{
- m = gfc_match_defined_op_name (oper, 1, 1);
+ m = gfc_match_defined_op_name (name, 1, 1);
if (m == MATCH_ERROR)
return MATCH_ERROR;
if (m == MATCH_YES)
{
if (gfc_match (" : ") != MATCH_YES)
return MATCH_ERROR;
- strcpy (name, oper);
}
else
{
- if (gfc_match (" %n : ", name) != MATCH_YES)
+ if (gfc_match (" %n : ", &name) != MATCH_YES)
return MATCH_ERROR;
}
rop = OMP_REDUCTION_USER;
@@ -2869,7 +2863,7 @@ gfc_match_omp_declare_reduction (void)
const char *predef_name = NULL;

omp_udr = gfc_get_omp_udr ();
- omp_udr->name = gfc_get_string ("%s", name);
+ omp_udr->name = name;
omp_udr->rop = rop;
omp_udr->ts = tss[i];
omp_udr->where = where;
@@ -3132,7 +3126,7 @@ match
gfc_match_omp_threadprivate (void)
{
locus old_loc;
- char n[GFC_MAX_SYMBOL_LEN+1];
+ const char *name = NULL;
gfc_symbol *sym;
match m;
gfc_symtree *st;
@@ -3161,16 +3155,16 @@ gfc_match_omp_threadprivate (void)
goto cleanup;
}

- m = gfc_match (" / %n /", n);
+ m = gfc_match (" / %n /", &name);
if (m == MATCH_ERROR)
goto cleanup;
- if (m == MATCH_NO || n[0] == '\0')
+ if (m == MATCH_NO)
goto syntax;

- st = gfc_find_symtree (gfc_current_ns->common_root, n);
+ st = gfc_find_symtree (gfc_current_ns->common_root, name);
if (st == NULL)
{
- gfc_error ("COMMON block /%s/ not found at %C", n);
+ gfc_error ("COMMON block /%s/ not found at %C", name);
goto cleanup;
}
st->n.common->threadprivate = 1;
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 13cc6f5fccd..880671b57f4 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -3590,7 +3590,7 @@ match_deferred_characteristics (gfc_typespec * ts)
{
locus loc;
match m = MATCH_ERROR;
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;

loc = gfc_current_locus;

@@ -3616,7 +3616,7 @@ match_deferred_characteristics (gfc_typespec * ts)
/* Set the function locus correctly. If we have not found the
function name, there is an error. */
if (m == MATCH_YES
- && gfc_match ("function% %n", name) == MATCH_YES
+ && gfc_match ("function% %n", &name) == MATCH_YES
&& strcmp (name, gfc_current_block ()->name) == 0)
{
gfc_current_block ()->declared_at = gfc_current_locus;
@@ -5228,7 +5228,6 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
new_st.ext.omp_name) != 0))
gfc_error ("Name after !$omp critical and !$omp end critical does "
"not match at %C");
- free (CONST_CAST (char *, new_st.ext.omp_name));
new_st.ext.omp_name = NULL;
break;
case EXEC_OMP_END_SINGLE:
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index b30938ef61c..da661372c5c 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -1692,7 +1692,7 @@ cleanup:
static match
match_arg_list_function (gfc_actual_arglist *result)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name = NULL;
locus old_locus;
match m;

@@ -1704,7 +1704,7 @@ match_arg_list_function (gfc_actual_arglist *result)
goto cleanup;
}

- m = gfc_match ("%n (", name);
+ m = gfc_match ("%n (", &name);
if (m != MATCH_YES)
goto cleanup;

@@ -3144,7 +3144,7 @@ match
gfc_match_rvalue (gfc_expr **result)
{
gfc_actual_arglist *actual_arglist;
- char argname[GFC_MAX_SYMBOL_LEN + 1];
+ const char *argname = NULL;
const char *name = NULL;
gfc_state_data *st;
gfc_symbol *sym;
@@ -3526,7 +3526,7 @@ gfc_match_rvalue (gfc_expr **result)
symbol would end up in the symbol table. */

old_loc = gfc_current_locus;
- m2 = gfc_match (" ( %n =", argname);
+ m2 = gfc_match (" ( %n =", &argname);
gfc_current_locus = old_loc;

e = gfc_get_expr ();

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

This gets rid of some of the str[n]*cmp in favour of (faster) pointer
equality checks.

gcc/fortran/ChangeLog:

2017-11-02 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* check.c (gfc_check_move_alloc): Use pointer comparison instead
of strcmp.
* class.c (find_intrinsic_vtab): Likewise.
* decl.c (find_special, check_function_name, variable_decl,
insert_parameter_exprs, gfc_get_pdt_instance,
gfc_match_formal_arglist, match_result, add_hidden_procptr_result,
add_global_entry, gfc_match_end): Likewise.
* interface.c (gfc_match_end_interface, compare_components,
gfc_compare_derived_types, find_keyword_arg, count_types_test,
generic_correspondence, compare_actual_formal,
gfc_check_typebound_override): Likewise.
* match.c (gfc_match_else, gfc_match_elseif, match_case_eos,
gfc_match_elsewhere): Likewise.
* openmp.c (gfc_match_oacc_routine, match_udr_expr,
gfc_omp_udr_find): Likewise.
* parse.c (match_deferred_characteristics,
parse_omp_structured_block, add_global_procedure): Likewise.
* resolve.c (check_proc_interface, resolve_formal_arglist,
resolve_contained_fntype, resolve_common_blocks,
count_specific_procs, not_entry_self_reference,
resolve_global_procedure, resolve_select_type,
gfc_verify_binding_labels, build_init_assign, compare_fsyms,
resolve_typebound_procedure, resolve_component): Likewise.
* symbol.c (gfc_add_component, gfc_find_component): Likewise.
* trans-array.c (structure_alloc_comps): Likewise.
* trans-decl.c (gfc_get_extern_function_decl, build_entry_thunks,
gfc_get_fake_result_decl, struct module_hasher,
module_decl_hasher::equal, gfc_trans_use_stmts,
generate_local_decl): Likewise.
* trans-expr.c (conv_parent_component_references,
gfc_conv_procedure_call): Likewise.
* module.c (mio_namelist, find_symbol, load_omp_udrs,
read_module): Likewise.
---
gcc/fortran/check.c | 2 +-
gcc/fortran/class.c | 2 +-
gcc/fortran/decl.c | 31 +++++++++++++++---------------
gcc/fortran/interface.c | 34 ++++++++++++++++-----------------
gcc/fortran/match.c | 8 ++++----
gcc/fortran/module.c | 17 ++++++++---------
gcc/fortran/openmp.c | 7 +++----
gcc/fortran/parse.c | 10 ++++------
gcc/fortran/resolve.c | 40 +++++++++++++++++++--------------------
gcc/fortran/symbol.c | 6 +++---
gcc/fortran/trans-array.c | 4 ++--
gcc/fortran/trans-decl.c | 24 +++++++++++------------
gcc/fortran/trans-expr.c | 7 +++----
13 files changed, 91 insertions(+), 101 deletions(-)

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 30214fef4c7..cb18a3af519 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -3566,7 +3566,7 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
of reflection reveals that this can only occur for derived types
with recursive allocatable components. */
if (to->expr_type == EXPR_VARIABLE && from->expr_type == EXPR_VARIABLE
- && !strcmp (to->symtree->n.sym->name, from->symtree->n.sym->name))
+ && to->symtree->n.sym->name == from->symtree->n.sym->name)
{
gfc_ref *to_ref, *from_ref;
to_ref = to->ref;
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 2eae7f0f351..8e637689fae 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -2736,7 +2736,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
contained = ns->contained;
for (; contained; contained = contained->sibling)
if (contained->proc_name
- && strcmp (name, contained->proc_name->name) == 0)
+ && name == contained->proc_name->name)
{
copy = contained->proc_name;
goto got_char_copy;
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index b0c45b88505..2baa1783434 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -1118,7 +1118,7 @@ find_special (const char *name, gfc_symbol **result, bool allow_subroutine)
if (s->sym == NULL)
goto end; /* Nameless interface. */

- if (strcmp (name, s->sym->name) == 0)
+ if (name == s->sym->name)
{
*result = s->sym;
return 0;
@@ -2273,7 +2273,7 @@ check_function_name (const char *name)
gfc_symbol *block = gfc_current_block ();
if (block && block->result && block->result != block
&& strcmp (block->result->name, "ppr@") != 0
- && strcmp (block->name, name) == 0)
+ && block->name == name)
{
gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
"from appearing in a specification statement",
@@ -2583,11 +2583,11 @@ variable_decl (int elem)
/* Procedure pointer as function result. */
if (gfc_current_state () == COMP_FUNCTION
&& strcmp ("ppr@", gfc_current_block ()->name) == 0
- && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0)
+ && name == gfc_current_block ()->ns->proc_name->name)
name = gfc_get_string ("%s", "ppr@");

if (gfc_current_state () == COMP_FUNCTION
- && strcmp (name, gfc_current_block ()->name) == 0
+ && name == gfc_current_block ()->name
&& gfc_current_block ()->result
&& strcmp ("ppr@", gfc_current_block ()->result->name) == 0)
name = gfc_get_string ("%s", "ppr@");
@@ -3359,7 +3359,7 @@ insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
|| (*f != 0 && e->symtree->n.sym->attr.pdt_len))
{
for (param = type_param_spec_list; param; param = param->next)
- if (strcmp (e->symtree->n.sym->name, param->name) == 0)
+ if (e->symtree->n.sym->name == param->name)
break;

if (param)
@@ -3483,7 +3483,7 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
actual_param = param_list;
for (;actual_param; actual_param = actual_param->next)
if (actual_param->name
- && strcmp (actual_param->name, param->name) == 0)
+ && actual_param->name == param->name)
break;
if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
kind_expr = gfc_copy_expr (actual_param->expr);
@@ -6215,7 +6215,7 @@ gfc_match_formal_arglist (gfc_symbol *progname, int st_flag,
so check for it explicitly. After the statement is accepted,
the name is checked for especially in gfc_get_symbol(). */
if (gfc_new_block != NULL && sym != NULL && !typeparam
- && strcmp (sym->name, gfc_new_block->name) == 0)
+ && sym->name == gfc_new_block->name)
{
gfc_error ("Name %qs at %C is the name of the procedure",
sym->name);
@@ -6290,7 +6290,7 @@ ok:
|| (p->next == NULL && q->next != NULL))
arg_count_mismatch = true;
else if ((p->sym == NULL && q->sym == NULL)
- || strcmp (p->sym->name, q->sym->name) == 0)
+ || p->sym->name == q->sym->name)
continue;
else
gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
@@ -6336,7 +6336,7 @@ match_result (gfc_symbol *function, gfc_symbol **result)
return MATCH_ERROR;
}

- if (strcmp (function->name, name) == 0)
+ if (function->name == name)
{
gfc_error ("RESULT variable at %C must be different than function name");
return MATCH_ERROR;
@@ -6451,12 +6451,12 @@ add_hidden_procptr_result (gfc_symbol *sym)

/* First usage case: PROCEDURE and EXTERNAL statements. */
case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block ()
- && strcmp (gfc_current_block ()->name, sym->name) == 0
+ && gfc_current_block ()->name == sym->name
&& sym->attr.external;
/* Second usage case: INTERFACE statements. */
case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous
&& gfc_state_stack->previous->state == COMP_FUNCTION
- && strcmp (gfc_state_stack->previous->sym->name, sym->name) == 0;
+ && gfc_state_stack->previous->sym->name == sym->name;

if (case1 || case2)
{
@@ -7148,7 +7148,7 @@ add_global_entry (const char *name, const char *binding_label, bool sub,
/* Don't add the symbol multiple times. */
if (binding_label
&& (!gfc_notification_std (GFC_STD_F2008)
- || strcmp (name, binding_label) != 0))
+ || name != binding_label))
{
s = gfc_get_gsymbol (binding_label);

@@ -8044,9 +8044,8 @@ gfc_match_end (gfc_statement *st)
/* We have to pick out the declared submodule name from the composite
required by F2008:11.2.3 para 2, which ends in the declared name. */
if (state == COMP_SUBMODULE)
- block_name = strchr (block_name, '.') + 1;
-
- if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0)
+ block_name = gfc_get_string ("%s", strchr (block_name, '.') + 1);
+ if (name != block_name && strcmp (block_name, "ppr@") != 0)
{
gfc_error ("Expected label %qs for %s statement at %C", block_name,
gfc_ascii_statement (*st));
@@ -8054,7 +8053,7 @@ gfc_match_end (gfc_statement *st)
}
/* Procedure pointer as function result. */
else if (strcmp (block_name, "ppr@") == 0
- && strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0)
+ && name != gfc_current_block ()->ns->proc_name->name)
{
gfc_error ("Expected label %qs for %s statement at %C",
gfc_current_block ()->ns->proc_name->name,
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 8716813b7b2..d18590da331 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -411,7 +411,7 @@ gfc_match_end_interface (void)
/* Comparing the symbol node names is OK because only use-associated
symbols can be renamed. */
if (type != current_interface.type
- || strcmp (current_interface.uop->name, name) != 0)
+ || current_interface.uop->name != name)
{
gfc_error ("Expecting %<END INTERFACE OPERATOR (.%s.)%> at %C",
current_interface.uop->name);
@@ -423,7 +423,7 @@ gfc_match_end_interface (void)
case INTERFACE_DTIO:
case INTERFACE_GENERIC:
if (type != current_interface.type
- || strcmp (current_interface.sym->name, name) != 0)
+ || current_interface.sym->name != name)
{
gfc_error ("Expecting %<END INTERFACE %s%> at %C",
current_interface.sym->name);
@@ -476,7 +476,7 @@ compare_components (gfc_component *cmp1, gfc_component *cmp2,
{
/* Compare names, but not for anonymous components such as UNION or MAP. */
if (!is_anonymous_component (cmp1) && !is_anonymous_component (cmp2)
- && strcmp (cmp1->name, cmp2->name) != 0)
+ && cmp1->name != cmp2->name)
return false;

if (cmp1->attr.access != cmp2->attr.access)
@@ -624,9 +624,9 @@ gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
/* Special case for comparing derived types across namespaces. If the
true names and module names are the same and the module name is
nonnull, then they are equal. */
- if (strcmp (derived1->name, derived2->name) == 0
+ if (derived1->name == derived2->name
&& derived1->module != NULL && derived2->module != NULL
- && strcmp (derived1->module, derived2->module) == 0)
+ && derived1->module == derived2->module)
return true;

/* Compare type via the rules of the standard. Both types must have
@@ -636,7 +636,7 @@ gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)

/* Compare names, but not for anonymous types such as UNION or MAP. */
if (!is_anonymous_dt (derived1) && !is_anonymous_dt (derived2)
- && strcmp (derived1->name, derived2->name) != 0)
+ && derived1->name != derived2->name)
return false;

if (derived1->component_access == ACCESS_PRIVATE
@@ -839,7 +839,7 @@ static gfc_symbol *
find_keyword_arg (const char *name, gfc_formal_arglist *f)
{
for (; f; f = f->next)
- if (strcmp (f->sym->name, name) == 0)
+ if (f->sym->name == name)
return f->sym;

return NULL;
@@ -1140,7 +1140,7 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
continue;

if (arg[i].sym && (arg[i].sym->attr.optional
- || (p1 && strcmp (arg[i].sym->name, p1) == 0)))
+ || (p1 && arg[i].sym->name == p1)))
continue; /* Skip OPTIONAL and PASS arguments. */

arg[i].flag = k;
@@ -1149,7 +1149,7 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
for (j = i + 1; j < n1; j++)
if ((arg[j].sym == NULL
|| !(arg[j].sym->attr.optional
- || (p1 && strcmp (arg[j].sym->name, p1) == 0)))
+ || (p1 && arg[j].sym->name == p1)))
&& (compare_type_rank_if (arg[i].sym, arg[j].sym)
|| compare_type_rank_if (arg[j].sym, arg[i].sym)))
arg[j].flag = k;
@@ -1176,7 +1176,7 @@ count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
ac2 = 0;

for (f = f2; f; f = f->next)
- if ((!p2 || strcmp (f->sym->name, p2) != 0)
+ if ((!p2 || f->sym->name != p2)
&& (compare_type_rank_if (arg[i].sym, f->sym)
|| compare_type_rank_if (f->sym, arg[i].sym)))
ac2++;
@@ -1249,9 +1249,9 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
if (f1->sym->attr.optional)
goto next;

- if (p1 && strcmp (f1->sym->name, p1) == 0)
+ if (p1 && f1->sym->name == p1)
f1 = f1->next;
- if (f2 && p2 && strcmp (f2->sym->name, p2) == 0)
+ if (f2 && p2 && f2->sym->name == p2)
f2 = f2->next;

if (f2 != NULL && (compare_type_rank (f1->sym, f2->sym)
@@ -1265,7 +1265,7 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
the current non-match. */
for (g = f1; g; g = g->next)
{
- if (g->sym->attr.optional || (p1 && strcmp (g->sym->name, p1) == 0))
+ if (g->sym->attr.optional || (p1 && g->sym->name == p1))
continue;

sym = find_keyword_arg (g->sym->name, f2_save);
@@ -2914,7 +2914,7 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
{
if (f->sym == NULL)
continue;
- if (strcmp (f->sym->name, a->name) == 0)
+ if (f->sym->name == a->name)
break;
}

@@ -4644,14 +4644,14 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
proc_formal = proc_formal->next, old_formal = old_formal->next)
{
if (proc->n.tb->pass_arg
- && !strcmp (proc->n.tb->pass_arg, proc_formal->sym->name))
+ && proc->n.tb->pass_arg == proc_formal->sym->name)
proc_pass_arg = argpos;
if (old->n.tb->pass_arg
- && !strcmp (old->n.tb->pass_arg, old_formal->sym->name))
+ && old->n.tb->pass_arg == old_formal->sym->name)
old_pass_arg = argpos;

/* Check that the names correspond. */
- if (strcmp (proc_formal->sym->name, old_formal->sym->name))
+ if (proc_formal->sym->name != old_formal->sym->name)
{
gfc_error ("Dummy argument %qs of %qs at %L should be named %qs as"
" to match the corresponding argument of the overridden"
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 6596bd87c09..f27249ec6ed 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1716,7 +1716,7 @@ gfc_match_else (void)
return MATCH_ERROR;
}

- if (strcmp (name, gfc_current_block ()->name) != 0)
+ if (name != gfc_current_block ()->name)
{
gfc_error ("Label %qs at %C doesn't match IF label %qs",
name, gfc_current_block ()->name);
@@ -1751,7 +1751,7 @@ gfc_match_elseif (void)
goto cleanup;
}

- if (strcmp (name, gfc_current_block ()->name) != 0)
+ if (name != gfc_current_block ()->name)
{
gfc_error ("Label %qs at %C doesn't match IF label %qs",
name, gfc_current_block ()->name);
@@ -5914,7 +5914,7 @@ match_case_eos (void)
if (m != MATCH_YES)
return m;

- if (strcmp (name, gfc_current_block ()->name) != 0)
+ if (name != gfc_current_block ()->name)
{
gfc_error ("Expected block name %qs of SELECT construct at %C",
gfc_current_block ()->name);
@@ -6640,7 +6640,7 @@ gfc_match_elsewhere (void)
if (gfc_match_eos () != MATCH_YES)
goto syntax;

- if (strcmp (name, gfc_current_block ()->name) != 0)
+ if (name != gfc_current_block ()->name)
{
gfc_error ("Label %qs at %C doesn't match WHERE label %qs",
name, gfc_current_block ()->name);
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 3ad47f57930..fe5ae34dd13 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -3689,7 +3689,7 @@ mio_namelist (gfc_symbol *sym)
if (sym->attr.flavor == FL_NAMELIST)
{
check_name = find_use_name (sym->name, false);
- if (check_name && strcmp (check_name, sym->name) != 0)
+ if (check_name && check_name != sym->name)
gfc_error ("Namelist %s cannot be renamed by USE "
"association to %s", sym->name, check_name);
}
@@ -4379,16 +4379,15 @@ static gfc_symtree *
find_symbol (gfc_symtree *st, const char *name,
const char *module, int generic)
{
- int c;
gfc_symtree *retval, *s;

if (st == NULL || st->n.sym == NULL)
return NULL;

- c = strcmp (name, st->n.sym->name);
- if (c == 0 && st->n.sym->module
- && strcmp (module, st->n.sym->module) == 0
- && !check_unique_name (st->name))
+ if (name == st->n.sym->name
+ && st->n.sym->module
+ && module == st->n.sym->module
+ && !check_unique_name (st->name))
{
s = gfc_find_symtree (gfc_current_ns->sym_root, name);

@@ -4804,7 +4803,7 @@ load_omp_udrs (void)
{
require_atom (ATOM_INTEGER);
pointer_info *p = get_integer (atom_int);
- if (strcmp (p->u.rsym.module, udr->omp_out->module))
+ if (p->u.rsym.module != udr->omp_out->module)
{
gfc_error ("Ambiguous !$OMP DECLARE REDUCTION from "
"module %s at %L",
@@ -5203,9 +5202,9 @@ read_module (void)
{
st = gfc_find_symtree (gfc_current_ns->sym_root, name);
if (st != NULL
- && strcmp (st->n.sym->name, info->u.rsym.true_name) == 0
+ && st->n.sym->name == info->u.rsym.true_name
&& st->n.sym->module != NULL
- && strcmp (st->n.sym->module, info->u.rsym.module) == 0)
+ && st->n.sym->module == info->u.rsym.module)
{
info->u.rsym.symtree = st;
info->u.rsym.sym = st->n.sym;
diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index 08bc05cbc28..a868e34193f 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -2297,7 +2297,7 @@ gfc_match_oacc_routine (void)
{
sym = st->n.sym;
if (gfc_current_ns->proc_name != NULL
- && strcmp (sym->name, gfc_current_ns->proc_name->name) == 0)
+ && sym->name == gfc_current_ns->proc_name->name)
sym = NULL;
}

@@ -2628,8 +2628,7 @@ match_udr_expr (gfc_symtree *omp_sym1, gfc_symtree *omp_sym2)
if (m != MATCH_YES)
return false;

- if (strcmp (sname, omp_sym1->name) == 0
- || strcmp (sname, omp_sym2->name) == 0)
+ if (sname == omp_sym1->name || sname == omp_sym2->name)
return false;

gfc_current_ns = ns->parent;
@@ -2763,7 +2762,7 @@ gfc_omp_udr_find (gfc_symtree *st, gfc_typespec *ts)
{
if (omp_udr->ts.type == BT_DERIVED || omp_udr->ts.type == BT_CLASS)
{
- if (strcmp (omp_udr->ts.u.derived->name, ts->u.derived->name) == 0)
+ if (omp_udr->ts.u.derived->name == ts->u.derived->name)
return omp_udr;
}
else if (omp_udr->ts.kind == ts->kind)
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 880671b57f4..389eead0691 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -3569,8 +3569,7 @@ decl:

if (current_interface.ns
&& current_interface.ns->proc_name
- && strcmp (current_interface.ns->proc_name->name,
- prog_unit->name) == 0)
+ && current_interface.ns->proc_name->name == prog_unit->name)
gfc_error ("INTERFACE procedure %qs at %L has the same name as the "
"enclosing procedure", prog_unit->name,
&current_interface.ns->proc_name->declared_at);
@@ -3617,7 +3616,7 @@ match_deferred_characteristics (gfc_typespec * ts)
function name, there is an error. */
if (m == MATCH_YES
&& gfc_match ("function% %n", &name) == MATCH_YES
- && strcmp (name, gfc_current_block ()->name) == 0)
+ && name == gfc_current_block ()->name)
{
gfc_current_block ()->declared_at = gfc_current_locus;
gfc_commit_symbols ();
@@ -5224,8 +5223,7 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
case EXEC_OMP_END_CRITICAL:
if (((cp->ext.omp_clauses == NULL) ^ (new_st.ext.omp_name == NULL))
|| (new_st.ext.omp_name != NULL
- && strcmp (cp->ext.omp_clauses->critical_name,
- new_st.ext.omp_name) != 0))
+ && cp->ext.omp_clauses->critical_name != new_st.ext.omp_name))
gfc_error ("Name after !$omp critical and !$omp end critical does "
"not match at %C");
new_st.ext.omp_name = NULL;
@@ -5998,7 +5996,7 @@ add_global_procedure (bool sub)
/* Don't add the symbol multiple times. */
if (gfc_new_block->binding_label
&& (!gfc_notification_std (GFC_STD_F2008)
- || strcmp (gfc_new_block->name, gfc_new_block->binding_label) != 0))
+ || gfc_new_block->name != gfc_new_block->binding_label))
{
s = gfc_get_gsymbol (gfc_new_block->binding_label);

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index ded27624283..afb745bddc5 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -149,7 +149,7 @@ check_proc_interface (gfc_symbol *ifc, locus *where)
/* For generic interfaces, check if there is
a specific procedure with the same name. */
gfc_interface *gen = ifc->generic;
- while (gen && strcmp (gen->sym->name, ifc->name) != 0)
+ while (gen && gen->sym->name != ifc->name)
gen = gen->next;
if (!gen)
{
@@ -310,7 +310,7 @@ resolve_formal_arglist (gfc_symbol *proc)
&& !resolve_procedure_interface (sym))
return;

- if (strcmp (proc->name, sym->name) == 0)
+ if (proc->name == sym->name)
{
gfc_error ("Self-referential argument "
"%qs at %L is not allowed", sym->name,
@@ -573,7 +573,7 @@ resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns)
&& sym->ns->parent
&& sym->ns->parent->proc_name
&& sym->ns->parent->proc_name->attr.flavor == FL_PROCEDURE
- && !strcmp (sym->name, sym->ns->parent->proc_name->name))
+ && sym->name == sym->ns->parent->proc_name->name)
gfc_error ("Contained procedure %qs at %L has the same name as its "
"encompassing procedure", sym->name, &sym->declared_at);

@@ -1015,8 +1015,8 @@ resolve_common_blocks (gfc_symtree *common_root)
&& gsym->type == GSYM_COMMON
&& ((common_root->n.common->binding_label
&& (!gsym->binding_label
- || strcmp (common_root->n.common->binding_label,
- gsym->binding_label) != 0))
+ || common_root->n.common->binding_label !=
+ gsym->binding_label))
|| (!common_root->n.common->binding_label
&& gsym->binding_label)))
{
@@ -1650,7 +1650,7 @@ count_specific_procs (gfc_expr *e)
sym = e->symtree->n.sym;

for (p = sym->generic; p; p = p->next)
- if (strcmp (sym->name, p->sym->name) == 0)
+ if (sym->name == p->sym->name)
{
e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
sym->name);
@@ -2337,15 +2337,14 @@ not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns)

for (; entry; entry = entry->next)
{
- if (strcmp (sym->name, entry->sym->name) == 0)
+ if (sym->name == entry->sym->name)
{
- if (strcmp (gsym_ns->proc_name->name,
- sym->ns->proc_name->name) == 0)
+ if (gsym_ns->proc_name->name == sym->ns->proc_name->name)
return false;

if (sym->ns->parent
- && strcmp (gsym_ns->proc_name->name,
- sym->ns->parent->proc_name->name) == 0)
+ && gsym_ns->proc_name->name ==
+ sym->ns->parent->proc_name->name)
return false;
}
}
@@ -2550,7 +2549,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
{
gfc_entry_list *entry;
for (entry = gsym->ns->entries; entry; entry = entry->next)
- if (strcmp (entry->sym->name, sym->name) == 0)
+ if (entry->sym->name == sym->name)
{
def_sym = entry->sym;
break;
@@ -8912,8 +8911,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
if (c->ts.type == d->ts.type
&& ((c->ts.type == BT_DERIVED
&& c->ts.u.derived && d->ts.u.derived
- && !strcmp (c->ts.u.derived->name,
- d->ts.u.derived->name))
+ && c->ts.u.derived->name == d->ts.u.derived->name)
|| c->ts.type == BT_UNKNOWN
|| (!(c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
&& c->ts.kind == d->ts.kind)))
@@ -11733,7 +11731,7 @@ gfc_verify_binding_labels (gfc_symbol *sym)
}
else if (sym->attr.flavor == FL_VARIABLE && module
&& (strcmp (module, gsym->mod_name) != 0
- || strcmp (sym->name, gsym->sym_name) != 0))
+ || sym->name != gsym->sym_name))
{
/* This can only happen if the variable is defined in a module - if it
isn't the same module, reject it. */
@@ -11748,7 +11746,7 @@ gfc_verify_binding_labels (gfc_symbol *sym)
|| (gsym->defined && sym->attr.if_source != IFSRC_IFBODY))
&& sym != gsym->ns->proc_name
&& (module != gsym->mod_name
- || strcmp (gsym->sym_name, sym->name) != 0
+ || gsym->sym_name != sym->name
|| (module && strcmp (module, gsym->mod_name) != 0)))
{
/* Print an error if the procedure is defined multiple times; we have to
@@ -11895,7 +11893,7 @@ build_init_assign (gfc_symbol *sym, gfc_expr *init)
{
ns = ns->contained;
for (;ns; ns = ns->sibling)
- if (strcmp (ns->proc_name->name, sym->name) == 0)
+ if (ns->proc_name->name == sym->name)
break;
}

@@ -12388,7 +12386,7 @@ compare_fsyms (gfc_symbol *sym)
if (sym == fsym)
return;

- if (strcmp (sym->name, fsym->name) == 0)
+ if (sym->name == fsym->name)
{
if (!gfc_check_dummy_characteristics (fsym, sym, true, errmsg, 200))
gfc_error ("%s at %L", errmsg, &fsym->declared_at);
@@ -13382,7 +13380,7 @@ resolve_typebound_procedure (gfc_symtree* stree)
stree->n.tb->pass_arg_num = 1;
for (i = dummy_args; i; i = i->next)
{
- if (!strcmp (i->sym->name, stree->n.tb->pass_arg))
+ if (i->sym->name == stree->n.tb->pass_arg)
{
me_arg = i->sym;
break;
@@ -13812,7 +13810,7 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
c->tb->pass_arg_num = 1;
for (i = c->ts.interface->formal; i; i = i->next)
{
- if (!strcmp (i->sym->name, c->tb->pass_arg))
+ if (i->sym->name == c->tb->pass_arg)
{
me_arg = i->sym;
break;
@@ -13914,7 +13912,7 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
&& ((sym->attr.is_class
&& c == sym->components->ts.u.derived->components)
|| (!sym->attr.is_class && c == sym->components))
- && strcmp (super_type->name, c->name) == 0)
+ && super_type->name == c->name)
c->attr.access = super_type->attr.access;

/* If this type is an extension, see if this component has the same name
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index e576bc1cb69..00a178772df 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -2239,7 +2239,7 @@ gfc_add_component (gfc_symbol *sym, const char *name,

for (p = sym->components; p; p = p->next)
{
- if (strcmp (p->name, name) == 0)
+ if (p->name == name)
{
gfc_error ("Component %qs at %C already declared at %L",
name, &p->loc);
@@ -2504,7 +2504,8 @@ gfc_find_component (gfc_symbol *sym, const char *name,
return check;
}
}
- else if (strcmp (p->name, name) == 0)
+ else if (p->name == name || strcmp (p->name, name) == 0)
+ /* FORNOW: name could be "_data" et al so fallback to strcmp. */
break;

continue;
@@ -2902,7 +2903,6 @@ compare_symtree (void *_st1, void *_st2)

st1 = (gfc_symtree *) _st1;
st2 = (gfc_symtree *) _st2;
-
return strcmp (st1->name, st2->name);
}

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index adb2c0575a8..78132908929 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -9024,7 +9024,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
gfc_actual_arglist *param = pdt_param_list;
gfc_init_se (&tse, NULL);
for (; param; param = param->next)
- if (param->name && !strcmp (c->name, param->name))
+ if (param->name && c->name == param->name)
c_expr = param->expr;

if (!c_expr)
@@ -9266,7 +9266,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,

gfc_init_se (&tse, NULL);
for (; param; param = param->next)
- if (!strcmp (c->name, param->name)
+ if (c->name == param->name
&& param->spec_type == SPEC_EXPLICIT)
c_expr = param->expr;

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index e2adfa2e2db..6e717633a8f 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -1994,7 +1994,7 @@ gfc_get_extern_function_decl (gfc_symbol * sym)

for (; entry; entry = entry->next)
{
- if (strcmp (gsym->name, entry->sym->name) == 0)
+ if (gsym->name == entry->sym->name)
{
sym->backend_decl = entry->sym->backend_decl;
break;
@@ -2787,9 +2787,10 @@ build_entry_thunks (gfc_namespace * ns, bool global)

for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
field; field = DECL_CHAIN (field))
- if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
- thunk_sym->result->name) == 0)
+ if (IDENTIFIER_POINTER (DECL_NAME (field)) ==
+ thunk_sym->result->name)
break;
+
gcc_assert (field != NULL_TREE);
tmp = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (field), union_decl, field,
@@ -2912,7 +2913,7 @@ gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
tree t = NULL, var;
if (this_fake_result_decl != NULL)
for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
- if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
+ if (IDENTIFIER_POINTER (TREE_PURPOSE (t)) == sym->name)
break;
if (t)
return TREE_VALUE (t);
@@ -2929,10 +2930,8 @@ gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)

for (field = TYPE_FIELDS (TREE_TYPE (decl));
field; field = DECL_CHAIN (field))
- if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
- sym->name) == 0)
+ if (IDENTIFIER_POINTER (DECL_NAME (field)) == sym->name)
break;
-
gcc_assert (field != NULL_TREE);
decl = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (field), decl, field, NULL_TREE);
@@ -4794,7 +4793,7 @@ struct module_hasher : ggc_ptr_hash<module_htab_entry>
static bool
equal (module_htab_entry *a, const char *b)
{
- return !strcmp (a->name, b);
+ return a->name == b;
}
};

@@ -4817,7 +4816,7 @@ module_decl_hasher::equal (tree t1, const char *x2)
const_tree n1 = DECL_NAME (t1);
if (n1 == NULL_TREE)
n1 = TYPE_NAME (TREE_TYPE (t1));
- return strcmp (IDENTIFIER_POINTER (n1), x2) == 0;
+ return IDENTIFIER_POINTER (n1) == x2;
}

struct module_htab_entry *
@@ -5071,7 +5070,7 @@ gfc_trans_use_stmts (gfc_namespace * ns)
if (st->n.sym->backend_decl
&& DECL_P (st->n.sym->backend_decl)
&& st->n.sym->module
- && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
+ && st->n.sym->module == use_stmt->module_name)
{
gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
|| !VAR_P (st->n.sym->backend_decl));
@@ -5084,8 +5083,7 @@ gfc_trans_use_stmts (gfc_namespace * ns)
else if (st->n.sym->attr.flavor == FL_NAMELIST
&& st->n.sym->attr.use_only
&& st->n.sym->module
- && strcmp (st->n.sym->module, use_stmt->module_name)
- == 0)
+ && st->n.sym->module == use_stmt->module_name)
{
decl = generate_namelist_decl (st->n.sym);
DECL_CONTEXT (decl) = entry->namespace_decl;
@@ -5613,7 +5611,7 @@ generate_local_decl (gfc_symbol * sym)
gfc_entry_list *el;

for (el = sym->ns->entries; el; el=el->next)
- if (strcmp(sym->name, el->sym->name) == 0)
+ if (sym->name == el->sym->name)
enter = true;

if (!enter)
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 56ce98c78c6..6c8a5b30568 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2490,7 +2490,7 @@ conv_parent_component_references (gfc_se * se, gfc_ref * ref)

/* Return if the component is in the parent type. */
for (cmp = dt->components; cmp; cmp = cmp->next)
- if (strcmp (c->name, cmp->name) == 0)
+ if (c->name == cmp->name)
return;

/* Build a gfc_ref to recursively call gfc_conv_component_ref. */
@@ -5199,8 +5199,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& fsym->ts.type == BT_CLASS
&& !CLASS_DATA (fsym)->as
&& !CLASS_DATA (e)->as
- && strcmp (fsym->ts.u.derived->name,
- e->ts.u.derived->name))
+ && fsym->ts.u.derived->name != e->ts.u.derived->name)
{
type = gfc_typenode_for_spec (&fsym->ts);
var = gfc_create_var (type, fsym->name);
@@ -6001,7 +6000,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
{
formal = gfc_sym_get_dummy_args (sym->ns->proc_name);
for (; formal; formal = formal->next)
- if (strcmp (formal->sym->name, sym->name) == 0)
+ if (formal->sym->name == sym->name)
cl.backend_decl = formal->sym->ts.u.cl->backend_decl;
}
len = cl.backend_decl;

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

gcc/fortran/ChangeLog:

2017-11-28 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* module.c (struct pointer_info): Change binding_label to const
pointer.
(free_pi_tree): Do not free binding_label.
(load_commons): Use stringpool for binding_label.
(load_needed): Likewise.
(read_module): Likewise.
---
gcc/fortran/module.c | 31 ++++++++++++-------------------
1 file changed, 12 insertions(+), 19 deletions(-)

diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 24e48c94c76..8f6dc9f2864 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -158,7 +158,8 @@ typedef struct pointer_info
struct
{
gfc_symbol *sym;
- char *true_name, *module, *binding_label;
+ const char *binding_label;
+ char *true_name, *module;
fixup_t *stfixup;
gfc_symtree *symtree;
enum gfc_rsym_state state;
@@ -242,7 +243,6 @@ free_pi_tree (pointer_info *p)
{
XDELETEVEC (p->u.rsym.true_name);
XDELETEVEC (p->u.rsym.module);
- XDELETEVEC (p->u.rsym.binding_label);
}

free (p);
@@ -4646,7 +4646,7 @@ load_commons (void)
while (peek_atom () != ATOM_RPAREN)
{
int flags;
- char* label;
+ const char* bind_label;
mio_lparen ();
mio_pool_string (&name);

@@ -4663,10 +4663,9 @@ load_commons (void)
/* Get whether this was a bind(c) common or not. */
mio_integer (&p->is_bind_c);
/* Get the binding label. */
- label = read_string ();
- if (strlen (label))
- p->binding_label = IDENTIFIER_POINTER (get_identifier (label));
- XDELETEVEC (label);
+ mio_pool_string (&bind_label);
+ if (bind_label)
+ p->binding_label = bind_label;

mio_rparen ();
}
@@ -4899,8 +4898,7 @@ load_needed (pointer_info *p)
sym->name = gfc_dt_lower_string (p->u.rsym.true_name);
sym->module = gfc_get_string ("%s", p->u.rsym.module);
if (p->u.rsym.binding_label)
- sym->binding_label = IDENTIFIER_POINTER (get_identifier
- (p->u.rsym.binding_label));
+ sym->binding_label = p->u.rsym.binding_label;

associate_integer_pointer (p, sym);
}
@@ -5052,7 +5050,7 @@ read_module (void)
pointer_info *info, *q;
gfc_use_rename *u = NULL;
gfc_symtree *st;
- gfc_symbol *sym;
+ gfc_symbol *sym = NULL;

get_module_locus (&operator_interfaces); /* Skip these for now. */
skip_list ();
@@ -5075,7 +5073,7 @@ read_module (void)

while (peek_atom () != ATOM_RPAREN)
{
- char* bind_label;
+ const char* bind_label;
require_atom (ATOM_INTEGER);
info = get_integer (atom_int);

@@ -5084,11 +5082,9 @@ read_module (void)

info->u.rsym.true_name = read_string ();
info->u.rsym.module = read_string ();
- bind_label = read_string ();
- if (strlen (bind_label))
+ mio_pool_string (&bind_label);
+ if (bind_label)
info->u.rsym.binding_label = bind_label;
- else
- XDELETEVEC (bind_label);

require_atom (ATOM_INTEGER);
info->u.rsym.ns = atom_int;
@@ -5265,10 +5261,7 @@ read_module (void)
sym->module = gfc_get_string ("%s", info->u.rsym.module);

if (info->u.rsym.binding_label)
- {
- tree id = get_identifier (info->u.rsym.binding_label);
- sym->binding_label = IDENTIFIER_POINTER (id);
- }
+ sym->binding_label = info->u.rsym.binding_label;
}

st->n.sym = sym;

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

gcc/fortran/ChangeLog:

2017-11-26 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* class.c (finalize_component): Use stringpool.
(finalization_scalarizer): Likewise.
* frontend-passes.c (create_var): Likewise.
(get_len_trim_call): Likewise.
* iresolve.c (gfc_resolve_atomic_def): Likewise.
(gfc_resolve_atomic_ref): Likewise.
(gfc_resolve_event_query): Likewise.
* openmp.c (gfc_match_omp_declare_reduction): Likewise.
* parse.c (gfc_parse_file): Likewise.
* resolve.c (build_loc_call): Likewise.
(resolve_ordinary_assign): Likewise.
* decl.c (add_hidden_procptr_result): Likewise and use pointer
comparison instead of string comparison.
---
gcc/fortran/class.c | 10 +++++++---
gcc/fortran/decl.c | 11 +++++++----
gcc/fortran/frontend-passes.c | 10 ++++++----
gcc/fortran/iresolve.c | 6 +++---
gcc/fortran/openmp.c | 13 +++++++++----
gcc/fortran/parse.c | 2 +-
gcc/fortran/resolve.c | 6 ++++--
7 files changed, 37 insertions(+), 21 deletions(-)

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 20a68da8e9b..33c772c6eba 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -959,12 +959,13 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp,
dealloc->ext.alloc.list->expr = e;
dealloc->expr1 = gfc_lval_expr_from_sym (stat);

+ const char *sname = gfc_get_string ("%s", "associated");
gfc_code *cond = gfc_get_code (EXEC_IF);
cond->block = gfc_get_code (EXEC_IF);
cond->block->expr1 = gfc_get_expr ();
cond->block->expr1->expr_type = EXPR_FUNCTION;
cond->block->expr1->where = gfc_current_locus;
- gfc_get_sym_tree ("associated", sub_ns, &cond->block->expr1->symtree, false);
+ gfc_get_sym_tree (sname, sub_ns, &cond->block->expr1->symtree, false);
cond->block->expr1->symtree->n.sym->attr.flavor = FL_PROCEDURE;
cond->block->expr1->symtree->n.sym->attr.intrinsic = 1;
cond->block->expr1->symtree->n.sym->result = cond->block->expr1->symtree->n.sym;
@@ -1038,10 +1039,12 @@ finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr,
{
gfc_code *block;
gfc_expr *expr, *expr2;
+ const char *sname;

/* C_F_POINTER(). */
block = gfc_get_code (EXEC_CALL);
- gfc_get_sym_tree ("c_f_pointer", sub_ns, &block->symtree, true);
+ sname = gfc_get_string ("%s", "c_f_pointer");
+ gfc_get_sym_tree (sname, sub_ns, &block->symtree, true);
block->resolved_sym = block->symtree->n.sym;
block->resolved_sym->attr.flavor = FL_PROCEDURE;
block->resolved_sym->attr.intrinsic = 1;
@@ -1063,7 +1066,8 @@ finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr,
/* TRANSFER's first argument: C_LOC (array). */
expr = gfc_get_expr ();
expr->expr_type = EXPR_FUNCTION;
- gfc_get_sym_tree ("c_loc", sub_ns, &expr->symtree, false);
+ sname = gfc_get_string ("%s", "c_loc");
+ gfc_get_sym_tree (sname, sub_ns, &expr->symtree, false);
expr->symtree->n.sym->attr.flavor = FL_PROCEDURE;
expr->symtree->n.sym->intmod_sym_id = ISOCBINDING_LOC;
expr->symtree->n.sym->attr.intrinsic = 1;
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index cc14a871dfd..1f148c88eb8 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -6441,6 +6441,7 @@ static bool
add_hidden_procptr_result (gfc_symbol *sym)
{
bool case1,case2;
+ const char *ppr_name;

if (gfc_notification_std (GFC_STD_F2003) == ERROR)
return false;
@@ -6454,16 +6455,18 @@ add_hidden_procptr_result (gfc_symbol *sym)
&& gfc_state_stack->previous->state == COMP_FUNCTION
&& gfc_state_stack->previous->sym->name == sym->name;

+ ppr_name = gfc_get_string ("%s", "ppr@");
if (case1 || case2)
{
+
gfc_symtree *stree;
if (case1)
- gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree, false);
+ gfc_get_sym_tree (ppr_name, gfc_current_ns, &stree, false);
else if (case2)
{
gfc_symtree *st2;
- gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree, false);
- st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@");
+ gfc_get_sym_tree (ppr_name, gfc_current_ns->parent, &stree, false);
+ st2 = gfc_new_symtree (&gfc_current_ns->sym_root, ppr_name);
st2->n.sym = stree->n.sym;
stree->n.sym->refs++;
}
@@ -6490,7 +6493,7 @@ add_hidden_procptr_result (gfc_symbol *sym)
&& sym->result && sym->result != sym && sym->result->attr.external
&& sym == gfc_current_ns->proc_name
&& sym == sym->result->ns->proc_name
- && strcmp ("ppr@", sym->result->name) == 0)
+ && sym->result->name == ppr_name)
{
sym->result->attr.proc_pointer = 1;
sym->attr.pointer = 0;
diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c
index d549d8b6ffd..ccbc25acf97 100644
--- a/gcc/fortran/frontend-passes.c
+++ b/gcc/fortran/frontend-passes.c
@@ -713,7 +713,7 @@ insert_block ()
static gfc_expr*
create_var (gfc_expr * e, const char *vname)
{
- char name[GFC_MAX_SYMBOL_LEN +1];
+ const char *name;
gfc_symtree *symtree;
gfc_symbol *symbol;
gfc_expr *result;
@@ -733,9 +733,9 @@ create_var (gfc_expr * e, const char *vname)
ns = insert_block ();

if (vname)
- snprintf (name, GFC_MAX_SYMBOL_LEN, "__var_%d_%s", var_num++, vname);
+ name = gfc_get_string ("__var_%d_%s", var_num++, vname);
else
- snprintf (name, GFC_MAX_SYMBOL_LEN, "__var_%d", var_num++);
+ name = gfc_get_string ("__var_%d", var_num++);

if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
gcc_unreachable ();
@@ -1985,6 +1985,7 @@ get_len_trim_call (gfc_expr *str, int kind)
{
gfc_expr *fcn;
gfc_actual_arglist *actual_arglist, *next;
+ const char *sname;

fcn = gfc_get_expr ();
fcn->expr_type = EXPR_FUNCTION;
@@ -2000,7 +2001,8 @@ get_len_trim_call (gfc_expr *str, int kind)
fcn->ts.type = BT_INTEGER;
fcn->ts.kind = gfc_charlen_int_kind;

- gfc_get_sym_tree ("__internal_len_trim", current_ns, &fcn->symtree, false);
+ sname = gfc_get_string ("%s", "__internal_len_trim");
+ gfc_get_sym_tree (sname, current_ns, &fcn->symtree, false);
fcn->symtree->n.sym->ts = fcn->ts;
fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
fcn->symtree->n.sym->attr.function = 1;
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 2eb8f7c9113..f22e0da54c9 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -3351,7 +3351,7 @@ create_formal_for_intents (gfc_actual_arglist* actual, const sym_intent* ints)
void
gfc_resolve_atomic_def (gfc_code *c)
{
- const char *name = "atomic_define";
+ const char *name = gfc_get_string ("%s", "atomic_define");
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}

@@ -3359,14 +3359,14 @@ gfc_resolve_atomic_def (gfc_code *c)
void
gfc_resolve_atomic_ref (gfc_code *c)
{
- const char *name = "atomic_ref";
+ const char *name = gfc_get_string ("%s", "atomic_ref");
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}

void
gfc_resolve_event_query (gfc_code *c)
{
- const char *name = "event_query";
+ const char *name = gfc_get_string ("%s", "event_query");
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}

diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index a868e34193f..fcfe671be8b 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -2860,6 +2860,7 @@ gfc_match_omp_declare_reduction (void)
gfc_namespace *combiner_ns, *initializer_ns = NULL;
gfc_omp_udr *prev_udr, *omp_udr;
const char *predef_name = NULL;
+ const char *sname;

omp_udr = gfc_get_omp_udr ();
omp_udr->name = name;
@@ -2870,8 +2871,10 @@ gfc_match_omp_declare_reduction (void)
gfc_current_ns = combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
combiner_ns->proc_name = combiner_ns->parent->proc_name;

- gfc_get_sym_tree ("omp_out", combiner_ns, &omp_out, false);
- gfc_get_sym_tree ("omp_in", combiner_ns, &omp_in, false);
+ sname = gfc_get_string ("%s", "omp_out");
+ gfc_get_sym_tree (sname, combiner_ns, &omp_out, false);
+ sname = gfc_get_string ("%s", "omp_in");
+ gfc_get_sym_tree (sname, combiner_ns, &omp_in, false);
combiner_ns->omp_udr_ns = 1;
omp_out->n.sym->ts = tss[i];
omp_in->n.sym->ts = tss[i];
@@ -2903,8 +2906,10 @@ gfc_match_omp_declare_reduction (void)
gfc_current_ns = initializer_ns;
initializer_ns->proc_name = initializer_ns->parent->proc_name;

- gfc_get_sym_tree ("omp_priv", initializer_ns, &omp_priv, false);
- gfc_get_sym_tree ("omp_orig", initializer_ns, &omp_orig, false);
+ sname = gfc_get_string ("%s", "omp_priv");
+ gfc_get_sym_tree (sname, initializer_ns, &omp_priv, false);
+ sname = gfc_get_string ("%s", "omp_orig");
+ gfc_get_sym_tree (sname, initializer_ns, &omp_orig, false);
initializer_ns->omp_udr_ns = 1;
omp_priv->n.sym->ts = tss[i];
omp_orig->n.sym->ts = tss[i];
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 755bff56e24..b7265c42f58 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -6252,7 +6252,7 @@ loop:
prog_locus = gfc_current_locus;

push_state (&s, COMP_PROGRAM, gfc_new_block);
- main_program_symbol (gfc_current_ns, "MAIN__");
+ main_program_symbol (gfc_current_ns, gfc_get_string ("MAIN__"));
parse_progunit (st);
goto prog_units;
}
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 88c16d462bd..8072bd20435 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -8814,10 +8814,11 @@ fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2,
static gfc_expr *
build_loc_call (gfc_expr *sym_expr)
{
+ const char *loc = gfc_get_string ("%s", "_loc");
gfc_expr *loc_call;
loc_call = gfc_get_expr ();
loc_call->expr_type = EXPR_FUNCTION;
- gfc_get_sym_tree ("_loc", gfc_current_ns, &loc_call->symtree, false);
+ gfc_get_sym_tree (loc, gfc_current_ns, &loc_call->symtree, false);
loc_call->symtree->n.sym->attr.flavor = FL_PROCEDURE;
loc_call->symtree->n.sym->attr.intrinsic = 1;
loc_call->symtree->n.sym->result = loc_call->symtree->n.sym;
@@ -10487,12 +10488,13 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
path. */
if (caf_convert_to_send)
{
+ const char *sname = gfc_get_string ("%s", GFC_PREFIX ("caf_send"));
if (code->expr2->expr_type == EXPR_FUNCTION
&& code->expr2->value.function.isym
&& code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET)
remove_caf_get_intrinsic (code->expr2);
code->op = EXEC_CALL;
- gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree, true);
+ gfc_get_sym_tree (sname, ns, &code->symtree, true);
code->resolved_sym = code->symtree->n.sym;
code->resolved_sym->attr.flavor = FL_PROCEDURE;
code->resolved_sym->attr.intrinsic = 1;

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

gfc_match_name does check for too long names already. Since
gfc_new_symbol is also called for symbols with internal names containing
compiler-generated prefixes, these internal names can easily exceed the
max_identifier_length mandated by the standard.

gcc/fortran/ChangeLog

2018-09-04 Bernhard Reutner-Fischer <***@gcc.gnu.org>

PR fortran/87103
* expr.c (gfc_check_conformance): Check vsnprintf for truncation.
* iresolve.c (gfc_get_string): Likewise.
* symbol.c (gfc_new_symbol): Remove check for maximum symbol
name length. Remove redundant 0 setting of new calloc()ed
gfc_symbol.
---
gcc/fortran/expr.c | 4 +++-
gcc/fortran/iresolve.c | 5 ++++-
gcc/fortran/symbol.c | 16 ----------------
3 files changed, 7 insertions(+), 18 deletions(-)

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index c5bf822cd24..6b5671390ec 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -3225,8 +3225,10 @@ gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, .
return true;

va_start (argp, optype_msgid);
- vsnprintf (buffer, 240, optype_msgid, argp);
+ d = vsnprintf (buffer, sizeof (buffer), optype_msgid, argp);
va_end (argp);
+ if (d < 1 || d >= (int) sizeof (buffer)) /* Reject truncation. */
+ gfc_internal_error ("optype_msgid overflow: %d", d);

if (op1->rank != op2->rank)
{
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 61663fec7e5..d7bd0545173 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -60,9 +60,12 @@ gfc_get_string (const char *format, ...)
}
else
{
+ int ret;
va_start (ap, format);
- vsnprintf (temp_name, sizeof (temp_name), format, ap);
+ ret = vsnprintf (temp_name, sizeof (temp_name), format, ap);
va_end (ap);
+ if (ret < 1 || ret >= (int) sizeof (temp_name)) /* Reject truncation. */
+ gfc_internal_error ("identifier overflow: %d", ret);
temp_name[sizeof (temp_name) - 1] = 0;
str = temp_name;
}
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index cde34c67482..fc3354f0457 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -3142,25 +3142,9 @@ gfc_new_symbol (const char *name, gfc_namespace *ns)
gfc_clear_ts (&p->ts);
gfc_clear_attr (&p->attr);
p->ns = ns;
-
p->declared_at = gfc_current_locus;
-
- if (strlen (name) > GFC_MAX_SYMBOL_LEN)
- gfc_internal_error ("new_symbol(): Symbol name too long");
-
p->name = gfc_get_string ("%s", name);

- /* Make sure flags for symbol being C bound are clear initially. */
- p->attr.is_bind_c = 0;
- p->attr.is_iso_c = 0;
-
- /* Clear the ptrs we may need. */
- p->common_block = NULL;
- p->f2k_derived = NULL;
- p->assoc = NULL;
- p->dt_next = NULL;
- p->fn_result_spec = 0;
-
return p;
}

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

gcc/fortran/ChangeLog:

2017-11-29 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* module.c (load_needed): Use stringpool when generating symbols
and module names.
---
gcc/fortran/module.c | 17 ++++++++++++-----
1 file changed, 12 insertions(+), 5 deletions(-)

diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 8f6dc9f2864..ebfcd62801d 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -4857,6 +4857,7 @@ load_needed (pointer_info *p)
pointer_info *q;
gfc_symbol *sym;
int rv;
+ const char *true_name, *module;

rv = 0;
if (p == NULL)
@@ -4888,15 +4889,21 @@ load_needed (pointer_info *p)
associate_integer_pointer (q, ns);
}

+ true_name = p->u.rsym.true_name;
+ if (true_name[0] != '\0')
+ true_name = gfc_get_string ("%s", true_name);
+ module = p->u.rsym.module;
+ if (module[0] != '\0')
+ module = gfc_get_string ("%s", module);
+
/* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
doesn't go pear-shaped if the symbol is used. */
if (!ns->proc_name)
- gfc_find_symbol (p->u.rsym.module, gfc_current_ns,
- 1, &ns->proc_name);
+ gfc_find_symbol (module, gfc_current_ns, 1, &ns->proc_name);

- sym = gfc_new_symbol (p->u.rsym.true_name, ns);
- sym->name = gfc_dt_lower_string (p->u.rsym.true_name);
- sym->module = gfc_get_string ("%s", p->u.rsym.module);
+ sym = gfc_new_symbol (true_name, ns);
+ sym->name = gfc_dt_lower_string (true_name);
+ sym->module = module;
if (p->u.rsym.binding_label)
sym->binding_label = p->u.rsym.binding_label;

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

gcc/fortran/ChangeLog:

2018-09-19 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* class.c (generate_finalization_wrapper, gfc_find_derived_vtab,
find_intrinsic_vtab): Set module if in module context.
* decl.c (gfc_match_decl_type_spec): Likewise.
(match_procedure_decl, match_ppc_decl): Flag interface function
as artificial.
* resolve.c (check_proc_interface): Do not warn about missing
explicit interface for artificial interface functions.
* module.c (free_pi_tree): Do not free true_name nor module.
(parse_string): Avoid needless reallocation.
(read_string): Delete.
(read_module): Use stringpool when generating symbols and module
names.
(mio_symtree_ref): Use stringpool for module.
(mio_omp_udr_expr): Likewise.
(load_needed): Use stringpool for module and symbol name.
(find_symbols_to_write): Fix indentation.
---
gcc/fortran/class.c | 18 ++++++++-
gcc/fortran/decl.c | 8 ++++
gcc/fortran/module.c | 92 +++++++++++++++++++------------------------
gcc/fortran/resolve.c | 2 +-
4 files changed, 65 insertions(+), 55 deletions(-)

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 33c772c6eba..370b6387744 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -1641,6 +1641,8 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
array->as->type = AS_ASSUMED_RANK;
array->as->rank = -1;
array->attr.intent = INTENT_INOUT;
+ if (ns->proc_name->attr.flavor == FL_MODULE)
+ array->module = ns->proc_name->name;
gfc_set_sym_referenced (array);
final->formal = gfc_get_formal_arglist ();
final->formal->sym = array;
@@ -1654,6 +1656,8 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
byte_stride->attr.dummy = 1;
byte_stride->attr.value = 1;
byte_stride->attr.artificial = 1;
+ if (ns->proc_name->attr.flavor == FL_MODULE)
+ byte_stride->module = ns->proc_name->name;
gfc_set_sym_referenced (byte_stride);
final->formal->next = gfc_get_formal_arglist ();
final->formal->next->sym = byte_stride;
@@ -1667,6 +1671,8 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
fini_coarray->attr.dummy = 1;
fini_coarray->attr.value = 1;
fini_coarray->attr.artificial = 1;
+ if (ns->proc_name->attr.flavor == FL_MODULE)
+ fini_coarray->module = ns->proc_name->name;
gfc_set_sym_referenced (fini_coarray);
final->formal->next->next = gfc_get_formal_arglist ();
final->formal->next->next->sym = fini_coarray;
@@ -2432,7 +2438,9 @@ gfc_find_derived_vtab (gfc_symbol *derived)
src->attr.flavor = FL_VARIABLE;
src->attr.dummy = 1;
src->attr.artificial = 1;
- src->attr.intent = INTENT_IN;
+ src->attr.intent = INTENT_IN;
+ if (ns->proc_name->attr.flavor == FL_MODULE)
+ src->module = sub_ns->proc_name->name;
gfc_set_sym_referenced (src);
copy->formal = gfc_get_formal_arglist ();
copy->formal->sym = src;
@@ -2443,6 +2451,8 @@ gfc_find_derived_vtab (gfc_symbol *derived)
dst->attr.dummy = 1;
dst->attr.artificial = 1;
dst->attr.intent = INTENT_INOUT;
+ if (ns->proc_name->attr.flavor == FL_MODULE)
+ dst->module = sub_ns->proc_name->name;
gfc_set_sym_referenced (dst);
copy->formal->next = gfc_get_formal_arglist ();
copy->formal->next->sym = dst;
@@ -2761,7 +2771,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
copy->attr.elemental = 1;
if (ns->proc_name->attr.flavor == FL_MODULE)
copy->module = ns->proc_name->name;
- gfc_set_sym_referenced (copy);
+ gfc_set_sym_referenced (copy);
/* Set up formal arguments. */
gfc_get_symbol (gfc_get_string ("%s", "src"), sub_ns, &src);
src->ts.type = ts->type;
@@ -2769,6 +2779,8 @@ find_intrinsic_vtab (gfc_typespec *ts)
src->attr.flavor = FL_VARIABLE;
src->attr.dummy = 1;
src->attr.intent = INTENT_IN;
+ if (ns->proc_name->attr.flavor == FL_MODULE)
+ src->module = sub_ns->proc_name->name;
gfc_set_sym_referenced (src);
copy->formal = gfc_get_formal_arglist ();
copy->formal->sym = src;
@@ -2778,6 +2790,8 @@ find_intrinsic_vtab (gfc_typespec *ts)
dst->attr.flavor = FL_VARIABLE;
dst->attr.dummy = 1;
dst->attr.intent = INTENT_INOUT;
+ if (ns->proc_name->attr.flavor == FL_MODULE)
+ dst->module = sub_ns->proc_name->name;
gfc_set_sym_referenced (dst);
copy->formal->next = gfc_get_formal_arglist ();
copy->formal->next->sym = dst;
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 1f148c88eb8..018af363679 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -4061,6 +4061,10 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
upe->refs++;
upe->ts.type = BT_VOID;
upe->attr.unlimited_polymorphic = 1;
+ /* Make sure gfc_find_gsymbol sees a (non-NULL) name to
+ * search for by plugging in some module name. */
+ if (gfc_current_ns->proc_name != NULL)
+ upe->module = gfc_current_ns->proc_name->name;
/* This is essential to force the construction of
unlimited polymorphic component class containers. */
upe->attr.zero_comp = 1;
@@ -6681,6 +6685,8 @@ match_procedure_decl (void)
sym->ts.interface->ts = current_ts;
sym->ts.interface->attr.flavor = FL_PROCEDURE;
sym->ts.interface->attr.function = 1;
+ /* Suppress warnings about explicit interface */
+ sym->ts.interface->attr.artificial = 1;
sym->attr.function = 1;
sym->attr.if_source = IFSRC_UNKNOWN;
}
@@ -6820,6 +6826,8 @@ match_ppc_decl (void)
c->ts.interface->ts = ts;
c->ts.interface->attr.flavor = FL_PROCEDURE;
c->ts.interface->attr.function = 1;
+ /* Suppress warnings about explicit interface */
+ c->ts.interface->attr.artificial = 1;
c->attr.function = 1;
c->attr.if_source = IFSRC_UNKNOWN;
}
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 8f6dc9f2864..3cc8e80dc56 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -159,7 +159,7 @@ typedef struct pointer_info
{
gfc_symbol *sym;
const char *binding_label;
- char *true_name, *module;
+ const char *true_name, *module;
fixup_t *stfixup;
gfc_symtree *symtree;
enum gfc_rsym_state state;
@@ -239,12 +239,6 @@ free_pi_tree (pointer_info *p)
free_pi_tree (p->left);
free_pi_tree (p->right);

- if (iomode == IO_INPUT)
- {
- XDELETEVEC (p->u.rsym.true_name);
- XDELETEVEC (p->u.rsym.module);
- }
-
free (p);
}

@@ -1271,8 +1265,9 @@ parse_string (void)
len++;
}

- atom_string = XRESIZEVEC (char, atom_string, len + 1);
- atom_string[len] = '\0'; /* C-style string for debug purposes. */
+ if (len >= cursz)
+ atom_string = XRESIZEVEC (char, atom_string, len + 1);
+ atom_string[len] = '\0'; /* C-style string for debug purposes. */
}


@@ -1594,19 +1589,6 @@ find_enum (const mstring *m)
}


-/* Read a string. The caller is responsible for freeing. */
-
-static char*
-read_string (void)
-{
- char* p;
- require_atom (ATOM_STRING);
- p = atom_string;
- atom_string = NULL;
- return p;
-}
-
-
/**************** Module output subroutines ***************************/

/* Output a character to a module file. */
@@ -3013,7 +2995,7 @@ mio_symtree_ref (gfc_symtree **stp)
{
p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name,
gfc_current_ns);
- p->u.rsym.sym->module = gfc_get_string ("%s", p->u.rsym.module);
+ p->u.rsym.sym->module = p->u.rsym.module;
}

p->u.rsym.symtree->n.sym = p->u.rsym.sym;
@@ -4242,13 +4224,13 @@ mio_omp_udr_expr (gfc_omp_udr *udr, gfc_symbol **sym1, gfc_symbol **sym2,
q->u.pointer = (void *) ns;
sym = gfc_new_symbol (is_initializer ? "omp_priv" : "omp_out", ns);
sym->ts = udr->ts;
- sym->module = gfc_get_string ("%s", p1->u.rsym.module);
+ sym->module = p1->u.rsym.module;
associate_integer_pointer (p1, sym);
sym->attr.omp_udr_artificial_var = 1;
gcc_assert (p2->u.rsym.sym == NULL);
sym = gfc_new_symbol (is_initializer ? "omp_orig" : "omp_in", ns);
sym->ts = udr->ts;
- sym->module = gfc_get_string ("%s", p2->u.rsym.module);
+ sym->module = p2->u.rsym.module;
associate_integer_pointer (p2, sym);
sym->attr.omp_udr_artificial_var = 1;
if (mio_name (0, omp_declare_reduction_stmt) == 0)
@@ -4371,8 +4353,8 @@ mio_symbol (gfc_symbol *sym)
/************************* Top level subroutines *************************/

/* A recursive function to look for a specific symbol by name and by
- module. Whilst several symtrees might point to one symbol, its
- is sufficient for the purposes here than one exist. Note that
+ module. Whilst several symtrees might point to one symbol, it
+ is sufficient for the purposes here that one exist. Note that
generic interfaces are distinguished as are symbols that have been
renamed in another module. */
static gfc_symtree *
@@ -4890,15 +4872,24 @@ load_needed (pointer_info *p)

/* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
doesn't go pear-shaped if the symbol is used. */
- if (!ns->proc_name)
- gfc_find_symbol (p->u.rsym.module, gfc_current_ns,
- 1, &ns->proc_name);
+ if (ns->proc_name == NULL && p->u.rsym.module != NULL)
+ gfc_find_symbol (p->u.rsym.module,
+ gfc_current_ns, 1, &ns->proc_name);
+ if (p->u.rsym.true_name != NULL)
+ {
+ sym = gfc_new_symbol (p->u.rsym.true_name, ns);
+ sym->name = gfc_dt_lower_string (p->u.rsym.true_name);
+ }
+ else
+ {
+ static unsigned int fake = 0;
+ const char *fake_node;

- sym = gfc_new_symbol (p->u.rsym.true_name, ns);
- sym->name = gfc_dt_lower_string (p->u.rsym.true_name);
- sym->module = gfc_get_string ("%s", p->u.rsym.module);
- if (p->u.rsym.binding_label)
- sym->binding_label = p->u.rsym.binding_label;
+ fake_node = gfc_get_string ("__fake_fixup_node_%d", fake++);
+ sym = gfc_new_symbol (fake_node, ns);
+ }
+ sym->module = p->u.rsym.module;
+ sym->binding_label = p->u.rsym.binding_label;

associate_integer_pointer (p, sym);
}
@@ -5073,18 +5064,15 @@ read_module (void)

while (peek_atom () != ATOM_RPAREN)
{
- const char* bind_label;
require_atom (ATOM_INTEGER);
info = get_integer (atom_int);

info->type = P_SYMBOL;
info->u.rsym.state = UNUSED;

- info->u.rsym.true_name = read_string ();
- info->u.rsym.module = read_string ();
- mio_pool_string (&bind_label);
- if (bind_label)
- info->u.rsym.binding_label = bind_label;
+ mio_pool_string (&info->u.rsym.true_name);
+ mio_pool_string (&info->u.rsym.module);
+ mio_pool_string (&info->u.rsym.binding_label);

require_atom (ATOM_INTEGER);
info->u.rsym.ns = atom_int;
@@ -5096,10 +5084,13 @@ read_module (void)
being loaded again. This should not happen if the symbol being
read is an index for an assumed shape dummy array (ns != 1). */

- sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
+ if (info->u.rsym.true_name == NULL || info->u.rsym.module == NULL)
+ sym = NULL;
+ else
+ sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);

if (sym == NULL
- || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
+ || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns != 1))
{
skip_list ();
continue;
@@ -5254,14 +5245,11 @@ read_module (void)
/* Create a symbol node if it doesn't already exist. */
if (sym == NULL)
{
- info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
- gfc_current_ns);
- info->u.rsym.sym->name = gfc_dt_lower_string (info->u.rsym.true_name);
- sym = info->u.rsym.sym;
- sym->module = gfc_get_string ("%s", info->u.rsym.module);
-
- if (info->u.rsym.binding_label)
- sym->binding_label = info->u.rsym.binding_label;
+ sym = gfc_new_symbol (info->u.rsym.true_name, gfc_current_ns);
+ sym->name = gfc_dt_lower_string (info->u.rsym.true_name);
+ sym->module = info->u.rsym.module;
+ sym->binding_label = info->u.rsym.binding_label;
+ info->u.rsym.sym = sym;
}

st->n.sym = sym;
@@ -5795,7 +5783,7 @@ find_symbols_to_write(sorted_pointer_info **tree, pointer_info *p)
sp->p = p;

gfc_insert_bbt (tree, sp, compare_sorted_pointer_info);
- }
+ }

find_symbols_to_write (tree, p->left);
find_symbols_to_write (tree, p->right);
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 8072bd20435..34ecc9e669f 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -173,7 +173,7 @@ check_proc_interface (gfc_symbol *ifc, locus *where)
"PROCEDURE statement at %L", ifc->name, where);
return false;
}
- if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0')
+ if (!ifc->attr.if_source && !ifc->attr.intrinsic && !ifc->attr.artificial)
{
gfc_error ("Interface %qs at %L must be explicit", ifc->name, where);
return false;

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

gcc/fortran/ChangeLog:

2017-12-12 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* trans-openmp.c (gfc_trans_omp_array_reduction_or_udr): Use
stringpool for clause reduction code.
---
gcc/fortran/trans-openmp.c | 1 +
1 file changed, 1 insertion(+)

diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index f038f4c5bf8..c8d7e0a409d 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -1616,6 +1616,7 @@ gfc_trans_omp_array_reduction_or_udr (tree c, gfc_omp_namelist *n, locus where)
}
if (iname != NULL)
{
+ iname = gfc_get_string ("%s", iname);
memset (&intrinsic_sym, 0, sizeof (intrinsic_sym));
intrinsic_sym.ns = sym->ns;
intrinsic_sym.name = iname;

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

This replaces the remaining occurrences of names and name manipulation
to go through the stringpool. Required to make TYPE (IS) handling work
later on.

gcc/fortran/ChangeLog:

2017-11-14 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* class.c (gfc_build_class_symbol): Use pointer for name.
(generate_finalization_wrapper): Likewise.
(gfc_find_derived_vtab): Likewise.
(find_intrinsic_vtab): Likewise.
* decl.c (gfc_get_pdt_instance): Likewise.
* frontend-passes.c (create_do_loop): Likewise.
* match.c (select_intrinsic_set_tmp): Likewise.
* resolve.c (resolve_select_type): Likewise.
(resolve_critical): Likewise.
(get_temp_from_expr): Likewise.
(resolve_component): Likewise.
* trans-expr.c (alloc_scalar_allocatable_for_subcomponent_assignment):
Likewise.
* trans.c (gfc_deferred_strlen): Likewise.
---
gcc/fortran/class.c | 44 ++++++++++++++++-------------------
gcc/fortran/decl.c | 2 +-
gcc/fortran/frontend-passes.c | 6 ++---
gcc/fortran/match.c | 6 ++---
gcc/fortran/resolve.c | 30 +++++++++++-------------
gcc/fortran/trans-expr.c | 4 ++--
gcc/fortran/trans.c | 6 ++---
7 files changed, 46 insertions(+), 52 deletions(-)

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 8e637689fae..c2dc3411811 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -602,7 +602,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
gfc_array_spec **as)
{
char tname[GFC_MAX_SYMBOL_LEN+1];
- char *name;
+ const char *name;
gfc_symbol *fclass;
gfc_symbol *vtab;
gfc_component *c;
@@ -633,17 +633,17 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
rank = !(*as) || (*as)->rank == -1 ? GFC_MAX_DIMENSIONS : (*as)->rank;
get_unique_hashed_string (tname, ts->u.derived);
if ((*as) && attr->allocatable)
- name = xasprintf ("__class_%s_%d_%da", tname, rank, (*as)->corank);
+ name = gfc_get_string ("__class_%s_%d_%da", tname, rank, (*as)->corank);
else if ((*as) && attr->pointer)
- name = xasprintf ("__class_%s_%d_%dp", tname, rank, (*as)->corank);
+ name = gfc_get_string ("__class_%s_%d_%dp", tname, rank, (*as)->corank);
else if ((*as))
- name = xasprintf ("__class_%s_%d_%dt", tname, rank, (*as)->corank);
+ name = gfc_get_string ("__class_%s_%d_%dt", tname, rank, (*as)->corank);
else if (attr->pointer)
- name = xasprintf ("__class_%s_p", tname);
+ name = gfc_get_string ("__class_%s_p", tname);
else if (attr->allocatable)
- name = xasprintf ("__class_%s_a", tname);
+ name = gfc_get_string ("__class_%s_a", tname);
else
- name = xasprintf ("__class_%s_t", tname);
+ name = gfc_get_string ("__class_%s_t", tname);

if (ts->u.derived->attr.unlimited_polymorphic)
{
@@ -738,7 +738,6 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
ts->u.derived = fclass;
attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0;
(*as) = NULL;
- free (name);
return true;
}

@@ -1528,7 +1527,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
gfc_component *comp;
gfc_namespace *sub_ns;
gfc_code *last_code, *block;
- char *name;
+ const char *name;
bool finalizable_comp = false;
bool expr_null_wrapper = false;
gfc_expr *ancestor_wrapper = NULL, *rank;
@@ -1607,7 +1606,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
sub_ns->resolved = 1;

/* Set up the procedure symbol. */
- name = xasprintf ("__final_%s", tname);
+ name = gfc_get_string ("__final_%s", tname);
gfc_get_symbol (name, sub_ns, &final);
sub_ns->proc_name = final;
final->attr.flavor = FL_PROCEDURE;
@@ -2173,7 +2172,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
gfc_free_expr (rank);
vtab_final->initializer = gfc_lval_expr_from_sym (final);
vtab_final->ts.interface = final;
- free (name);
}


@@ -2242,10 +2240,10 @@ gfc_find_derived_vtab (gfc_symbol *derived)
if (ns)
{
char tname[GFC_MAX_SYMBOL_LEN+1];
- char *name;
+ const char *name;

get_unique_hashed_string (tname, derived);
- name = xasprintf ("__vtab_%s", tname);
+ name = gfc_get_string ("__vtab_%s", tname);

/* Look for the vtab symbol in various namespaces. */
if (gsym && gsym->ns)
@@ -2273,7 +2271,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
vtab->attr.vtab = 1;
vtab->attr.access = ACCESS_PUBLIC;
gfc_set_sym_referenced (vtab);
- name = xasprintf ("__vtype_%s", tname);
+ name = gfc_get_string ("__vtype_%s", tname);

gfc_find_symbol (name, ns, 0, &vtype);
if (vtype == NULL)
@@ -2376,7 +2374,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
else
{
/* Construct default initialization variable. */
- name = xasprintf ("__def_init_%s", tname);
+ name = gfc_get_string ("__def_init_%s", tname);
gfc_get_symbol (name, ns, &def_init);
def_init->attr.target = 1;
def_init->attr.artificial = 1;
@@ -2409,7 +2407,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
ns->contained = sub_ns;
sub_ns->resolved = 1;
/* Set up procedure symbol. */
- name = xasprintf ("__copy_%s", tname);
+ name = gfc_get_string ("__copy_%s", tname);
gfc_get_symbol (name, sub_ns, &copy);
sub_ns->proc_name = copy;
copy->attr.flavor = FL_PROCEDURE;
@@ -2486,7 +2484,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
ns->contained = sub_ns;
sub_ns->resolved = 1;
/* Set up procedure symbol. */
- name = xasprintf ("__deallocate_%s", tname);
+ name = gfc_get_string ("__deallocate_%s", tname);
gfc_get_symbol (name, sub_ns, &dealloc);
sub_ns->proc_name = dealloc;
dealloc->attr.flavor = FL_PROCEDURE;
@@ -2535,7 +2533,6 @@ have_vtype:
vtab->ts.u.derived = vtype;
vtab->value = gfc_default_initializer (&vtab->ts);
}
- free (name);
}

found_sym = vtab;
@@ -2628,13 +2625,13 @@ find_intrinsic_vtab (gfc_typespec *ts)
if (ns)
{
char tname[GFC_MAX_SYMBOL_LEN+1];
- char *name;
+ const char *name;

/* Encode all types as TYPENAME_KIND_ including especially character
arrays, whose length is now consistently stored in the _len component
of the class-variable. */
sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind);
- name = xasprintf ("__vtab_%s", tname);
+ name = gfc_get_string ("__vtab_%s", tname);

/* Look for the vtab symbol in the top-level namespace only. */
gfc_find_symbol (name, ns, 0, &vtab);
@@ -2651,7 +2648,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
vtab->attr.vtab = 1;
vtab->attr.access = ACCESS_PUBLIC;
gfc_set_sym_referenced (vtab);
- name = xasprintf ("__vtype_%s", tname);
+ name = gfc_get_string ("__vtype_%s", tname);

gfc_find_symbol (name, ns, 0, &vtype);
if (vtype == NULL)
@@ -2727,12 +2724,12 @@ find_intrinsic_vtab (gfc_typespec *ts)
c->tb->ppc = 1;

if (ts->type != BT_CHARACTER)
- name = xasprintf ("__copy_%s", tname);
+ name = gfc_get_string ("__copy_%s", tname);
else
{
/* __copy is always the same for characters.
Check to see if copy function already exists. */
- name = xasprintf ("__copy_character_%d", ts->kind);
+ name = gfc_get_string ("__copy_character_%d", ts->kind);
contained = ns->contained;
for (; contained; contained = contained->sibling)
if (contained->proc_name
@@ -2801,7 +2798,6 @@ find_intrinsic_vtab (gfc_typespec *ts)
vtab->ts.u.derived = vtype;
vtab->value = gfc_default_initializer (&vtab->ts);
}
- free (name);
}

found_sym = vtab;
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 2baa1783434..48ef5637e36 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -3582,7 +3582,7 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,

/* Now we search for the PDT instance 'name'. If it doesn't exist, we
build it, using 'pdt' as a template. */
- if (gfc_get_symbol (name, pdt->ns, &instance))
+ if (gfc_get_symbol (gfc_get_string ("%s", name), pdt->ns, &instance))
{
gfc_error ("Parameterized derived type at %C is ambiguous");
goto error_return;
diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c
index 0a5e8937015..d549d8b6ffd 100644
--- a/gcc/fortran/frontend-passes.c
+++ b/gcc/fortran/frontend-passes.c
@@ -3427,7 +3427,7 @@ create_do_loop (gfc_expr *start, gfc_expr *end, gfc_expr *step, locus *where,
gfc_namespace *ns, char *vname)
{

- char name[GFC_MAX_SYMBOL_LEN +1];
+ const char *name;
gfc_symtree *symtree;
gfc_symbol *symbol;
gfc_expr *i;
@@ -3435,9 +3435,9 @@ create_do_loop (gfc_expr *start, gfc_expr *end, gfc_expr *step, locus *where,

/* Create an expression for the iteration variable. */
if (vname)
- sprintf (name, "__var_%d_do_%s", var_num++, vname);
+ name = gfc_get_string ("__var_%d_do_%s", var_num++, vname);
else
- sprintf (name, "__var_%d_do", var_num++);
+ name = gfc_get_string ("__var_%d_do", var_num++);


if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index f27249ec6ed..2c4d6e8228c 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -6048,7 +6048,7 @@ select_type_push (gfc_symbol *sel)
static gfc_symtree *
select_intrinsic_set_tmp (gfc_typespec *ts)
{
- char name[GFC_MAX_SYMBOL_LEN];
+ const char *name;
gfc_symtree *tmp;
HOST_WIDE_INT charlen = 0;

@@ -6064,10 +6064,10 @@ select_intrinsic_set_tmp (gfc_typespec *ts)
charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);

if (ts->type != BT_CHARACTER)
- sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type),
+ name = gfc_get_string ("__tmp_%s_%d", gfc_basic_typename (ts->type),
ts->kind);
else
- snprintf (name, sizeof (name), "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
+ name = gfc_get_string ("__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
gfc_basic_typename (ts->type), charlen, ts->kind);

gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index afb745bddc5..e98e6a6d53e 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -8842,7 +8842,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
gfc_code *class_is = NULL, *default_case = NULL;
gfc_case *c;
gfc_symtree *st;
- char name[GFC_MAX_SYMBOL_LEN];
+ const char *name;
gfc_namespace *ns;
int error = 0;
int rank = 0;
@@ -9096,21 +9096,20 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
'global' one). */

if (c->ts.type == BT_CLASS)
- sprintf (name, "__tmp_class_%s", c->ts.u.derived->name);
+ name = gfc_get_string ("__tmp_class_%s", c->ts.u.derived->name);
else if (c->ts.type == BT_DERIVED)
- sprintf (name, "__tmp_type_%s", c->ts.u.derived->name);
+ name = gfc_get_string ("__tmp_type_%s", c->ts.u.derived->name);
else if (c->ts.type == BT_CHARACTER)
{
HOST_WIDE_INT charlen = 0;
if (c->ts.u.cl && c->ts.u.cl->length
&& c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
- snprintf (name, sizeof (name),
- "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
+ name = gfc_get_string ("__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
gfc_basic_typename (c->ts.type), charlen, c->ts.kind);
}
else
- sprintf (name, "__tmp_%s_%d", gfc_basic_typename (c->ts.type),
+ name = gfc_get_string ("__tmp_%s_%d", gfc_basic_typename (c->ts.type),
c->ts.kind);

st = gfc_find_symtree (ns->sym_root, name);
@@ -9553,20 +9552,19 @@ resolve_critical (gfc_code *code)
{
gfc_symtree *symtree;
gfc_symbol *lock_type;
- char name[GFC_MAX_SYMBOL_LEN];
+ const char *name;
static int serial = 0;

if (flag_coarray != GFC_FCOARRAY_LIB)
return;

- symtree = gfc_find_symtree (gfc_current_ns->sym_root,
- GFC_PREFIX ("lock_type"));
+ name = gfc_get_string (GFC_PREFIX ("lock_type"));
+ symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
if (symtree)
lock_type = symtree->n.sym;
else
{
- if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns, &symtree,
- false) != 0)
+ if (gfc_get_sym_tree (name, gfc_current_ns, &symtree, false) != 0)
gcc_unreachable ();
lock_type = symtree->n.sym;
lock_type->attr.flavor = FL_DERIVED;
@@ -9575,7 +9573,7 @@ resolve_critical (gfc_code *code)
lock_type->intmod_sym_id = ISOFORTRAN_LOCK_TYPE;
}

- sprintf(name, GFC_PREFIX ("lock_var") "%d",serial++);
+ name = gfc_get_string (GFC_PREFIX ("lock_var") "%d", serial++);
if (gfc_get_sym_tree (name, gfc_current_ns, &symtree, false) != 0)
gcc_unreachable ();

@@ -10569,13 +10567,13 @@ static gfc_expr*
get_temp_from_expr (gfc_expr *e, gfc_namespace *ns)
{
static int serial = 0;
- char name[GFC_MAX_SYMBOL_LEN];
+ const char *name;
gfc_symtree *tmp;
gfc_array_spec *as;
gfc_array_ref *aref;
gfc_ref *ref;

- sprintf (name, GFC_PREFIX("DA%d"), serial++);
+ name = gfc_get_string (GFC_PREFIX("DA%d"), serial++);
gfc_get_sym_tree (name, ns, &tmp, false);
gfc_add_type (tmp->n.sym, &e->ts, NULL);

@@ -13956,9 +13954,9 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
&& !c->attr.function
&& !sym->attr.is_class)
{
- char name[GFC_MAX_SYMBOL_LEN+9];
+ const char *name;
gfc_component *strlen;
- sprintf (name, "_%s_length", c->name);
+ name = gfc_get_string ("_%s_length", c->name);
strlen = gfc_find_component (sym, name, true, true, NULL);
if (strlen == NULL)
{
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 6c8a5b30568..d502c127951 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -7307,7 +7307,7 @@ alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,

if (cm->ts.type == BT_CHARACTER && cm->ts.deferred)
{
- char name[GFC_MAX_SYMBOL_LEN+9];
+ const char *name;
gfc_component *strlen;
/* Use the rhs string length and the lhs element size. */
gcc_assert (expr2->ts.type == BT_CHARACTER);
@@ -7321,7 +7321,7 @@ alloc_scalar_allocatable_for_subcomponent_assignment (stmtblock_t *block,

/* Ensure that cm->ts.u.cl->backend_decl is a componentref to _%s_length
component. */
- sprintf (name, "_%s_length", cm->name);
+ name = gfc_get_string ("_%s_length", cm->name);
strlen = gfc_find_component (sym, name, true, true, NULL);
lhs_cl_size = fold_build3_loc (input_location, COMPONENT_REF,
gfc_charlen_type_node,
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 153bab63396..66ba0572e0c 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -2330,14 +2330,14 @@ gfc_likely (tree cond, enum br_predictor predictor)
bool
gfc_deferred_strlen (gfc_component *c, tree *decl)
{
- char name[GFC_MAX_SYMBOL_LEN+9];
+ const char *name;
gfc_component *strlen;
if (!(c->ts.type == BT_CHARACTER
&& (c->ts.deferred || c->attr.pdt_string)))
return false;
- sprintf (name, "_%s_length", c->name);
+ name = gfc_get_string ("_%s_length", c->name);
for (strlen = c; strlen; strlen = strlen->next)
- if (strcmp (strlen->name, name) == 0)
+ if (strlen->name == name)
break;
*decl = strlen ? strlen->backend_decl : NULL_TREE;
return strlen != NULL;

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

compiling gfortran.dg/typebound_proc_31.f90 leaked the type-bound
structs:

56 bytes in 1 blocks are definitely lost.
at 0x4C2CC05: calloc (vg_replace_malloc.c:711)
by 0x151EA90: xcalloc (xmalloc.c:162)
by 0x8E3E4F: gfc_get_typebound_proc(gfc_typebound_proc*) (symbol.c:4945)
by 0x84C095: match_procedure_in_type (decl.c:10486)
by 0x84C095: gfc_match_procedure() (decl.c:6696)
...

gcc/fortran/ChangeLog:

2017-12-06 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* symbol.c (free_tb_tree): Free type-bound procedure struct.
(gfc_get_typebound_proc): Use explicit memcpy for clarity.
---
gcc/fortran/symbol.c | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 53c760a6c38..cde34c67482 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -3845,7 +3845,7 @@ free_tb_tree (gfc_symtree *t)

/* TODO: Free type-bound procedure structs themselves; probably needs some
sort of ref-counting mechanism. */
-
+ free (t->n.tb);
free (t);
}

@@ -5052,7 +5052,7 @@ gfc_get_typebound_proc (gfc_typebound_proc *tb0)

result = XCNEW (gfc_typebound_proc);
if (tb0)
- *result = *tb0;
+ memcpy (result, tb0, sizeof (gfc_typebound_proc));;
result->error = 1;

latest_undo_chgset->tbps.safe_push (result);

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

gcc/fortran/ChangeLog:

2017-11-24 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* primary.c (match_charkind_name): Return stringpool node.
(match_string_constant): Use stringpool node for name.
---
gcc/fortran/primary.c | 21 ++++++++++++---------
1 file changed, 12 insertions(+), 9 deletions(-)

diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index da661372c5c..cd5f81542cb 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -950,8 +950,9 @@ next_string_char (gfc_char_t delimiter, int *ret)
the name will be detected later. */

static match
-match_charkind_name (char *name)
+match_charkind_name (const char **result)
{
+ char buffer [GFC_MAX_SYMBOL_LEN + 1];
locus old_loc;
char c, peek;
int len;
@@ -961,8 +962,8 @@ match_charkind_name (char *name)
if (!ISALPHA (c))
return MATCH_NO;

- *name++ = c;
- len = 1;
+ len = 0;
+ buffer[len++] = c;

for (;;)
{
@@ -976,7 +977,8 @@ match_charkind_name (char *name)
if (peek == '\'' || peek == '\"')
{
gfc_current_locus = old_loc;
- *name = '\0';
+ buffer[len] = '\0';
+ *result = gfc_get_string ("%s", buffer);
return MATCH_YES;
}
}
@@ -986,8 +988,8 @@ match_charkind_name (char *name)
&& (c != '$' || !flag_dollar_ok))
break;

- *name++ = c;
- if (++len > GFC_MAX_SYMBOL_LEN)
+ buffer[len++] = c;
+ if (len > GFC_MAX_SYMBOL_LEN)
break;
}

@@ -1005,9 +1007,10 @@ match_charkind_name (char *name)
static match
match_string_constant (gfc_expr **result)
{
- char name[GFC_MAX_SYMBOL_LEN + 1], peek;
+ char peek;
+ const char *name = NULL;
size_t length;
- int kind,save_warn_ampersand, ret;
+ int kind, save_warn_ampersand, ret;
locus old_locus, start_locus;
gfc_symbol *sym;
gfc_expr *e;
@@ -1043,7 +1046,7 @@ match_string_constant (gfc_expr **result)
{
gfc_current_locus = old_locus;

- m = match_charkind_name (name);
+ m = match_charkind_name (&name);
if (m != MATCH_YES)
goto no_match;

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

Use the existing helper function to create type names. The helper
function uses the stringpool already.

gcc/fortran/ChangeLog:

2017-11-24 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* decl.c (build_sym): Use stringpool node instead of stack
variables.
(gfc_match_map): Likewise.
(gfc_match_union): Likewise.
* trans-decl.c (gfc_trans_use_stmts): Call gfc_dt_upper_string
and thus use stringpool node for the type name.
---
gcc/fortran/decl.c | 25 ++++++++++---------------
gcc/fortran/trans-decl.c | 8 +++-----
2 files changed, 13 insertions(+), 20 deletions(-)

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 48ef5637e36..55a59008f66 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -1490,7 +1490,7 @@ build_sym (const char *name, gfc_charlen *cl, bool cl_deferred,
{
symbol_attribute attr;
gfc_symbol *sym;
- int upper;
+ const char *upper;
gfc_symtree *st;

/* Symbols in a submodule are host associated from the parent module or
@@ -1520,20 +1520,15 @@ build_sym (const char *name, gfc_charlen *cl, bool cl_deferred,
course, this is only necessary if the upper case letter is
actually different. */

- upper = TOUPPER(name[0]);
- if (upper != name[0])
+ upper = gfc_dt_upper_string (name);
+ if (upper[0] != name[0])
{
- char u_name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symtree *st;
-
- gcc_assert (strlen(name) <= GFC_MAX_SYMBOL_LEN);
- strcpy (u_name, name);
- u_name[0] = upper;
-
- st = gfc_find_symtree (gfc_current_ns->sym_root, u_name);
+ gcc_assert (strlen (upper) <= GFC_MAX_SYMBOL_LEN);
+ st = gfc_find_symtree (gfc_current_ns->sym_root, upper);

/* STRUCTURE types can alias symbol names */
- if (st != 0 && st->n.sym->attr.flavor != FL_STRUCT)
+ if (st && st->n.sym->attr.flavor != FL_STRUCT)
{
gfc_error ("Symbol %qs at %C also declared as a type at %L", name,
&st->n.sym->declared_at);
@@ -9672,7 +9667,7 @@ gfc_match_map (void)
{
/* Counter used to give unique internal names to map structures. */
static unsigned int gfc_map_id = 0;
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name;
gfc_symbol *sym;
locus old_loc;

@@ -9687,7 +9682,7 @@ gfc_match_map (void)

/* Map blocks are anonymous so we make up unique names for the symbol table
which are invalid Fortran identifiers. */
- snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "MM$%u", gfc_map_id++);
+ name = gfc_get_string ("MM$%u", gfc_map_id++);

if (!get_struct_decl (name, FL_STRUCT, &old_loc, &sym))
return MATCH_ERROR;
@@ -9705,7 +9700,7 @@ gfc_match_union (void)
{
/* Counter used to give unique internal names to union types. */
static unsigned int gfc_union_id = 0;
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name;
gfc_symbol *sym;
locus old_loc;

@@ -9720,7 +9715,7 @@ gfc_match_union (void)

/* Unions are anonymous so we make up unique names for the symbol table
which are invalid Fortran identifiers. */
- snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "UU$%u", gfc_union_id++);
+ name = gfc_get_string ("UU$%u", gfc_union_id++);

if (!get_struct_decl (name, FL_UNION, &old_loc, &sym))
return MATCH_ERROR;
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 6e717633a8f..023350723ff 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -5053,12 +5053,10 @@ gfc_trans_use_stmts (gfc_namespace * ns)
/* The following can happen if a derived type is renamed. */
if (!st)
{
- char *name;
- name = xstrdup (rent->local_name
+ const char *upper;
+ upper = gfc_dt_upper_string (rent->local_name
? rent->local_name : rent->use_name);
- name[0] = (char) TOUPPER ((unsigned char) name[0]);
- st = gfc_find_symtree (ns->sym_root, name);
- free (name);
+ st = gfc_find_symtree (ns->sym_root, upper);
gcc_assert (st);
}

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

gcc/fortran/ChangeLog:

2017-11-24 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* class.c (finalizer_insert_packed_call): Use stringpool.
(generate_finalization_wrapper): Likewise.
(gfc_find_derived_vtab): Likewise.
(find_intrinsic_vtab): Likewise.
* decl.c (gfc_match_null): Likewise.
* parse.c (gfc_build_block_ns): Likewise.
* resolve.c (resolve_entries): Likewise.
* symbol.c (gfc_get_unique_symtree): Likewise.
---
gcc/fortran/class.c | 40 ++++++++++++++++++++--------------------
gcc/fortran/decl.c | 2 +-
gcc/fortran/parse.c | 6 +++---
gcc/fortran/resolve.c | 5 ++---
gcc/fortran/symbol.c | 4 ++--
5 files changed, 28 insertions(+), 29 deletions(-)

diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index c2dc3411811..20a68da8e9b 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -1373,7 +1373,7 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
block->ext.block.ns = ns;
block->ext.block.assoc = NULL;

- gfc_get_symbol ("ptr2", ns, &ptr2);
+ gfc_get_symbol (gfc_get_string ("%s", "ptr2"), ns, &ptr2);
ptr2->ts.type = BT_DERIVED;
ptr2->ts.u.derived = array->ts.u.derived;
ptr2->attr.flavor = FL_VARIABLE;
@@ -1382,7 +1382,7 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini,
gfc_set_sym_referenced (ptr2);
gfc_commit_symbol (ptr2);

- gfc_get_symbol ("tmp_array", ns, &tmp_array);
+ gfc_get_symbol (gfc_get_string ("%s", "tmp_array"), ns, &tmp_array);
tmp_array->ts.type = BT_DERIVED;
tmp_array->ts.u.derived = array->ts.u.derived;
tmp_array->attr.flavor = FL_VARIABLE;
@@ -1625,7 +1625,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
gfc_commit_symbol (final);

/* Set up formal argument. */
- gfc_get_symbol ("array", sub_ns, &array);
+ gfc_get_symbol (gfc_get_string ("%s", "array"), sub_ns, &array);
array->ts.type = BT_DERIVED;
array->ts.u.derived = derived;
array->attr.flavor = FL_VARIABLE;
@@ -1643,7 +1643,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
gfc_commit_symbol (array);

/* Set up formal argument. */
- gfc_get_symbol ("byte_stride", sub_ns, &byte_stride);
+ gfc_get_symbol (gfc_get_string ("%s", "byte_stride"), sub_ns, &byte_stride);
byte_stride->ts.type = BT_INTEGER;
byte_stride->ts.kind = gfc_index_integer_kind;
byte_stride->attr.flavor = FL_VARIABLE;
@@ -1656,7 +1656,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
gfc_commit_symbol (byte_stride);

/* Set up formal argument. */
- gfc_get_symbol ("fini_coarray", sub_ns, &fini_coarray);
+ gfc_get_symbol (gfc_get_string ("%s", "fini_coarray"), sub_ns, &fini_coarray);
fini_coarray->ts.type = BT_LOGICAL;
fini_coarray->ts.kind = 1;
fini_coarray->attr.flavor = FL_VARIABLE;
@@ -1679,7 +1679,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,

/* Local variables. */

- gfc_get_symbol ("idx", sub_ns, &idx);
+ gfc_get_symbol (gfc_get_string ("%s", "idx"), sub_ns, &idx);
idx->ts.type = BT_INTEGER;
idx->ts.kind = gfc_index_integer_kind;
idx->attr.flavor = FL_VARIABLE;
@@ -1687,7 +1687,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
gfc_set_sym_referenced (idx);
gfc_commit_symbol (idx);

- gfc_get_symbol ("idx2", sub_ns, &idx2);
+ gfc_get_symbol (gfc_get_string ("%s", "idx2"), sub_ns, &idx2);
idx2->ts.type = BT_INTEGER;
idx2->ts.kind = gfc_index_integer_kind;
idx2->attr.flavor = FL_VARIABLE;
@@ -1695,7 +1695,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
gfc_set_sym_referenced (idx2);
gfc_commit_symbol (idx2);

- gfc_get_symbol ("offset", sub_ns, &offset);
+ gfc_get_symbol (gfc_get_string ("%s", "offset"), sub_ns, &offset);
offset->ts.type = BT_INTEGER;
offset->ts.kind = gfc_index_integer_kind;
offset->attr.flavor = FL_VARIABLE;
@@ -1711,7 +1711,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
gfc_convert_type_warn (rank, &idx->ts, 2, 0);

/* Create is_contiguous variable. */
- gfc_get_symbol ("is_contiguous", sub_ns, &is_contiguous);
+ gfc_get_symbol (gfc_get_string ("%s", "is_contiguous"), sub_ns, &is_contiguous);
is_contiguous->ts.type = BT_LOGICAL;
is_contiguous->ts.kind = gfc_default_logical_kind;
is_contiguous->attr.flavor = FL_VARIABLE;
@@ -1722,7 +1722,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
/* Create "sizes(0..rank)" variable, which contains the multiplied
up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1),
sizes(2) = sizes(1) * extent(dim=2) etc. */
- gfc_get_symbol ("sizes", sub_ns, &sizes);
+ gfc_get_symbol (gfc_get_string ("%s", "sizes"), sub_ns, &sizes);
sizes->ts.type = BT_INTEGER;
sizes->ts.kind = gfc_index_integer_kind;
sizes->attr.flavor = FL_VARIABLE;
@@ -1739,7 +1739,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,

/* Create "strides(1..rank)" variable, which contains the strides per
dimension. */
- gfc_get_symbol ("strides", sub_ns, &strides);
+ gfc_get_symbol (gfc_get_string ("%s", "strides"), sub_ns, &strides);
strides->ts.type = BT_INTEGER;
strides->ts.kind = gfc_index_integer_kind;
strides->attr.flavor = FL_VARIABLE;
@@ -1919,7 +1919,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,

/* Obtain the size (number of elements) of "array" MINUS ONE,
which is used in the scalarization. */
- gfc_get_symbol ("nelem", sub_ns, &nelem);
+ gfc_get_symbol (gfc_get_string ("%s", "nelem"), sub_ns, &nelem);
nelem->ts.type = BT_INTEGER;
nelem->ts.kind = gfc_index_integer_kind;
nelem->attr.flavor = FL_VARIABLE;
@@ -1972,7 +1972,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
{
gfc_finalizer *fini, *fini_elem = NULL;

- gfc_get_symbol ("ptr1", sub_ns, &ptr);
+ gfc_get_symbol (gfc_get_string ("%s", "ptr1"), sub_ns, &ptr);
ptr->ts.type = BT_DERIVED;
ptr->ts.u.derived = derived;
ptr->attr.flavor = FL_VARIABLE;
@@ -2096,7 +2096,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,

if (!ptr)
{
- gfc_get_symbol ("ptr2", sub_ns, &ptr);
+ gfc_get_symbol (gfc_get_string ("%s", "ptr2"), sub_ns, &ptr);
ptr->ts.type = BT_DERIVED;
ptr->ts.u.derived = derived;
ptr->attr.flavor = FL_VARIABLE;
@@ -2106,7 +2106,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
gfc_commit_symbol (ptr);
}

- gfc_get_symbol ("ignore", sub_ns, &stat);
+ gfc_get_symbol (gfc_get_string ("%s", "ignore"), sub_ns, &stat);
stat->attr.flavor = FL_VARIABLE;
stat->attr.artificial = 1;
stat->ts.type = BT_INTEGER;
@@ -2422,7 +2422,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
copy->module = ns->proc_name->name;
gfc_set_sym_referenced (copy);
/* Set up formal arguments. */
- gfc_get_symbol ("src", sub_ns, &src);
+ gfc_get_symbol (gfc_get_string ("%s", "src"), sub_ns, &src);
src->ts.type = BT_DERIVED;
src->ts.u.derived = derived;
src->attr.flavor = FL_VARIABLE;
@@ -2432,7 +2432,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
gfc_set_sym_referenced (src);
copy->formal = gfc_get_formal_arglist ();
copy->formal->sym = src;
- gfc_get_symbol ("dst", sub_ns, &dst);
+ gfc_get_symbol (gfc_get_string ("%s", "dst"), sub_ns, &dst);
dst->ts.type = BT_DERIVED;
dst->ts.u.derived = derived;
dst->attr.flavor = FL_VARIABLE;
@@ -2497,7 +2497,7 @@ gfc_find_derived_vtab (gfc_symbol *derived)
dealloc->module = ns->proc_name->name;
gfc_set_sym_referenced (dealloc);
/* Set up formal argument. */
- gfc_get_symbol ("arg", sub_ns, &arg);
+ gfc_get_symbol (gfc_get_string ("%s", "arg"), sub_ns, &arg);
arg->ts.type = BT_DERIVED;
arg->ts.u.derived = derived;
arg->attr.flavor = FL_VARIABLE;
@@ -2759,7 +2759,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
copy->module = ns->proc_name->name;
gfc_set_sym_referenced (copy);
/* Set up formal arguments. */
- gfc_get_symbol ("src", sub_ns, &src);
+ gfc_get_symbol (gfc_get_string ("%s", "src"), sub_ns, &src);
src->ts.type = ts->type;
src->ts.kind = ts->kind;
src->attr.flavor = FL_VARIABLE;
@@ -2768,7 +2768,7 @@ find_intrinsic_vtab (gfc_typespec *ts)
gfc_set_sym_referenced (src);
copy->formal = gfc_get_formal_arglist ();
copy->formal->sym = src;
- gfc_get_symbol ("dst", sub_ns, &dst);
+ gfc_get_symbol (gfc_get_string ("%s", "dst"), sub_ns, &dst);
dst->ts.type = ts->type;
dst->ts.kind = ts->kind;
dst->attr.flavor = FL_VARIABLE;
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 55a59008f66..d6a6538f769 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -2183,7 +2183,7 @@ gfc_match_null (gfc_expr **result)
}

/* The NULL symbol now has to be/become an intrinsic function. */
- if (gfc_get_symbol ("null", NULL, &sym))
+ if (gfc_get_symbol (gfc_get_string ("%s", "null"), NULL, &sym))
{
gfc_error ("NULL() initialization at %C is ambiguous");
return MATCH_ERROR;
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 389eead0691..755bff56e24 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -4442,10 +4442,10 @@ gfc_build_block_ns (gfc_namespace *parent_ns)
else
{
bool t;
- char buffer[20]; /* Enough to hold "***@2147483648\n". */
+ const char *block_name;

- snprintf(buffer, sizeof(buffer), "block@%d", numblock++);
- gfc_get_symbol (buffer, my_ns, &my_ns->proc_name);
+ block_name = gfc_get_string ("block@%d", numblock++);
+ gfc_get_symbol (block_name, my_ns, &my_ns->proc_name);
t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL,
my_ns->proc_name->name, NULL);
gcc_assert (t);
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index e98e6a6d53e..88c16d462bd 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -699,7 +699,7 @@ resolve_entries (gfc_namespace *ns)
gfc_code *c;
gfc_symbol *proc;
gfc_entry_list *el;
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name;
static int master_count = 0;

if (ns->proc_name == NULL)
@@ -758,8 +758,7 @@ resolve_entries (gfc_namespace *ns)
/* Give the internal function a unique name (within this file).
Also include the function name so the user has some hope of figuring
out what is going on. */
- snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s",
- master_count++, ns->proc_name->name);
+ name = gfc_get_string ("master.%d.%s", master_count++, ns->proc_name->name);
gfc_get_ha_symbol (name, &proc);
gcc_assert (proc != NULL);

diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index ce134d2b441..53c760a6c38 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -2975,10 +2975,10 @@ gfc_find_symtree (gfc_symtree *st, const char *name)
gfc_symtree *
gfc_get_unique_symtree (gfc_namespace *ns)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
static int serial = 0;
+ const char *name;

- sprintf (name, "@%d", serial++);
+ name = gfc_get_string ("@%d", serial++);
return gfc_new_symtree (&ns->sym_root, name);
}

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

gcc/fortran/ChangeLog:

2017-11-23 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* module.c (use_iso_fortran_env_module): Use stringpool and use
pointer comparison instead of strcmp.
---
gcc/fortran/module.c | 16 ++++++++--------
1 file changed, 8 insertions(+), 8 deletions(-)

diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index d7bc7fbef1c..3b644234921 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -6678,7 +6678,7 @@ read_module_to_tmpbuf ()
static void
use_iso_fortran_env_module (void)
{
- static char mod[] = "iso_fortran_env";
+ const char *mod = gfc_get_string ("%s", "iso_fortran_env");
gfc_use_rename *u;
gfc_symbol *mod_sym;
gfc_symtree *mod_symtree;
@@ -6686,11 +6686,11 @@ use_iso_fortran_env_module (void)
int i, j;

intmod_sym symbol[] = {
-#define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
-#define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
-#define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
-#define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
-#define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d },
+#define NAMED_INTCST(a,b,c,d) { a, gfc_get_string ("%s", b), 0, d },
+#define NAMED_KINDARRAY(a,b,c,d) { a, gfc_get_string ("%s", b), 0, d },
+#define NAMED_DERIVED_TYPE(a,b,c,d) { a, gfc_get_string ("%s", b), 0, d },
+#define NAMED_FUNCTION(a,b,c,d) { a, gfc_get_string ("%s", b), c, d },
+#define NAMED_SUBROUTINE(a,b,c,d) { a, gfc_get_string ("%s", b), c, d },
#include "iso-fortran-env.def"
{ ISOFORTRANENV_INVALID, NULL, -1234, 0 } };

@@ -6708,7 +6708,7 @@ use_iso_fortran_env_module (void)

mod_sym->attr.flavor = FL_MODULE;
mod_sym->attr.intrinsic = 1;
- mod_sym->module = gfc_get_string ("%s", mod);
+ mod_sym->module = mod;
mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
}
else
@@ -6723,7 +6723,7 @@ use_iso_fortran_env_module (void)
bool found = false;
for (u = gfc_rename_list; u; u = u->next)
{
- if (strcmp (symbol[i].name, u->use_name) == 0)
+ if (symbol[i].name == u->use_name)
{
found = true;
u->found = 1;

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

gcc/fortran/ChangeLog:

2017-11-20 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* gfortran.h (struct CInteropKind_t): Make name a pointer.
* misc.c (get_c_kind): Use pointer comparison on name to
determine index.
* symbol.c (generate_isocbinding_symbol): Use stringpool pointer
for argument to get_c_kind ().
* trans-types.c (gfc_init_c_interop_kinds): Use stringpool node
for name.
* module.c (import_iso_c_binding_module): Likewise.
---
gcc/fortran/gfortran.h | 2 +-
gcc/fortran/misc.c | 2 +-
gcc/fortran/module.c | 16 +++++++++-------
gcc/fortran/symbol.c | 3 ++-
gcc/fortran/trans-types.c | 20 ++++++++++----------
5 files changed, 23 insertions(+), 20 deletions(-)

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 039719644ea..0e164c35300 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -719,7 +719,7 @@ enum intmod_id

typedef struct
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ const char *name;
int value; /* Used for both integer and character values. */
bt f90_type;
}
diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
index fb18c5ceb6f..29aae591ed3 100644
--- a/gcc/fortran/misc.c
+++ b/gcc/fortran/misc.c
@@ -278,7 +278,7 @@ get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
int index = 0;

for (index = 0; index < ISOCBINDING_LAST; index++)
- if (strcmp (kinds_table[index].name, c_kind_name) == 0)
+ if (kinds_table[index].name == c_kind_name)
return index;

return ISOCBINDING_INVALID;
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index b94411ac68b..22d9abb247f 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -6357,27 +6357,27 @@ import_iso_c_binding_module (void)
#define NAMED_FUNCTION(a,b,c,d) \
case a: \
not_in_std = (gfc_option.allow_std & d) == 0; \
- name = b; \
+ name = gfc_get_string ("%s", b); \
break;
#define NAMED_SUBROUTINE(a,b,c,d) \
case a: \
not_in_std = (gfc_option.allow_std & d) == 0; \
- name = b; \
+ name = gfc_get_string ("%s", b); \
break;
#define NAMED_INTCST(a,b,c,d) \
case a: \
not_in_std = (gfc_option.allow_std & d) == 0; \
- name = b; \
+ name = gfc_get_string ("%s", b); \
break;
#define NAMED_REALCST(a,b,c,d) \
case a: \
not_in_std = (gfc_option.allow_std & d) == 0; \
- name = b; \
+ name = gfc_get_string ("%s", b); \
break;
#define NAMED_CMPXCST(a,b,c,d) \
case a: \
not_in_std = (gfc_option.allow_std & d) == 0; \
- name = b; \
+ name = gfc_get_string ("%s", b); \
break;
#include "iso-c-binding.def"
default:
@@ -6481,13 +6481,15 @@ import_iso_c_binding_module (void)
return_type = c_funptr->n.sym; \
else \
return_type = NULL; \
- create_intrinsic_function (b, a, iso_c_module_name, \
+ create_intrinsic_function (gfc_get_string ("%s", b), \
+ a, iso_c_module_name, \
INTMOD_ISO_C_BINDING, false, \
return_type); \
break;
#define NAMED_SUBROUTINE(a,b,c,d) \
case a: \
- create_intrinsic_function (b, a, iso_c_module_name, \
+ create_intrinsic_function (gfc_get_string ("%s", b), \
+ a, iso_c_module_name, \
INTMOD_ISO_C_BINDING, true, NULL); \
break;
#include "iso-c-binding.def"
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index cc9d4e3f9d8..ce134d2b441 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -4985,7 +4985,8 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
tmp_comp->ts.f90_type = BT_INTEGER;

/* The kinds for c_ptr and c_funptr are the same. */
- index = get_c_kind ("c_ptr", c_interop_kinds_table);
+ index = get_c_kind (gfc_get_string ("%s", "c_ptr"),
+ c_interop_kinds_table);
tmp_comp->ts.kind = c_interop_kinds_table[index].value;
tmp_comp->attr.access = ACCESS_PRIVATE;

diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 46f6d8c03a6..deb9993b0e3 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -360,45 +360,45 @@ gfc_init_c_interop_kinds (void)
for (i = 0; i < ISOCBINDING_NUMBER; i++)
{
/* Initialize the name and value fields. */
- c_interop_kinds_table[i].name[0] = '\0';
+ c_interop_kinds_table[i].name = NULL;
c_interop_kinds_table[i].value = -100;
c_interop_kinds_table[i].f90_type = BT_UNKNOWN;
}

#define NAMED_INTCST(a,b,c,d) \
- strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+ c_interop_kinds_table[a].name = gfc_get_string ("%s", b); \
c_interop_kinds_table[a].f90_type = BT_INTEGER; \
c_interop_kinds_table[a].value = c;
#define NAMED_REALCST(a,b,c,d) \
- strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+ c_interop_kinds_table[a].name = gfc_get_string ("%s", b); \
c_interop_kinds_table[a].f90_type = BT_REAL; \
c_interop_kinds_table[a].value = c;
#define NAMED_CMPXCST(a,b,c,d) \
- strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+ c_interop_kinds_table[a].name = gfc_get_string ("%s", b); \
c_interop_kinds_table[a].f90_type = BT_COMPLEX; \
c_interop_kinds_table[a].value = c;
#define NAMED_LOGCST(a,b,c) \
- strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+ c_interop_kinds_table[a].name = gfc_get_string ("%s", b); \
c_interop_kinds_table[a].f90_type = BT_LOGICAL; \
c_interop_kinds_table[a].value = c;
#define NAMED_CHARKNDCST(a,b,c) \
- strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+ c_interop_kinds_table[a].name = gfc_get_string ("%s", b); \
c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
c_interop_kinds_table[a].value = c;
#define NAMED_CHARCST(a,b,c) \
- strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+ c_interop_kinds_table[a].name = gfc_get_string ("%s", b); \
c_interop_kinds_table[a].f90_type = BT_CHARACTER; \
c_interop_kinds_table[a].value = c;
#define DERIVED_TYPE(a,b,c) \
- strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+ c_interop_kinds_table[a].name = gfc_get_string ("%s", b); \
c_interop_kinds_table[a].f90_type = BT_DERIVED; \
c_interop_kinds_table[a].value = c;
#define NAMED_FUNCTION(a,b,c,d) \
- strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+ c_interop_kinds_table[a].name = gfc_get_string ("%s", b); \
c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
c_interop_kinds_table[a].value = c;
#define NAMED_SUBROUTINE(a,b,c,d) \
- strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+ c_interop_kinds_table[a].name = gfc_get_string ("%s", b); \
c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
c_interop_kinds_table[a].value = c;
#include "iso-c-binding.def"

[Bernhard Reutner-Fischer]

From: Bernhard Reutner-Fischer <***@gcc.gnu.org>

gcc/fortran/ChangeLog:

2017-11-23 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* module.c (import_iso_c_binding_module): Use pointer comparison
instead instead of strcmp.
---
gcc/fortran/module.c | 25 ++++++++++---------------
1 file changed, 10 insertions(+), 15 deletions(-)

diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 22d9abb247f..d7bc7fbef1c 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -6269,7 +6269,7 @@ import_iso_c_binding_module (void)
gfc_symbol *mod_sym = NULL, *return_type;
gfc_symtree *mod_symtree = NULL, *tmp_symtree;
gfc_symtree *c_ptr = NULL, *c_funptr = NULL;
- const char *iso_c_module_name = "__iso_c_binding";
+ const char *iso_c_module_name = gfc_get_string ("%s", "__iso_c_binding");
gfc_use_rename *u;
int i;
bool want_c_ptr = false, want_c_funptr = false;
@@ -6291,7 +6291,7 @@ import_iso_c_binding_module (void)

mod_sym->attr.flavor = FL_MODULE;
mod_sym->attr.intrinsic = 1;
- mod_sym->module = gfc_get_string ("%s", iso_c_module_name);
+ mod_sym->module = iso_c_module_name;
mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
}

@@ -6300,27 +6300,22 @@ import_iso_c_binding_module (void)
need C_(FUN)PTR. */
for (u = gfc_rename_list; u; u = u->next)
{
- if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_PTR].name,
- u->use_name) == 0)
+ if (c_interop_kinds_table[ISOCBINDING_NULL_PTR].name == u->use_name)
want_c_ptr = true;
- else if (strcmp (c_interop_kinds_table[ISOCBINDING_LOC].name,
- u->use_name) == 0)
+ else if (c_interop_kinds_table[ISOCBINDING_LOC].name == u->use_name)
want_c_ptr = true;
- else if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_FUNPTR].name,
- u->use_name) == 0)
+ else if (c_interop_kinds_table[ISOCBINDING_NULL_FUNPTR].name ==
+ u->use_name)
want_c_funptr = true;
- else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNLOC].name,
- u->use_name) == 0)
+ else if (c_interop_kinds_table[ISOCBINDING_FUNLOC].name == u->use_name)
want_c_funptr = true;
- else if (strcmp (c_interop_kinds_table[ISOCBINDING_PTR].name,
- u->use_name) == 0)
+ else if (c_interop_kinds_table[ISOCBINDING_PTR].name == u->use_name)
{
c_ptr = generate_isocbinding_symbol (iso_c_module_name,
(iso_c_binding_symbol) ISOCBINDING_PTR,
u->local_name ? u->local_name : u->use_name, NULL, false);
}
- else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNPTR].name,
- u->use_name) == 0)
+ else if (c_interop_kinds_table[ISOCBINDING_FUNPTR].name == u->use_name)
{
c_funptr = generate_isocbinding_symbol (iso_c_module_name,
(iso_c_binding_symbol) ISOCBINDING_FUNPTR,
@@ -6345,7 +6340,7 @@ import_iso_c_binding_module (void)
{
bool found = false;
for (u = gfc_rename_list; u; u = u->next)
- if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
+ if (c_interop_kinds_table[i].name == u->use_name)
{
bool not_in_std;
const char *name;

[Bernhard Reutner-Fischer]

Regstrapped without regressions, ok for trunk stage3 now / next stage1?

gcc/fortran/ChangeLog

2015-11-29 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* trans-types.c (gfc_typenode_for_spec): Commentary typo fix.

Signed-off-by: Bernhard Reutner-Fischer <***@gmail.com>
---
gcc/fortran/trans-types.c | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 6e2b3f1..0ac337e 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1049,7 +1049,7 @@ gfc_get_character_type (int kind, gfc_charlen * cl)
return gfc_get_character_type_len (kind, len);
}

-/* Covert a basic type. This will be an array for character types. */
+/* Convert a basic type. This will be an array for character types. */

tree
gfc_typenode_for_spec (gfc_typespec * spec)

[Steve Kargl]

Post by Bernhard Reutner-Fischer
Regstrapped without regressions, ok for trunk stage3 now / next stage1?
gcc/fortran/ChangeLog
* trans-types.c (gfc_typenode_for_spec): Commentary typo fix.

Patches to fix typographical errors in comments are pre-approved.

[Bernhard Reutner-Fischer]

Post by Steve Kargl

Post by Bernhard Reutner-Fischer
Regstrapped without regressions, ok for trunk stage3 now / next stage1?
gcc/fortran/ChangeLog
* trans-types.c (gfc_typenode_for_spec): Commentary typo fix.

Patches to fix typographical errors in comments are pre-approved.

Ack.

This one applied as r237575

Thanks!

[Bernhard Reutner-Fischer]

gcc/fortran/ChangeLog

2015-11-29 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* gfortran.h (gfc_lookup_function_fuzzy): New declaration.
* resolve.c: Include spellcheck.h.
(lookup_function_fuzzy_find_candidates): New static function.
(lookup_uop_fuzzy_find_candidates): Likewise.
(lookup_uop_fuzzy): Likewise.
(resolve_operator) <INTRINSIC_USER>: Call lookup_uop_fuzzy.
(gfc_lookup_function_fuzzy): New definition.
(resolve_unknown_f): Call gfc_lookup_function_fuzzy.
* interface.c (check_interface0): Likewise.
* symbol.c: Include spellcheck.h.
(lookup_symbol_fuzzy_find_candidates): New static function.
(lookup_symbol_fuzzy): Likewise.
(gfc_set_default_type): Call lookup_symbol_fuzzy.
(lookup_component_fuzzy_find_candidates): New static function.
(lookup_component_fuzzy): Likewise.
(gfc_find_component): Call lookup_component_fuzzy.

gcc/testsuite/ChangeLog

2015-11-29 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* gfortran.dg/spellcheck-operator.f90: New testcase.
* gfortran.dg/spellcheck-procedure.f90: New testcase.
* gfortran.dg/spellcheck-structure.f90: New testcase.

---

David Malcolm nice Levenshtein distance spelling check helpers
were used in some parts of other frontends. This proposed patch adds
some spelling corrections to the fortran frontend.

Suggestions are printed if we can find a suitable name, currently
perusing a very simple cutoff factor:
/* If more than half of the letters were misspelled, the suggestion is
likely to be meaningless. */
cutoff = MAX (strlen (typo), strlen (best_guess)) / 2;
which effectively skips names with less than 4 characters.
For e.g. structures, one could try to be much smarter in an attempt to
also provide suggestions for single-letter members/components.

This patch covers (at least partly):
- user-defined operators
- structures (types and their components)
- functions
- symbols (variables)

I do not immediately see how to handle subroutines. Ideas?

If anybody has a testcase where a spelling-suggestion would make sense
then please pass it along so we maybe can add support for GCC-7.

Signed-off-by: Bernhard Reutner-Fischer <***@gmail.com>
---
gcc/fortran/gfortran.h | 1 +
gcc/fortran/interface.c | 16 ++-
gcc/fortran/resolve.c | 135 ++++++++++++++++++++-
gcc/fortran/symbol.c | 129 +++++++++++++++++++-
gcc/testsuite/gfortran.dg/spellcheck-operator.f90 | 30 +++++
gcc/testsuite/gfortran.dg/spellcheck-procedure.f90 | 41 +++++++
gcc/testsuite/gfortran.dg/spellcheck-structure.f90 | 35 ++++++
7 files changed, 376 insertions(+), 11 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-operator.f90
create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-procedure.f90
create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-structure.f90

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 5487c93..cbfd592 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3060,6 +3060,7 @@ bool gfc_type_is_extensible (gfc_symbol *);
bool gfc_resolve_intrinsic (gfc_symbol *, locus *);
bool gfc_explicit_interface_required (gfc_symbol *, char *, int);
extern int gfc_do_concurrent_flag;
+const char* gfc_lookup_function_fuzzy (const char *, gfc_symtree *);


/* array.c */
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 30cc522..19f800f 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1590,10 +1590,18 @@ check_interface0 (gfc_interface *p, const char *interface_name)
if (p->sym->attr.external)
gfc_error ("Procedure %qs in %s at %L has no explicit interface",
p->sym->name, interface_name, &p->sym->declared_at);
- else
- gfc_error ("Procedure %qs in %s at %L is neither function nor "
- "subroutine", p->sym->name, interface_name,
- &p->sym->declared_at);
+ else {
+ const char *guessed
+ = gfc_lookup_function_fuzzy (p->sym->name, p->sym->ns->sym_root);
+ if (guessed)
+ gfc_error ("Procedure %qs in %s at %L is neither function nor "
+ "subroutine; did you mean %qs?", p->sym->name,
+ interface_name, &p->sym->declared_at, guessed);
+ else
+ gfc_error ("Procedure %qs in %s at %L is neither function nor "
+ "subroutine", p->sym->name, interface_name,
+ &p->sym->declared_at);
+ }
return 1;
}

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 685e3f5..6e1f63c 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -29,6 +29,7 @@ along with GCC; see the file COPYING3. If not see
#include "data.h"
#include "target-memory.h" /* for gfc_simplify_transfer */
#include "constructor.h"
+#include "spellcheck.h"

/* Types used in equivalence statements. */

@@ -2682,6 +2683,61 @@ resolve_specific_f (gfc_expr *expr)
return true;
}

+/* Recursively append candidate SYM to CANDIDATES. */
+
+static void
+lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
+ vec<const char *> *candidates)
+{
+ gfc_symtree *p;
+ for (p = sym->right; p; p = p->right)
+ {
+ lookup_function_fuzzy_find_candidates (p, candidates);
+ if (p->n.sym->ts.type != BT_UNKNOWN)
+ candidates->safe_push (p->name);
+ }
+ for (p = sym->left; p; p = p->left)
+ {
+ lookup_function_fuzzy_find_candidates (p, candidates);
+ if (p->n.sym->ts.type != BT_UNKNOWN)
+ candidates->safe_push (p->name);
+ }
+}
+
+
+/* Lookup function FN fuzzily, taking names in FUN into account. */
+
+const char*
+gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *fun)
+{
+ auto_vec <const char *> candidates;
+ lookup_function_fuzzy_find_candidates (fun, &candidates);
+
+ /* Determine closest match. */
+ int i;
+ const char *name, *best = NULL;
+ edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+
+ FOR_EACH_VEC_ELT (candidates, i, name)
+ {
+ edit_distance_t dist = levenshtein_distance (fn, name);
+ if (dist < best_distance)
+ {
+ best_distance = dist;
+ best = name;
+ }
+ }
+ /* If more than half of the letters were misspelled, the suggestion is
+ likely to be meaningless. */
+ if (best)
+ {
+ unsigned int cutoff = MAX (strlen (fn), strlen (best)) / 2;
+ if (best_distance > cutoff)
+ return NULL;
+ }
+ return best;
+}
+

/* Resolve a procedure call not known to be generic nor specific. */

@@ -2732,8 +2788,15 @@ set_type:

if (ts->type == BT_UNKNOWN)
{
- gfc_error ("Function %qs at %L has no IMPLICIT type",
- sym->name, &expr->where);
+ const char *guessed
+ = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
+ if (guessed)
+ gfc_error ("Function %qs at %L has no IMPLICIT type"
+ "; did you mean %qs?",
+ sym->name, &expr->where, guessed);
+ else
+ gfc_error ("Function %qs at %L has no IMPLICIT type",
+ sym->name, &expr->where);
return false;
}
else
@@ -3504,6 +3567,63 @@ compare_shapes (gfc_expr *op1, gfc_expr *op2)
return t;
}

+/* Recursively append candidate UOP to CANDIDATES. */
+
+static void
+lookup_uop_fuzzy_find_candidates (gfc_symtree *uop,
+ vec<const char *> *candidates)
+{
+ gfc_symtree *p;
+ /* Not sure how to properly filter here. Use all for a start.
+ n.uop.op is NULL for empty interface operators (is that legal?) disregard
+ these as i suppose they don't make terribly sense. */
+ for (p = uop->right; p; p = p->right)
+ {
+ lookup_function_fuzzy_find_candidates (p, candidates);
+ if (p->n.uop->op != NULL)
+ candidates->safe_push (p->name);
+ }
+ for (p = uop->left; p; p = p->left)
+ {
+ lookup_function_fuzzy_find_candidates (p, candidates);
+ if (p->n.uop->op != NULL)
+ candidates->safe_push (p->name);
+ }
+}
+
+/* Lookup user-operator OP fuzzily, taking names in UOP into account. */
+
+static const char*
+lookup_uop_fuzzy (const char *op, gfc_symtree *uop)
+{
+ auto_vec <const char *> candidates;
+ lookup_uop_fuzzy_find_candidates (uop, &candidates);
+
+ /* Determine closest match. */
+ int i;
+ const char *name, *best = NULL;
+ edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+
+ FOR_EACH_VEC_ELT (candidates, i, name)
+ {
+ edit_distance_t dist = levenshtein_distance (op, name);
+ if (dist < best_distance)
+ {
+ best_distance = dist;
+ best = name;
+ }
+ }
+ /* If more than half of the letters were misspelled, the suggestion is
+ likely to be meaningless. */
+ if (best)
+ {
+ unsigned int cutoff = MAX (strlen (op), strlen (best)) / 2;
+ if (best_distance > cutoff)
+ return NULL;
+ }
+ return best;
+}
+

/* Resolve an operator expression node. This can involve replacing the
operation with a user defined function call. */
@@ -3703,7 +3823,16 @@ resolve_operator (gfc_expr *e)

case INTRINSIC_USER:
if (e->value.op.uop->op == NULL)
- sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
+ {
+ const char *name = e->value.op.uop->name;
+ const char *guessed;
+ guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root);
+ if (guessed)
+ sprintf (msg, _("Unknown operator '%s' at %%L; did you mean '%s'?"),
+ name, guessed);
+ else
+ sprintf (msg, _("Unknown operator '%s' at %%L"), name);
+ }
else if (op2 == NULL)
sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
e->value.op.uop->name, gfc_typename (&op1->ts));
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index ff9aff9..212f7d8 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -27,6 +27,7 @@ along with GCC; see the file COPYING3. If not see
#include "parse.h"
#include "match.h"
#include "constructor.h"
+#include "spellcheck.h"


/* Strings for all symbol attributes. We use these for dumping the
@@ -235,6 +236,62 @@ gfc_get_default_type (const char *name, gfc_namespace *ns)
}


+/* Recursively append candidate SYM to CANDIDATES. */
+
+static void
+lookup_symbol_fuzzy_find_candidates (gfc_symtree *sym,
+ vec<const char *> *candidates)
+{
+ gfc_symtree *p;
+ for (p = sym->right; p; p = p->right)
+ {
+ lookup_symbol_fuzzy_find_candidates (p, candidates);
+ if (p->n.sym->ts.type != BT_UNKNOWN)
+ candidates->safe_push (p->name);
+ }
+ for (p = sym->left; p; p = p->left)
+ {
+ lookup_symbol_fuzzy_find_candidates (p, candidates);
+ if (p->n.sym->ts.type != BT_UNKNOWN)
+ candidates->safe_push (p->name);
+ }
+}
+
+
+/* Lookup symbol SYM fuzzily, taking names in SYMBOL into account. */
+
+static const char*
+lookup_symbol_fuzzy (const char *sym, gfc_symbol *symbol)
+{
+ auto_vec <const char *> candidates;
+ lookup_symbol_fuzzy_find_candidates (symbol->ns->sym_root, &candidates);
+
+ /* Determine closest match. */
+ int i;
+ const char *name, *best = NULL;
+ edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+
+ FOR_EACH_VEC_ELT (candidates, i, name)
+ {
+ edit_distance_t dist = levenshtein_distance (sym, name);
+ if (dist < best_distance)
+ {
+ best_distance = dist;
+ best = name;
+ }
+ }
+ /* If more than half of the letters were misspelled, the suggestion is
+ likely to be meaningless. */
+ if (best)
+ {
+ unsigned int cutoff = MAX (strlen (sym), strlen (best)) / 2;
+ if (best_distance > cutoff)
+ return NULL;
+ }
+ return best;
+}
+
+
/* Given a pointer to a symbol, set its type according to the first
letter of its name. Fails if the letter in question has no default
type. */
@@ -253,8 +310,15 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
{
if (error_flag && !sym->attr.untyped)
{
- gfc_error ("Symbol %qs at %L has no IMPLICIT type",
- sym->name, &sym->declared_at);
+ const char *guessed
+ = lookup_symbol_fuzzy (sym->name, sym);
+ if (guessed)
+ gfc_error ("Symbol %qs at %L has no IMPLICIT type"
+ "; did you mean %qs?",
+ sym->name, &sym->declared_at, guessed);
+ else
+ gfc_error ("Symbol %qs at %L has no IMPLICIT type",
+ sym->name, &sym->declared_at);
sym->attr.untyped = 1; /* Ensure we only give an error once. */
}

@@ -2188,6 +2252,55 @@ bad:
}


+/* Recursively append candidate COMPONENT structures to CANDIDATES. */
+
+static void
+lookup_component_fuzzy_find_candidates (gfc_component *component,
+ vec<const char *> *candidates)
+{
+ for (gfc_component *p = component; p; p = p->next)
+ {
+ if (00 && p->ts.type == BT_DERIVED)
+ /* ??? There's no (suitable) DERIVED_TYPE which would come in
+ handy throughout the frontend; Use CLASS_DATA here for brevity. */
+ lookup_component_fuzzy_find_candidates (CLASS_DATA (p), candidates);
+ candidates->safe_push (p->name);
+ }
+}
+
+/* Lookup component MEMBER fuzzily, taking names in COMPONENT into account. */
+
+static const char*
+lookup_component_fuzzy (const char *member, gfc_component *component)
+{
+ auto_vec <const char *> candidates;
+ lookup_component_fuzzy_find_candidates (component, &candidates);
+
+ /* Determine closest match. */
+ int i;
+ const char *name, *best = NULL;
+ edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+
+ FOR_EACH_VEC_ELT (candidates, i, name)
+ {
+ edit_distance_t dist = levenshtein_distance (member, name);
+ if (dist < best_distance)
+ {
+ best_distance = dist;
+ best = name;
+ }
+ }
+ /* If more than half of the letters were misspelled, the suggestion is
+ likely to be meaningless. */
+ if (best)
+ {
+ unsigned int cutoff = MAX (strlen (member), strlen (best)) / 2;
+ if (best_distance > cutoff)
+ return NULL;
+ }
+ return best;
+}
+
/* Given a derived type node and a component name, try to locate the
component structure. Returns the NULL pointer if the component is
not found or the components are private. If noaccess is set, no access
@@ -2238,8 +2351,16 @@ gfc_find_component (gfc_symbol *sym, const char *name,
}

if (p == NULL && !silent)
- gfc_error ("%qs at %C is not a member of the %qs structure",
- name, sym->name);
+ {
+ const char *guessed = lookup_component_fuzzy (name, sym->components);
+ if (guessed)
+ gfc_error ("%qs at %C is not a member of the %qs structure"
+ "; did you mean %qs?",
+ name, sym->name, guessed);
+ else
+ gfc_error ("%qs at %C is not a member of the %qs structure",
+ name, sym->name);
+ }

return p;
}
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-operator.f90 b/gcc/testsuite/gfortran.dg/spellcheck-operator.f90
new file mode 100644
index 0000000..810a770
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-operator.f90
@@ -0,0 +1,30 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+module mymod1
+ implicit none
+ contains
+ function something_good (iarg1)
+ integer :: something_good
+ integer, intent(in) :: iarg1
+ something_good = iarg1 + 42
+ end function something_good
+end module mymod1
+
+program spellchekc
+ use mymod1
+ implicit none
+
+ interface operator (.mywrong.)
+ module procedure something_wring ! { dg-error "Procedure .something_wring. in operator interface .mywrong. at .1. is neither function nor subroutine; did you mean .something_good.\\?|User operator procedure .something_wring. at .1. must be a FUNCTION" }
+ end interface
+
+ interface operator (.mygood.)
+ module procedure something_good
+ end interface
+
+ integer :: i, j, added
+ i = 0
+ j = 0
+ added = .mygoof. j ! { dg-error "Unknown operator .mygoof. at .1.; did you mean .mygood.\\?" }
+end program spellchekc
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-procedure.f90 b/gcc/testsuite/gfortran.dg/spellcheck-procedure.f90
new file mode 100644
index 0000000..7923081
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-procedure.f90
@@ -0,0 +1,41 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+module mymod1
+ implicit none
+ contains
+ function something_good (iarg1)
+ integer :: something_good
+ integer, intent(in) :: iarg1
+ something_good = iarg1 + 42
+ end function something_good
+end module mymod1
+
+subroutine bark_unless_zero(iarg)
+ implicit none
+ integer, intent(in) :: iarg
+ if (iarg /= 0) call abort
+end subroutine bark_unless_zero
+
+function myadd(iarg1, iarg2)
+ implicit none
+ integer :: myadd
+ integer, intent(in) :: iarg1, iarg2
+ myadd = iarg1 + iarg2
+end function myadd
+
+program spellchekc
+ use mymod1
+ implicit none
+
+ integer :: i, j, myadd
+ i = 0
+ j = 0
+! I suppose this cannot be made to work, no\\?
+! call barf_unless_zero(i) ! { -dg-error "; did you mean .bark_unless_zero.\\?" }
+ j = something_goof(j) ! { dg-error "no IMPLICIT type; did you mean .something_good.\\?" }
+ j = myaddd(i, j) ! { dg-error "no IMPLICIT type; did you mean .myadd.\\?" }
+ j = mya(i, j) ! { dg-error "no IMPLICIT type; did you mean .myadd.\\?" }
+ if (j /= 42) call abort
+
+end program spellchekc
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-structure.f90 b/gcc/testsuite/gfortran.dg/spellcheck-structure.f90
new file mode 100644
index 0000000..929e05f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-structure.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+implicit none
+
+!!!!!!!!!!!!!! structure tests !!!!!!!!!!!!!!
+type type1
+ real :: radius
+ integer :: i
+end type type1
+
+type type2
+ integer :: myint
+ type(type1) :: mytype
+end type type2
+
+type type3
+ type(type2) :: type_2
+end type type3
+type type4
+ type(type3) :: type_3
+end type type4
+
+type(type1) :: t1
+t1%radiuz = .0 ! { dg-error ".radiuz. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+t1%x = .0 ! { dg-error ".x. at .1. is not a member of the .type1. structure" }
+type(type2) :: t2
+t2%mytape%radius = .0 ! { dg-error ".mytape. at .1. is not a member of the .type2. structure; did you mean .mytype.\\?" }
+t2%mytype%radious = .0 ! { dg-error ".radious. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+type(type4) :: t4
+t4%type_3%type_2%mytype%radium = 88.0 ! { dg-error ".radium. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+
+!!!!!!!!!!!!!! symbol tests !!!!!!!!!!!!!!
+integer :: iarg1
+iarg2 = 1 ! { dg-error "Symbol .iarg2. at .1. has no IMPLICIT type; did you mean .iarg1.\\?" }
+end

[Steve Kargl]

Post by Bernhard Reutner-Fischer
David Malcolm nice Levenshtein distance spelling check helpers
were used in some parts of other frontends. This proposed patch adds
some spelling corrections to the fortran frontend.
Suggestions are printed if we can find a suitable name, currently
/* If more than half of the letters were misspelled, the suggestion is
likely to be meaningless. */
cutoff = MAX (strlen (typo), strlen (best_guess)) / 2;
which effectively skips names with less than 4 characters.
For e.g. structures, one could try to be much smarter in an attempt to
also provide suggestions for single-letter members/components.
- user-defined operators
- structures (types and their components)
- functions
- symbols (variables)
I do not immediately see how to handle subroutines. Ideas?
If anybody has a testcase where a spelling-suggestion would make sense
then please pass it along so we maybe can add support for GCC-7.

What problem are you trying to solve here? The patch looks like
unneeded complexity with the result of injecting C++ idioms into
the Fortran FE.

[Bernhard Reutner-Fischer]

On 1 December 2015 at 16:01, Steve Kargl

Post by Steve Kargl

Post by Bernhard Reutner-Fischer
David Malcolm nice Levenshtein distance spelling check helpers
were used in some parts of other frontends. This proposed patch adds
some spelling corrections to the fortran frontend.

What problem are you trying to solve here? The patch looks like

The idea is to improve the programmer experience when writing code.
See the testcases enclosed in the patch. I consider this a feature :)

Post by Steve Kargl
unneeded complexity with the result of injecting C++ idioms into
the Fortran FE.

What C++ idioms are you referring to? The autovec?
AFAIU the light use of C++ in GCC is deemed OK. I see usage of
std::swap and std::map in the FE, not to mention the wide-int uses
(wi::). Thus we don't have to realloc/strcat but can use vectors to
the same effect, just as other frontends, including the C frontend,
do.
I take it you remember that we had to change all "try" to something
C++ friendly. If the Fortran FE meant to opt-out of being compiled
with a C++ compiler in the first place, why were all the C++ clashes
rewritten, back then? :)

thanks,

[Steve Kargl]

Post by Bernhard Reutner-Fischer
On 1 December 2015 at 16:01, Steve Kargl

Post by Steve Kargl

Post by Bernhard Reutner-Fischer
David Malcolm nice Levenshtein distance spelling check helpers
were used in some parts of other frontends. This proposed patch adds
some spelling corrections to the fortran frontend.

What problem are you trying to solve here? The patch looks like

The idea is to improve the programmer experience when writing code.
See the testcases enclosed in the patch. I consider this a feature :)

Opinions differ. I consider it unnecessary bloat.

Post by Bernhard Reutner-Fischer

Post by Steve Kargl
unneeded complexity with the result of injecting C++ idioms into
the Fortran FE.

What C++ idioms are you referring to? The autovec?
AFAIU the light use of C++ in GCC is deemed OK. I see usage of
std::swap and std::map in the FE, not to mention the wide-int uses
(wi::). Thus we don't have to realloc/strcat but can use vectors to
the same effect, just as other frontends, including the C frontend,
do.
I take it you remember that we had to change all "try" to something
C++ friendly. If the Fortran FE meant to opt-out of being compiled
with a C++ compiler in the first place, why were all the C++ clashes
rewritten, back then? :)

Yes, I know there are other C++ (mis)features within the
Fortran FE especially in the trans-*.c files. Those are
accepted (by some) as necessary evils to interface with
the ME. Your patch injects C++ into otherwise perfectly
fine C code, which makes it more difficult for those with
no or very limited C++ knowledge to maintain the gfortran.

There are currently 806 open bug reports for gfortran.
AFAIK, your patch does not address any of those bug reports.
The continued push to inject C++ into the Fortran FE will
have the (un)intentional consequence of forcing at least one
active gfortran contributor to stop.

--
Steve

[Bernhard Reutner-Fischer]

On 1 December 2015 at 17:41, Steve Kargl

Post by Steve Kargl

Post by Bernhard Reutner-Fischer
On 1 December 2015 at 16:01, Steve Kargl

Post by Steve Kargl

Post by Bernhard Reutner-Fischer
David Malcolm nice Levenshtein distance spelling check helpers
were used in some parts of other frontends. This proposed patch adds
some spelling corrections to the fortran frontend.

What problem are you trying to solve here? The patch looks like

The idea is to improve the programmer experience when writing code.
See the testcases enclosed in the patch. I consider this a feature :)

Opinions differ. I consider it unnecessary bloat.

Fair enough.
I fully agree that it's bloat.

The compiler is so tremendously bloated by now anyway that i consider
these couple of kilobyte to have a nice bloat/user friendliness
factor, overall ;)
I can imagine that people code their fortran programs in an IDE (the
bloated variant of an editor, mine is ~20518 bytes of text, no data,
no bss) and IDEs will sooner or later support fixit-hints. Even the
console/terminal users might enjoy to safe them a cycle of opening a
different file, looking up the type/module/etc name and then going
back to the source-file to correct their typo. *I* would welcome that
sometimes for sure :)

Post by Steve Kargl

Post by Bernhard Reutner-Fischer

Post by Steve Kargl
unneeded complexity with the result of injecting C++ idioms into
the Fortran FE.

What C++ idioms are you referring to? The autovec?
AFAIU the light use of C++ in GCC is deemed OK. I see usage of
std::swap and std::map in the FE, not to mention the wide-int uses
(wi::). Thus we don't have to realloc/strcat but can use vectors to
the same effect, just as other frontends, including the C frontend,
do.
I take it you remember that we had to change all "try" to something
C++ friendly. If the Fortran FE meant to opt-out of being compiled
with a C++ compiler in the first place, why were all the C++ clashes
rewritten, back then? :)

Yes, I know there are other C++ (mis)features within the
Fortran FE especially in the trans-*.c files. Those are
accepted (by some) as necessary evils to interface with
the ME. Your patch injects C++ into otherwise perfectly
fine C code, which makes it more difficult for those with
no or very limited C++ knowledge to maintain the gfortran.

So you're in favour of using realloc and strcat, ok. I can use that.
Let me see if ipa-icf can replace all the identical tails of the
lookup_*_fuzzy into a common helper.
Shouldn't rely on LTO anyway nor ipa-icf i suppose.

Post by Steve Kargl
There are currently 806 open bug reports for gfortran.
AFAIK, your patch does not address any of those bug reports.

I admit i didn't look..

Post by Steve Kargl
The continued push to inject C++ into the Fortran FE will
have the (un)intentional consequence of forcing at least one
active gfortran contributor to stop.

That was not my intention for sure.

cheers,

[Steve Kargl]

Post by Bernhard Reutner-Fischer
On 1 December 2015 at 17:41, Steve Kargl

Post by Steve Kargl
Yes, I know there are other C++ (mis)features within the
Fortran FE especially in the trans-*.c files. Those are
accepted (by some) as necessary evils to interface with
the ME. Your patch injects C++ into otherwise perfectly
fine C code, which makes it more difficult for those with
no or very limited C++ knowledge to maintain the gfortran.

So you're in favour of using realloc and strcat, ok. I can use that.
Let me see if ipa-icf can replace all the identical tails of the
lookup_*_fuzzy into a common helper.
Shouldn't rely on LTO anyway nor ipa-icf i suppose.

Yes, I would prefer it, but certainly won't demand it.
There are other Fortran contributors/maintainers. They
may prefer you approach, so give them time to speak up.

[David Malcolm]

Post by Bernhard Reutner-Fischer
gcc/fortran/ChangeLog
* gfortran.h (gfc_lookup_function_fuzzy): New declaration.
* resolve.c: Include spellcheck.h.
(lookup_function_fuzzy_find_candidates): New static function.
(lookup_uop_fuzzy_find_candidates): Likewise.
(lookup_uop_fuzzy): Likewise.
(resolve_operator) <INTRINSIC_USER>: Call lookup_uop_fuzzy.
(gfc_lookup_function_fuzzy): New definition.
(resolve_unknown_f): Call gfc_lookup_function_fuzzy.
* interface.c (check_interface0): Likewise.
* symbol.c: Include spellcheck.h.
(lookup_symbol_fuzzy_find_candidates): New static function.
(lookup_symbol_fuzzy): Likewise.
(gfc_set_default_type): Call lookup_symbol_fuzzy.
(lookup_component_fuzzy_find_candidates): New static function.
(lookup_component_fuzzy): Likewise.
(gfc_find_component): Call lookup_component_fuzzy.
gcc/testsuite/ChangeLog
* gfortran.dg/spellcheck-operator.f90: New testcase.
* gfortran.dg/spellcheck-procedure.f90: New testcase.
* gfortran.dg/spellcheck-structure.f90: New testcase.
---
David Malcolm nice Levenshtein distance spelling check helpers
were used in some parts of other frontends. This proposed patch adds
some spelling corrections to the fortran frontend.
Suggestions are printed if we can find a suitable name, currently
/* If more than half of the letters were misspelled, the suggestion is
likely to be meaningless. */
cutoff = MAX (strlen (typo), strlen (best_guess)) / 2;
which effectively skips names with less than 4 characters.
For e.g. structures, one could try to be much smarter in an attempt to
also provide suggestions for single-letter members/components.
- user-defined operators
- structures (types and their components)
- functions
- symbols (variables)
I do not immediately see how to handle subroutines. Ideas?
If anybody has a testcase where a spelling-suggestion would make sense
then please pass it along so we maybe can add support for GCC-7.
---
gcc/fortran/gfortran.h | 1 +
gcc/fortran/interface.c | 16 ++-
gcc/fortran/resolve.c | 135 ++++++++++++++++++++-
gcc/fortran/symbol.c | 129 +++++++++++++++++++-
gcc/testsuite/gfortran.dg/spellcheck-operator.f90 | 30 +++++
gcc/testsuite/gfortran.dg/spellcheck-procedure.f90 | 41 +++++++
gcc/testsuite/gfortran.dg/spellcheck-structure.f90 | 35 ++++++
7 files changed, 376 insertions(+), 11 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-operator.f90
create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-procedure.f90
create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-structure.f90
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 5487c93..cbfd592 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3060,6 +3060,7 @@ bool gfc_type_is_extensible (gfc_symbol *);
bool gfc_resolve_intrinsic (gfc_symbol *, locus *);
bool gfc_explicit_interface_required (gfc_symbol *, char *, int);
extern int gfc_do_concurrent_flag;
+const char* gfc_lookup_function_fuzzy (const char *, gfc_symtree *);
/* array.c */
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 30cc522..19f800f 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1590,10 +1590,18 @@ check_interface0 (gfc_interface *p, const char *interface_name)
if (p->sym->attr.external)
gfc_error ("Procedure %qs in %s at %L has no explicit interface",
p->sym->name, interface_name, &p->sym->declared_at);
- else
- gfc_error ("Procedure %qs in %s at %L is neither function nor "
- "subroutine", p->sym->name, interface_name,
- &p->sym->declared_at);
+ else {
+ const char *guessed
+ = gfc_lookup_function_fuzzy (p->sym->name, p->sym->ns->sym_root);
+ if (guessed)
+ gfc_error ("Procedure %qs in %s at %L is neither function nor "
+ "subroutine; did you mean %qs?", p->sym->name,
+ interface_name, &p->sym->declared_at, guessed);
+ else
+ gfc_error ("Procedure %qs in %s at %L is neither function nor "
+ "subroutine", p->sym->name, interface_name,
+ &p->sym->declared_at);
+ }
return 1;
}
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 685e3f5..6e1f63c 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -29,6 +29,7 @@ along with GCC; see the file COPYING3. If not see
#include "data.h"
#include "target-memory.h" /* for gfc_simplify_transfer */
#include "constructor.h"
+#include "spellcheck.h"
/* Types used in equivalence statements. */
@@ -2682,6 +2683,61 @@ resolve_specific_f (gfc_expr *expr)
return true;
}
+/* Recursively append candidate SYM to CANDIDATES. */
+
+static void
+lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
+ vec<const char *> *candidates)
+{
+ gfc_symtree *p;
+ for (p = sym->right; p; p = p->right)
+ {
+ lookup_function_fuzzy_find_candidates (p, candidates);
+ if (p->n.sym->ts.type != BT_UNKNOWN)
+ candidates->safe_push (p->name);
+ }
+ for (p = sym->left; p; p = p->left)
+ {
+ lookup_function_fuzzy_find_candidates (p, candidates);
+ if (p->n.sym->ts.type != BT_UNKNOWN)
+ candidates->safe_push (p->name);
+ }
+}
+
+
+/* Lookup function FN fuzzily, taking names in FUN into account. */
+
+const char*
+gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *fun)
+{
+ auto_vec <const char *> candidates;
+ lookup_function_fuzzy_find_candidates (fun, &candidates);
+
+ /* Determine closest match. */
+ int i;
+ const char *name, *best = NULL;
+ edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+
+ FOR_EACH_VEC_ELT (candidates, i, name)
+ {
+ edit_distance_t dist = levenshtein_distance (fn, name);
+ if (dist < best_distance)
+ {
+ best_distance = dist;
+ best = name;
+ }
+ }
+ /* If more than half of the letters were misspelled, the suggestion is
+ likely to be meaningless. */
+ if (best)
+ {
+ unsigned int cutoff = MAX (strlen (fn), strlen (best)) / 2;
+ if (best_distance > cutoff)
+ return NULL;
+ }
+ return best;
+}

Caveat: I'm not very familiar with the Fortran FE, so take the following
with a pinch of salt.

If I'm reading things right, here, and in various other places, you're
building a vec of const char *, and then seeing which one of those
candidates is the best match for another const char *.

You could simplify things by adding a helper function to spellcheck.h,
akin to this one:

extern tree
find_closest_identifier (tree target, const auto_vec<tree> *candidates);

This would reduce the amount of duplication in the patch (and slightly
reduce the amount of C++).

[are there IDENTIFIER nodes in the Fortran FE, or is it all const char
*? this would avoid some strlen calls]

Post by Bernhard Reutner-Fischer
/* Resolve a procedure call not known to be generic nor specific. */
if (ts->type == BT_UNKNOWN)
{
- gfc_error ("Function %qs at %L has no IMPLICIT type",
- sym->name, &expr->where);
+ const char *guessed
+ = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
+ if (guessed)
+ gfc_error ("Function %qs at %L has no IMPLICIT type"
+ "; did you mean %qs?",
+ sym->name, &expr->where, guessed);
+ else
+ gfc_error ("Function %qs at %L has no IMPLICIT type",
+ sym->name, &expr->where);
return false;
}
else
@@ -3504,6 +3567,63 @@ compare_shapes (gfc_expr *op1, gfc_expr *op2)
return t;
}
+/* Recursively append candidate UOP to CANDIDATES. */
+
+static void
+lookup_uop_fuzzy_find_candidates (gfc_symtree *uop,
+ vec<const char *> *candidates)
+{
+ gfc_symtree *p;
+ /* Not sure how to properly filter here. Use all for a start.
+ n.uop.op is NULL for empty interface operators (is that legal?) disregard
+ these as i suppose they don't make terribly sense. */
+ for (p = uop->right; p; p = p->right)
+ {
+ lookup_function_fuzzy_find_candidates (p, candidates);
+ if (p->n.uop->op != NULL)
+ candidates->safe_push (p->name);
+ }
+ for (p = uop->left; p; p = p->left)
+ {
+ lookup_function_fuzzy_find_candidates (p, candidates);
+ if (p->n.uop->op != NULL)
+ candidates->safe_push (p->name);
+ }
+}
+
+/* Lookup user-operator OP fuzzily, taking names in UOP into account. */
+
+static const char*
+lookup_uop_fuzzy (const char *op, gfc_symtree *uop)
+{
+ auto_vec <const char *> candidates;
+ lookup_uop_fuzzy_find_candidates (uop, &candidates);
+
+ /* Determine closest match. */
+ int i;
+ const char *name, *best = NULL;
+ edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+
+ FOR_EACH_VEC_ELT (candidates, i, name)
+ {
+ edit_distance_t dist = levenshtein_distance (op, name);
+ if (dist < best_distance)
+ {
+ best_distance = dist;
+ best = name;
+ }
+ }
+ /* If more than half of the letters were misspelled, the suggestion is
+ likely to be meaningless. */
+ if (best)
+ {
+ unsigned int cutoff = MAX (strlen (op), strlen (best)) / 2;
+ if (best_distance > cutoff)
+ return NULL;
+ }
+ return best;
+}

Here again, I think.

Post by Bernhard Reutner-Fischer
/* Resolve an operator expression node. This can involve replacing the
operation with a user defined function call. */
@@ -3703,7 +3823,16 @@ resolve_operator (gfc_expr *e)
if (e->value.op.uop->op == NULL)
- sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
+ {
+ const char *name = e->value.op.uop->name;
+ const char *guessed;
+ guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root);
+ if (guessed)
+ sprintf (msg, _("Unknown operator '%s' at %%L; did you mean '%s'?"),
+ name, guessed);
+ else
+ sprintf (msg, _("Unknown operator '%s' at %%L"), name);
+ }
else if (op2 == NULL)
sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
e->value.op.uop->name, gfc_typename (&op1->ts));
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index ff9aff9..212f7d8 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -27,6 +27,7 @@ along with GCC; see the file COPYING3. If not see
#include "parse.h"
#include "match.h"
#include "constructor.h"
+#include "spellcheck.h"
/* Strings for all symbol attributes. We use these for dumping the
@@ -235,6 +236,62 @@ gfc_get_default_type (const char *name, gfc_namespace *ns)
}
+/* Recursively append candidate SYM to CANDIDATES. */
+
+static void
+lookup_symbol_fuzzy_find_candidates (gfc_symtree *sym,
+ vec<const char *> *candidates)
+{
+ gfc_symtree *p;
+ for (p = sym->right; p; p = p->right)
+ {
+ lookup_symbol_fuzzy_find_candidates (p, candidates);
+ if (p->n.sym->ts.type != BT_UNKNOWN)
+ candidates->safe_push (p->name);
+ }
+ for (p = sym->left; p; p = p->left)
+ {
+ lookup_symbol_fuzzy_find_candidates (p, candidates);
+ if (p->n.sym->ts.type != BT_UNKNOWN)
+ candidates->safe_push (p->name);
+ }
+}
+
+
+/* Lookup symbol SYM fuzzily, taking names in SYMBOL into account. */
+
+static const char*
+lookup_symbol_fuzzy (const char *sym, gfc_symbol *symbol)
+{
+ auto_vec <const char *> candidates;
+ lookup_symbol_fuzzy_find_candidates (symbol->ns->sym_root, &candidates);
+
+ /* Determine closest match. */
+ int i;
+ const char *name, *best = NULL;
+ edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+
+ FOR_EACH_VEC_ELT (candidates, i, name)
+ {
+ edit_distance_t dist = levenshtein_distance (sym, name);
+ if (dist < best_distance)
+ {
+ best_distance = dist;
+ best = name;
+ }
+ }
+ /* If more than half of the letters were misspelled, the suggestion is
+ likely to be meaningless. */
+ if (best)
+ {
+ unsigned int cutoff = MAX (strlen (sym), strlen (best)) / 2;
+ if (best_distance > cutoff)
+ return NULL;
+ }
+ return best;
+}

Here again, I think.

Post by Bernhard Reutner-Fischer
+
/* Given a pointer to a symbol, set its type according to the first
letter of its name. Fails if the letter in question has no default
type. */
@@ -253,8 +310,15 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
{
if (error_flag && !sym->attr.untyped)
{
- gfc_error ("Symbol %qs at %L has no IMPLICIT type",
- sym->name, &sym->declared_at);
+ const char *guessed
+ = lookup_symbol_fuzzy (sym->name, sym);
+ if (guessed)
+ gfc_error ("Symbol %qs at %L has no IMPLICIT type"
+ "; did you mean %qs?",
+ sym->name, &sym->declared_at, guessed);
+ else
+ gfc_error ("Symbol %qs at %L has no IMPLICIT type",
+ sym->name, &sym->declared_at);
sym->attr.untyped = 1; /* Ensure we only give an error once. */
}
}
+/* Recursively append candidate COMPONENT structures to CANDIDATES. */
+
+static void
+lookup_component_fuzzy_find_candidates (gfc_component *component,
+ vec<const char *> *candidates)
+{
+ for (gfc_component *p = component; p; p = p->next)
+ {
+ if (00 && p->ts.type == BT_DERIVED)
+ /* ??? There's no (suitable) DERIVED_TYPE which would come in
+ handy throughout the frontend; Use CLASS_DATA here for brevity. */
+ lookup_component_fuzzy_find_candidates (CLASS_DATA (p), candidates);
+ candidates->safe_push (p->name);
+ }
+}
+
+/* Lookup component MEMBER fuzzily, taking names in COMPONENT into account. */
+
+static const char*
+lookup_component_fuzzy (const char *member, gfc_component *component)
+{
+ auto_vec <const char *> candidates;
+ lookup_component_fuzzy_find_candidates (component, &candidates);
+
+ /* Determine closest match. */
+ int i;
+ const char *name, *best = NULL;
+ edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+
+ FOR_EACH_VEC_ELT (candidates, i, name)
+ {
+ edit_distance_t dist = levenshtein_distance (member, name);
+ if (dist < best_distance)
+ {
+ best_distance = dist;
+ best = name;
+ }
+ }
+ /* If more than half of the letters were misspelled, the suggestion is
+ likely to be meaningless. */
+ if (best)
+ {
+ unsigned int cutoff = MAX (strlen (member), strlen (best)) / 2;
+ if (best_distance > cutoff)
+ return NULL;
+ }
+ return best;
+}

...and here again.

Post by Bernhard Reutner-Fischer
/* Given a derived type node and a component name, try to locate the
component structure. Returns the NULL pointer if the component is
not found or the components are private. If noaccess is set, no access
@@ -2238,8 +2351,16 @@ gfc_find_component (gfc_symbol *sym, const char *name,
}
if (p == NULL && !silent)
- gfc_error ("%qs at %C is not a member of the %qs structure",
- name, sym->name);
+ {
+ const char *guessed = lookup_component_fuzzy (name, sym->components);
+ if (guessed)
+ gfc_error ("%qs at %C is not a member of the %qs structure"
+ "; did you mean %qs?",
+ name, sym->name, guessed);
+ else
+ gfc_error ("%qs at %C is not a member of the %qs structure",
+ name, sym->name);
+ }
return p;
}
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-operator.f90 b/gcc/testsuite/gfortran.dg/spellcheck-operator.f90
new file mode 100644
index 0000000..810a770
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-operator.f90
@@ -0,0 +1,30 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+module mymod1
+ implicit none
+ contains
+ function something_good (iarg1)
+ integer :: something_good
+ integer, intent(in) :: iarg1
+ something_good = iarg1 + 42
+ end function something_good
+end module mymod1
+
+program spellchekc
+ use mymod1
+ implicit none
+
+ interface operator (.mywrong.)
+ module procedure something_wring ! { dg-error "Procedure .something_wring. in operator interface .mywrong. at .1. is neither function nor subroutine; did you mean .something_good.\\?|User operator procedure .something_wring. at .1. must be a FUNCTION" }
+ end interface
+
+ interface operator (.mygood.)
+ module procedure something_good
+ end interface
+
+ integer :: i, j, added
+ i = 0
+ j = 0
+ added = .mygoof. j ! { dg-error "Unknown operator .mygoof. at .1.; did you mean .mygood.\\?" }
+end program spellchekc
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-procedure.f90 b/gcc/testsuite/gfortran.dg/spellcheck-procedure.f90
new file mode 100644
index 0000000..7923081
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-procedure.f90
@@ -0,0 +1,41 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+module mymod1
+ implicit none
+ contains
+ function something_good (iarg1)
+ integer :: something_good
+ integer, intent(in) :: iarg1
+ something_good = iarg1 + 42
+ end function something_good
+end module mymod1
+
+subroutine bark_unless_zero(iarg)
+ implicit none
+ integer, intent(in) :: iarg
+ if (iarg /= 0) call abort
+end subroutine bark_unless_zero
+
+function myadd(iarg1, iarg2)
+ implicit none
+ integer :: myadd
+ integer, intent(in) :: iarg1, iarg2
+ myadd = iarg1 + iarg2
+end function myadd
+
+program spellchekc
+ use mymod1
+ implicit none
+
+ integer :: i, j, myadd
+ i = 0
+ j = 0
+! I suppose this cannot be made to work, no\\?
+! call barf_unless_zero(i) ! { -dg-error "; did you mean .bark_unless_zero.\\?" }
+ j = something_goof(j) ! { dg-error "no IMPLICIT type; did you mean .something_good.\\?" }
+ j = myaddd(i, j) ! { dg-error "no IMPLICIT type; did you mean .myadd.\\?" }
+ j = mya(i, j) ! { dg-error "no IMPLICIT type; did you mean .myadd.\\?" }
+ if (j /= 42) call abort
+
+end program spellchekc
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-structure.f90 b/gcc/testsuite/gfortran.dg/spellcheck-structure.f90
new file mode 100644
index 0000000..929e05f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-structure.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+implicit none
+
+!!!!!!!!!!!!!! structure tests !!!!!!!!!!!!!!
+type type1
+ real :: radius
+ integer :: i
+end type type1
+
+type type2
+ integer :: myint
+ type(type1) :: mytype
+end type type2
+
+type type3
+ type(type2) :: type_2
+end type type3
+type type4
+ type(type3) :: type_3
+end type type4
+
+type(type1) :: t1
+t1%radiuz = .0 ! { dg-error ".radiuz. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+t1%x = .0 ! { dg-error ".x. at .1. is not a member of the .type1. structure" }
+type(type2) :: t2
+t2%mytape%radius = .0 ! { dg-error ".mytape. at .1. is not a member of the .type2. structure; did you mean .mytype.\\?" }
+t2%mytype%radious = .0 ! { dg-error ".radious. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+type(type4) :: t4
+t4%type_3%type_2%mytype%radium = 88.0 ! { dg-error ".radium. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+
+!!!!!!!!!!!!!! symbol tests !!!!!!!!!!!!!!
+integer :: iarg1
+iarg2 = 1 ! { dg-error "Symbol .iarg2. at .1. has no IMPLICIT type; did you mean .iarg1.\\?" }
+end

[Bernhard Reutner-Fischer]

Post by David Malcolm

Post by Bernhard Reutner-Fischer
+/* Lookup function FN fuzzily, taking names in FUN into account. */
+
+const char*
+gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *fun)
+{
+ auto_vec <const char *> candidates;
+ lookup_function_fuzzy_find_candidates (fun, &candidates);
+
+ /* Determine closest match. */
+ int i;
+ const char *name, *best = NULL;
+ edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+
+ FOR_EACH_VEC_ELT (candidates, i, name)
+ {
+ edit_distance_t dist = levenshtein_distance (fn, name);
+ if (dist < best_distance)
+ {
+ best_distance = dist;
+ best = name;
+ }
+ }
+ /* If more than half of the letters were misspelled, the suggestion is
+ likely to be meaningless. */
+ if (best)
+ {
+ unsigned int cutoff = MAX (strlen (fn), strlen (best)) / 2;
+ if (best_distance > cutoff)
+ return NULL;
+ }
+ return best;
+}

Caveat: I'm not very familiar with the Fortran FE, so take the following
with a pinch of salt.
If I'm reading things right, here, and in various other places, you're
building a vec of const char *, and then seeing which one of those
candidates is the best match for another const char *.
You could simplify things by adding a helper function to spellcheck.h,
extern tree
find_closest_identifier (tree target, const auto_vec<tree> *candidates);

I was hoping for ipa-icf to fix that up on my behalf. I'll try to see
if it does. Short of that: yes, should do that.

Post by David Malcolm
This would reduce the amount of duplication in the patch (and slightly
reduce the amount of C++).

As said, we could as well use a list of candidates with NULL as record marker.
Implementation cosmetics. Steve seems to not be thrilled by the
overall idea in the first place, so unless there is clear support by
somebody else i won't pursue this any further, it's not that i'm bored
or ran out of stuff i should do.. ;)

Post by David Malcolm
[are there IDENTIFIER nodes in the Fortran FE, or is it all const char
*? this would avoid some strlen calls]

Right, but in the Fortran FE these are const char*.

thanks for your comments!

[David Malcolm]

Post by Bernhard Reutner-Fischer

Post by David Malcolm

Post by Bernhard Reutner-Fischer
+/* Lookup function FN fuzzily, taking names in FUN into account. */
+
+const char*
+gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *fun)
+{
+ auto_vec <const char *> candidates;
+ lookup_function_fuzzy_find_candidates (fun, &candidates);
+
+ /* Determine closest match. */
+ int i;
+ const char *name, *best = NULL;
+ edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+
+ FOR_EACH_VEC_ELT (candidates, i, name)
+ {
+ edit_distance_t dist = levenshtein_distance (fn, name);
+ if (dist < best_distance)
+ {
+ best_distance = dist;
+ best = name;
+ }
+ }
+ /* If more than half of the letters were misspelled, the suggestion is
+ likely to be meaningless. */
+ if (best)
+ {
+ unsigned int cutoff = MAX (strlen (fn), strlen (best)) / 2;
+ if (best_distance > cutoff)
+ return NULL;
+ }
+ return best;
+}

Caveat: I'm not very familiar with the Fortran FE, so take the following
with a pinch of salt.
If I'm reading things right, here, and in various other places, you're
building a vec of const char *, and then seeing which one of those
candidates is the best match for another const char *.
You could simplify things by adding a helper function to spellcheck.h,
extern tree
find_closest_identifier (tree target, const auto_vec<tree> *candidates);

I was hoping for ipa-icf to fix that up on my behalf. I'll try to see
if it does. Short of that: yes, should do that.

I was more thinking about code readability; don't rely on ipa-icf - fix
it in the source.

Post by Bernhard Reutner-Fischer

Post by David Malcolm
This would reduce the amount of duplication in the patch (and slightly
reduce the amount of C++).

As said, we could as well use a list of candidates with NULL as record marker.
Implementation cosmetics. Steve seems to not be thrilled by the
overall idea in the first place, so unless there is clear support by
somebody else i won't pursue this any further, it's not that i'm bored
or ran out of stuff i should do.. ;)

(FWIW I liked the idea, but I'm not a Fortran person so my opinion
counts much less that Steve's)

Post by Bernhard Reutner-Fischer

Post by David Malcolm
[are there IDENTIFIER nodes in the Fortran FE, or is it all const char
*? this would avoid some strlen calls]

Right, but in the Fortran FE these are const char*.
thanks for your comments!

[Steve Kargl]

Post by David Malcolm

Post by Bernhard Reutner-Fischer
As said, we could as well use a list of candidates with NULL as record marker.
Implementation cosmetics. Steve seems to not be thrilled by the
overall idea in the first place, so unless there is clear support by
somebody else i won't pursue this any further, it's not that i'm bored
or ran out of stuff i should do.. ;)

(FWIW I liked the idea, but I'm not a Fortran person so my opinion
counts much less that Steve's)

Your opinion is as valid as mine.

My only concern is code maintenance. Injection of C++ (or any
other language) into C code seems to add possible complications
when something needs to be fix or changed to accommodate a new
Fortran freature.

[Janne Blomqvist]

On Tue, Dec 1, 2015 at 7:51 PM, Bernhard Reutner-Fischer

Post by Bernhard Reutner-Fischer
As said, we could as well use a list of candidates with NULL as record marker.
Implementation cosmetics. Steve seems to not be thrilled by the
overall idea in the first place, so unless there is clear support by
somebody else i won't pursue this any further, it's not that i'm bored
or ran out of stuff i should do.. ;)

FWIW, I think the idea of this patch is quite nice, and I'd like to
see it in the compiler.

I'm personally Ok with "C++-isms", but nowadays my contributions are
so minor that my opinion shouldn't carry that much weight on this
matter.

[Mikael Morin]

Post by Janne Blomqvist
On Tue, Dec 1, 2015 at 7:51 PM, Bernhard Reutner-Fischer

Post by Bernhard Reutner-Fischer
As said, we could as well use a list of candidates with NULL as record marker.
Implementation cosmetics. Steve seems to not be thrilled by the
overall idea in the first place, so unless there is clear support by
somebody else i won't pursue this any further, it's not that i'm bored
or ran out of stuff i should do.. ;)

FWIW, I think the idea of this patch is quite nice, and I'd like to
see it in the compiler.

I like this feature as well.

Post by Janne Blomqvist
I'm personally Ok with "C++-isms", but nowadays my contributions are
so minor that my opinion shouldn't carry that much weight on this
matter.

Same here.
David Malcolm suggested to move the candidate selection code to the
common middle-end infrastructure, which would move half of the so-called
"bloat" there. Steve, would that work for you?

It seems to me that the remaining C++-isms are rather acceptable.
I do agree that the vec implementation details seem overly complex for
something whose job is just the memory management of a growing (or
shrinking) vector. However, the API is consistent and self-explanatory,
and the usage of it that is made here (just a few "safe_push") is not
more complex than what would be done with a C-only API.

Mikael

[Steve Kargl]

Post by Mikael Morin

Post by Janne Blomqvist
On Tue, Dec 1, 2015 at 7:51 PM, Bernhard Reutner-Fischer

Post by Bernhard Reutner-Fischer
As said, we could as well use a list of candidates with NULL as record marker.
Implementation cosmetics. Steve seems to not be thrilled by the
overall idea in the first place, so unless there is clear support by
somebody else i won't pursue this any further, it's not that i'm bored
or ran out of stuff i should do.. ;)

FWIW, I think the idea of this patch is quite nice, and I'd like to
see it in the compiler.

I like this feature as well.

Post by Janne Blomqvist
I'm personally Ok with "C++-isms", but nowadays my contributions are
so minor that my opinion shouldn't carry that much weight on this
matter.

Same here.
David Malcolm suggested to move the candidate selection code to the
common middle-end infrastructure, which would move half of the so-called
"bloat" there. Steve, would that work for you?

Fine with me.

When debugging, if I run into C++isms, I'll stop and move to
a new bug. We certainly have enough open bugs to choose from.

[Mikael Morin]

Hello,

Post by Bernhard Reutner-Fischer
David Malcolm nice Levenshtein distance spelling check helpers
were used in some parts of other frontends. This proposed patch adds
some spelling corrections to the fortran frontend.
Suggestions are printed if we can find a suitable name, currently
/* If more than half of the letters were misspelled, the suggestion is
likely to be meaningless. */
cutoff = MAX (strlen (typo), strlen (best_guess)) / 2;
which effectively skips names with less than 4 characters.
For e.g. structures, one could try to be much smarter in an attempt to
also provide suggestions for single-letter members/components.
- user-defined operators
- structures (types and their components)
- functions
- symbols (variables)
I do not immediately see how to handle subroutines. Ideas?

Not sure what you are looking for; I can get an error generated in
gfc_procedure_use if using IMPLICIT NONE (EXTERNAL)

Post by Bernhard Reutner-Fischer
If anybody has a testcase where a spelling-suggestion would make sense
then please pass it along so we maybe can add support for GCC-7.
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 685e3f5..6e1f63c 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -29,6 +29,7 @@ along with GCC; see the file COPYING3. If not see
#include "data.h"
#include "target-memory.h" /* for gfc_simplify_transfer */
#include "constructor.h"
+#include "spellcheck.h"
/* Types used in equivalence statements. */
@@ -2682,6 +2683,61 @@ resolve_specific_f (gfc_expr *expr)
return true;
}
+/* Recursively append candidate SYM to CANDIDATES. */
+
+static void
+lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
+ vec<const char *> *candidates)
+{
+ gfc_symtree *p;
+ for (p = sym->right; p; p = p->right)
+ {
+ lookup_function_fuzzy_find_candidates (p, candidates);
+ if (p->n.sym->ts.type != BT_UNKNOWN)
+ candidates->safe_push (p->name);
+ }
+ for (p = sym->left; p; p = p->left)
+ {
+ lookup_function_fuzzy_find_candidates (p, candidates);
+ if (p->n.sym->ts.type != BT_UNKNOWN)
+ candidates->safe_push (p->name);
+ }
+}

It seems you are considering some candidates more than once here.
The first time through the recursive call you will consider say
sym->right->right, and with the loop, you'll consider it again after
returning from the recursive call.
The usual way to traverse the whole tree is to handle the current
pointer and recurse on left and right pointers. So without loop.
There is gfc_traverse_ns that you might find handy to do that (no
obligation).

Same goes for the user operators below.

Post by Bernhard Reutner-Fischer
+
+
+/* Lookup function FN fuzzily, taking names in FUN into account. */
+
+const char*
+gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *fun)
+{
+ auto_vec <const char *> candidates;
+ lookup_function_fuzzy_find_candidates (fun, &candidates);

You have to start the lookup with the current namespace's sym_root (not
with fun), otherwise you'll miss some candidates.
You may also want to query parent namespaces for host-associated symbols.

Post by Bernhard Reutner-Fischer
+
+ /* Determine closest match. */
+ int i;
+ const char *name, *best = NULL;
+ edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+

[...]

Post by Bernhard Reutner-Fischer
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index ff9aff9..212f7d8 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -27,6 +27,7 @@ along with GCC; see the file COPYING3. If not see
#include "parse.h"
#include "match.h"
#include "constructor.h"
+#include "spellcheck.h"
/* Strings for all symbol attributes. We use these for dumping the
@@ -235,6 +236,62 @@ gfc_get_default_type (const char *name, gfc_namespace *ns)
}
+/* Recursively append candidate SYM to CANDIDATES. */
+
+static void
+lookup_symbol_fuzzy_find_candidates (gfc_symtree *sym,
+ vec<const char *> *candidates)
+{
+ gfc_symtree *p;
+ for (p = sym->right; p; p = p->right)
+ {
+ lookup_symbol_fuzzy_find_candidates (p, candidates);
+ if (p->n.sym->ts.type != BT_UNKNOWN)
+ candidates->safe_push (p->name);
+ }
+ for (p = sym->left; p; p = p->left)
+ {
+ lookup_symbol_fuzzy_find_candidates (p, candidates);
+ if (p->n.sym->ts.type != BT_UNKNOWN)
+ candidates->safe_push (p->name);
+ }
+}

This looks like the same as lookup_function_fuzzy_find_candidates, isn't it?
Maybe have a general symbol traversal function with a selection callback
argument to test whether the symbol is what you want, depending on the
context (is it a function? a subroutine? etc).

Post by Bernhard Reutner-Fischer
+
+
+/* Lookup symbol SYM fuzzily, taking names in SYMBOL into account. */
+
+static const char*
+lookup_symbol_fuzzy (const char *sym, gfc_symbol *symbol)
+{
+ auto_vec <const char *> candidates;
+ lookup_symbol_fuzzy_find_candidates (symbol->ns->sym_root, &candidates);
+
+ /* Determine closest match. */
+ int i;
+ const char *name, *best = NULL;
+ edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+
+ FOR_EACH_VEC_ELT (candidates, i, name)
+ {
+ edit_distance_t dist = levenshtein_distance (sym, name);
+ if (dist < best_distance)
+ {
+ best_distance = dist;
+ best = name;
+ }
+ }
+ /* If more than half of the letters were misspelled, the suggestion is
+ likely to be meaningless. */
+ if (best)
+ {
+ unsigned int cutoff = MAX (strlen (sym), strlen (best)) / 2;
+ if (best_distance > cutoff)
+ return NULL;
+ }
+ return best;
+}
+
+
/* Given a pointer to a symbol, set its type according to the first
letter of its name. Fails if the letter in question has no default
type. */
@@ -253,8 +310,15 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
{
if (error_flag && !sym->attr.untyped)
{
- gfc_error ("Symbol %qs at %L has no IMPLICIT type",
- sym->name, &sym->declared_at);
+ const char *guessed
+ = lookup_symbol_fuzzy (sym->name, sym);
+ if (guessed)
+ gfc_error ("Symbol %qs at %L has no IMPLICIT type"
+ "; did you mean %qs?",
+ sym->name, &sym->declared_at, guessed);
+ else
+ gfc_error ("Symbol %qs at %L has no IMPLICIT type",
+ sym->name, &sym->declared_at);
sym->attr.untyped = 1; /* Ensure we only give an error once. */
}
}
+/* Recursively append candidate COMPONENT structures to CANDIDATES. */
+
+static void
+lookup_component_fuzzy_find_candidates (gfc_component *component,
+ vec<const char *> *candidates)
+{
+ for (gfc_component *p = component; p; p = p->next)
+ {
+ if (00 && p->ts.type == BT_DERIVED)
+ /* ??? There's no (suitable) DERIVED_TYPE which would come in
+ handy throughout the frontend; Use CLASS_DATA here for brevity. */
+ lookup_component_fuzzy_find_candidates (CLASS_DATA (p), candidates);

I don't understand what you are looking for here.
Are you trying to handle type extension? Then I guess you would have to
pass the derived type symbol instead of its components, and use
gfc_get_derived_super_type to retrieve the parent type.

Mikael

[David Malcolm]

Post by Mikael Morin
Hello,

Post by Bernhard Reutner-Fischer
David Malcolm nice Levenshtein distance spelling check helpers
were used in some parts of other frontends. This proposed patch adds
some spelling corrections to the fortran frontend.
Suggestions are printed if we can find a suitable name, currently
/* If more than half of the letters were misspelled, the suggestion is
likely to be meaningless. */
cutoff = MAX (strlen (typo), strlen (best_guess)) / 2;
which effectively skips names with less than 4 characters.
For e.g. structures, one could try to be much smarter in an attempt to
also provide suggestions for single-letter members/components.
- user-defined operators
- structures (types and their components)
- functions
- symbols (variables)
I do not immediately see how to handle subroutines. Ideas?

Not sure what you are looking for; I can get an error generated in
gfc_procedure_use if using IMPLICIT NONE (EXTERNAL)

Post by Bernhard Reutner-Fischer
If anybody has a testcase where a spelling-suggestion would make sense
then please pass it along so we maybe can add support for GCC-7.
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 685e3f5..6e1f63c 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -29,6 +29,7 @@ along with GCC; see the file COPYING3. If not see
#include "data.h"
#include "target-memory.h" /* for gfc_simplify_transfer */
#include "constructor.h"
+#include "spellcheck.h"
/* Types used in equivalence statements. */
@@ -2682,6 +2683,61 @@ resolve_specific_f (gfc_expr *expr)
return true;
}
+/* Recursively append candidate SYM to CANDIDATES. */
+
+static void
+lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
+ vec<const char *> *candidates)
+{
+ gfc_symtree *p;
+ for (p = sym->right; p; p = p->right)
+ {
+ lookup_function_fuzzy_find_candidates (p, candidates);
+ if (p->n.sym->ts.type != BT_UNKNOWN)
+ candidates->safe_push (p->name);
+ }
+ for (p = sym->left; p; p = p->left)
+ {
+ lookup_function_fuzzy_find_candidates (p, candidates);
+ if (p->n.sym->ts.type != BT_UNKNOWN)
+ candidates->safe_push (p->name);
+ }
+}

It seems you are considering some candidates more than once here.
The first time through the recursive call you will consider say
sym->right->right, and with the loop, you'll consider it again after
returning from the recursive call.
The usual way to traverse the whole tree is to handle the current
pointer and recurse on left and right pointers. So without loop.
There is gfc_traverse_ns that you might find handy to do that (no
obligation).
Same goes for the user operators below.

Post by Bernhard Reutner-Fischer
+
+
+/* Lookup function FN fuzzily, taking names in FUN into account. */
+
+const char*
+gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *fun)
+{
+ auto_vec <const char *> candidates;
+ lookup_function_fuzzy_find_candidates (fun, &candidates);

You have to start the lookup with the current namespace's sym_root (not
with fun), otherwise you'll miss some candidates.
You may also want to query parent namespaces for host-associated symbols.

Post by Bernhard Reutner-Fischer
+
+ /* Determine closest match. */
+ int i;
+ const char *name, *best = NULL;
+ edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+

[...]

Post by Bernhard Reutner-Fischer
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index ff9aff9..212f7d8 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -27,6 +27,7 @@ along with GCC; see the file COPYING3. If not see
#include "parse.h"
#include "match.h"
#include "constructor.h"
+#include "spellcheck.h"
/* Strings for all symbol attributes. We use these for dumping the
@@ -235,6 +236,62 @@ gfc_get_default_type (const char *name, gfc_namespace *ns)
}
+/* Recursively append candidate SYM to CANDIDATES. */
+
+static void
+lookup_symbol_fuzzy_find_candidates (gfc_symtree *sym,
+ vec<const char *> *candidates)
+{
+ gfc_symtree *p;
+ for (p = sym->right; p; p = p->right)
+ {
+ lookup_symbol_fuzzy_find_candidates (p, candidates);
+ if (p->n.sym->ts.type != BT_UNKNOWN)
+ candidates->safe_push (p->name);
+ }
+ for (p = sym->left; p; p = p->left)
+ {
+ lookup_symbol_fuzzy_find_candidates (p, candidates);
+ if (p->n.sym->ts.type != BT_UNKNOWN)
+ candidates->safe_push (p->name);
+ }
+}

This looks like the same as lookup_function_fuzzy_find_candidates, isn't it?
Maybe have a general symbol traversal function with a selection callback
argument to test whether the symbol is what you want, depending on the
context (is it a function? a subroutine? etc).

Post by Bernhard Reutner-Fischer
+
+
+/* Lookup symbol SYM fuzzily, taking names in SYMBOL into account. */
+
+static const char*
+lookup_symbol_fuzzy (const char *sym, gfc_symbol *symbol)
+{
+ auto_vec <const char *> candidates;
+ lookup_symbol_fuzzy_find_candidates (symbol->ns->sym_root, &candidates);
+
+ /* Determine closest match. */
+ int i;
+ const char *name, *best = NULL;
+ edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+
+ FOR_EACH_VEC_ELT (candidates, i, name)
+ {
+ edit_distance_t dist = levenshtein_distance (sym, name);
+ if (dist < best_distance)
+ {
+ best_distance = dist;
+ best = name;
+ }
+ }
+ /* If more than half of the letters were misspelled, the suggestion is
+ likely to be meaningless. */
+ if (best)
+ {
+ unsigned int cutoff = MAX (strlen (sym), strlen (best)) / 2;
+ if (best_distance > cutoff)
+ return NULL;
+ }
+ return best;
+}
+
+
/* Given a pointer to a symbol, set its type according to the first
letter of its name. Fails if the letter in question has no default
type. */
@@ -253,8 +310,15 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
{
if (error_flag && !sym->attr.untyped)
{
- gfc_error ("Symbol %qs at %L has no IMPLICIT type",
- sym->name, &sym->declared_at);
+ const char *guessed
+ = lookup_symbol_fuzzy (sym->name, sym);
+ if (guessed)
+ gfc_error ("Symbol %qs at %L has no IMPLICIT type"
+ "; did you mean %qs?",
+ sym->name, &sym->declared_at, guessed);
+ else
+ gfc_error ("Symbol %qs at %L has no IMPLICIT type",
+ sym->name, &sym->declared_at);
sym->attr.untyped = 1; /* Ensure we only give an error once. */
}
}
+/* Recursively append candidate COMPONENT structures to CANDIDATES. */
+
+static void
+lookup_component_fuzzy_find_candidates (gfc_component *component,
+ vec<const char *> *candidates)
+{
+ for (gfc_component *p = component; p; p = p->next)
+ {
+ if (00 && p->ts.type == BT_DERIVED)
+ /* ??? There's no (suitable) DERIVED_TYPE which would come in
+ handy throughout the frontend; Use CLASS_DATA here for brevity. */
+ lookup_component_fuzzy_find_candidates (CLASS_DATA (p), candidates);

I don't understand what you are looking for here.
Are you trying to handle type extension? Then I guess you would have to
pass the derived type symbol instead of its components, and use
gfc_get_derived_super_type to retrieve the parent type.

I can't comment on Mikael's observations, but here's an updated version
of Bernhard's patch which moves the duplicated code into a new
"find_closest_string" function in gcc/spellcheck.c.
With that, the lookup_*_fuzzy functions are all of the form:

{
auto_vec <const char *> candidates;

/* call something to populate candidates e.g.: */
lookup_function_fuzzy_find_candidates (fun, &candidates);

return find_closest_string (fn, &candidates);
}

where, as before, the auto_vec is implicitly cleaned up via a
C++ destructor as the function exits. Hopefully with this change it
reduces the amount of proposed C++ in the fortran subdirectory to an
palatable amount.

That's all I did; I didn't address the other issues seen in this thread
(e.g. Mikael's notes above).

Not yet well-tested; it compiles and passes the new test cases; I'm
posting it here in case someone more familiar with the Fortran FE wants
to take this forward (Bernhard?)

Hope this is constructive
Dave

[Bernhard Reutner-Fischer]

Post by David Malcolm
I can't comment on Mikael's observations, but here's an updated version
of Bernhard's patch which moves the duplicated code into a new
"find_closest_string" function in gcc/spellcheck.c.
{
auto_vec <const char *> candidates;
/* call something to populate candidates e.g.: */
lookup_function_fuzzy_find_candidates (fun, &candidates);
return find_closest_string (fn, &candidates);
}
where, as before, the auto_vec is implicitly cleaned up via a
C++ destructor as the function exits. Hopefully with this change it
reduces the amount of proposed C++ in the fortran subdirectory to an
palatable amount.
That's all I did; I didn't address the other issues seen in this thread
(e.g. Mikael's notes above).
Not yet well-tested; it compiles and passes the new test cases; I'm
posting it here in case someone more familiar with the Fortran FE wants
to take this forward (Bernhard?)

I have rewritten the autovec to plain c, will send an updated patch including current comments and maybe the parameter handling as suggested by Joost when done.

Thanks,

Post by David Malcolm
Hope this is constructive
Dave

[Bernhard Reutner-Fischer]

gcc/fortran/ChangeLog

2015-12-27 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* gfortran.h (gfc_lookup_function_fuzzy): New declaration.
(gfc_closest_fuzzy_match): New declaration.
(vec_push): New definition.
* misc.c (gfc_closest_fuzzy_match): New definition.
* resolve.c: Include spellcheck.h.
(lookup_function_fuzzy_find_candidates): New static function.
(lookup_uop_fuzzy_find_candidates): Likewise.
(lookup_uop_fuzzy): Likewise.
(resolve_operator) <INTRINSIC_USER>: Call lookup_uop_fuzzy.
(gfc_lookup_function_fuzzy): New definition.
(resolve_unknown_f): Call gfc_lookup_function_fuzzy.
* interface.c (check_interface0): Likewise.
(lookup_arg_fuzzy_find_candidates): New static function.
(lookup_arg_fuzzy ): Likewise.
(compare_actual_formal): Call lookup_arg_fuzzy.
* symbol.c: Include spellcheck.h.
(lookup_symbol_fuzzy_find_candidates): New static function.
(lookup_symbol_fuzzy): Likewise.
(gfc_set_default_type): Call lookup_symbol_fuzzy.
(lookup_component_fuzzy_find_candidates): New static function.
(lookup_component_fuzzy): Likewise.
(gfc_find_component): Call lookup_component_fuzzy.

gcc/testsuite/ChangeLog

2015-12-27 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* gfortran.dg/spellcheck-operator.f90: New testcase.
* gfortran.dg/spellcheck-procedure_1.f90: New testcase.
* gfortran.dg/spellcheck-procedure_2.f90: New testcase.
* gfortran.dg/spellcheck-structure.f90: New testcase.
* gfortran.dg/spellcheck-parameter.f90: New testcase.

---

David Malcolm's nice Levenshtein distance spelling check helpers
were used in some parts of other frontends. This proposed patch adds
some spelling corrections to the fortran frontend.

Suggestions are printed if we can find a suitable name, currently
perusing a very simple cutoff factor:
/* If more than half of the letters were misspelled, the suggestion is
likely to be meaningless. */
cutoff = MAX (strlen (typo), strlen (best_guess)) / 2;
which effectively skips names with less than 4 characters.
For e.g. structures, one could try to be much smarter in an attempt to
also provide suggestions for single-letter members/components.

This patch covers (at least partly):
- user-defined operators
- structures (types and their components)
- functions
- symbols (variables)

If anybody has a testcase where a spelling-suggestion would make sense
then please pass it along so we maybe can add support for GCC-7.

Changes for v1 -> v2:

- subroutines using interfaces
- keyword arguments (named parameters)

Rewrite C++ autovec in plain C.
Factor out levenshtein distance handling into a commonly used
gfc_closest_fuzzy_match().

Signed-off-by: Bernhard Reutner-Fischer <***@gmail.com>
---
gcc/fortran/gfortran.h | 12 +++
gcc/fortran/interface.c | 72 ++++++++++++++--
gcc/fortran/misc.c | 39 +++++++++
gcc/fortran/resolve.c | 99 +++++++++++++++++++++-
gcc/fortran/symbol.c | 84 +++++++++++++++++-
gcc/testsuite/gfortran.dg/spellcheck-operator.f90 | 30 +++++++
gcc/testsuite/gfortran.dg/spellcheck-parameter.f90 | 15 ++++
.../gfortran.dg/spellcheck-procedure_1.f90 | 41 +++++++++
.../gfortran.dg/spellcheck-procedure_2.f90 | 35 ++++++++
gcc/testsuite/gfortran.dg/spellcheck-structure.f90 | 35 ++++++++
10 files changed, 446 insertions(+), 16 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-operator.f90
create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-parameter.f90
create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90
create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90
create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-structure.f90

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 5487c93..93f0887 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2641,6 +2641,17 @@ void gfc_done_2 (void);

int get_c_kind (const char *, CInteropKind_t *);

+const char *gfc_closest_fuzzy_match (const char *, char **);
+static inline void
+vec_push (char **&optr, size_t &osz, const char *elt)
+{
+ /* {auto,}vec.safe_push () replacement. Don't ask.. */
+ // if (strlen (elt) < 4) return; premature optimization: eliminated by cutoff
+ optr = XRESIZEVEC (char *, optr, osz + 2);
+ optr[osz] = CONST_CAST (char *, elt);
+ optr[++osz] = NULL;
+}
+
/* options.c */
unsigned int gfc_option_lang_mask (void);
void gfc_init_options_struct (struct gcc_options *);
@@ -3060,6 +3071,7 @@ bool gfc_type_is_extensible (gfc_symbol *);
bool gfc_resolve_intrinsic (gfc_symbol *, locus *);
bool gfc_explicit_interface_required (gfc_symbol *, char *, int);
extern int gfc_do_concurrent_flag;
+const char* gfc_lookup_function_fuzzy (const char *, gfc_symtree *);


/* array.c */
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 30cc522..eb9bc6a 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1587,13 +1587,27 @@ check_interface0 (gfc_interface *p, const char *interface_name)
|| !p->sym->attr.if_source)
&& p->sym->attr.flavor != FL_DERIVED)
{
+ const char *guessed
+ = gfc_lookup_function_fuzzy (p->sym->name, p->sym->ns->sym_root);
+
if (p->sym->attr.external)
- gfc_error ("Procedure %qs in %s at %L has no explicit interface",
- p->sym->name, interface_name, &p->sym->declared_at);
+ if (guessed)
+ gfc_error ("Procedure %qs in %s at %L has no explicit interface"
+ "; did you mean %qs?",
+ p->sym->name, interface_name, &p->sym->declared_at,
+ guessed);
+ else
+ gfc_error ("Procedure %qs in %s at %L has no explicit interface",
+ p->sym->name, interface_name, &p->sym->declared_at);
else
- gfc_error ("Procedure %qs in %s at %L is neither function nor "
- "subroutine", p->sym->name, interface_name,
- &p->sym->declared_at);
+ if (guessed)
+ gfc_error ("Procedure %qs in %s at %L is neither function nor "
+ "subroutine; did you mean %qs?", p->sym->name,
+ interface_name, &p->sym->declared_at, guessed);
+ else
+ gfc_error ("Procedure %qs in %s at %L is neither function nor "
+ "subroutine", p->sym->name, interface_name,
+ &p->sym->declared_at);
return 1;
}

@@ -2559,6 +2573,31 @@ is_procptr_result (gfc_expr *expr)
}


+/* Recursively append candidate argument ARG to CANDIDATES. Store the
+ number of total candidates in CANDIDATES_LEN. */
+
+static void
+lookup_arg_fuzzy_find_candidates (gfc_formal_arglist *arg,
+ char **&candidates,
+ size_t &candidates_len)
+{
+ for (gfc_formal_arglist *p = arg; p && p->sym; p = p->next)
+ vec_push (candidates, candidates_len, p->sym->name);
+}
+
+
+/* Lookup argument ARG fuzzily, taking names in ARGUMENTS into account. */
+
+static const char*
+lookup_arg_fuzzy (const char *arg, gfc_formal_arglist *arguments)
+{
+ char **candidates = NULL;
+ size_t candidates_len = 0;
+ lookup_arg_fuzzy_find_candidates (arguments, candidates, candidates_len);
+ return gfc_closest_fuzzy_match (arg, candidates);
+}
+
+
/* Given formal and actual argument lists, see if they are compatible.
If they are compatible, the actual argument list is sorted to
correspond with the formal list, and elements for missing optional
@@ -2611,8 +2650,16 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
if (f == NULL)
{
if (where)
- gfc_error ("Keyword argument %qs at %L is not in "
- "the procedure", a->name, &a->expr->where);
+ {
+ const char *guessed = lookup_arg_fuzzy (a->name, formal);
+ if (guessed)
+ gfc_error ("Keyword argument %qs at %L is not in "
+ "the procedure; did you mean %qs?",
+ a->name, &a->expr->where, guessed);
+ else
+ gfc_error ("Keyword argument %qs at %L is not in "
+ "the procedure", a->name, &a->expr->where);
+ }
return 0;
}

@@ -3311,8 +3358,15 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
{
if (sym->ns->has_implicit_none_export && sym->attr.proc == PROC_UNKNOWN)
{
- gfc_error ("Procedure %qs called at %L is not explicitly declared",
- sym->name, where);
+ const char *guessed
+ = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
+ if (guessed)
+ gfc_error ("Procedure %qs called at %L is not explicitly declared"
+ "; did you mean %qs?",
+ sym->name, where, guessed);
+ else
+ gfc_error ("Procedure %qs called at %L is not explicitly declared",
+ sym->name, where);
return false;
}
if (warn_implicit_interface)
diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
index 34ed04a..db51aef 100644
--- a/gcc/fortran/misc.c
+++ b/gcc/fortran/misc.c
@@ -22,6 +22,7 @@ along with GCC; see the file COPYING3. If not see
#include "system.h"
#include "coretypes.h"
#include "gfortran.h"
+#include "spellcheck.h"


/* Initialize a typespec to unknown. */
@@ -274,3 +275,41 @@ get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])

return ISOCBINDING_INVALID;
}
+
+
+/* For a given name TYPO, determine the best candidate from CANDIDATES
+ perusing Levenshtein distance. Frees CANDIDATES before returning. */
+
+const char *
+gfc_closest_fuzzy_match (const char *typo, char **candidates)
+{
+ /* Determine closest match. */
+ const char *best = NULL;
+ char **cand = candidates;
+ edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+
+ while (cand && *cand)
+ {
+ edit_distance_t dist = levenshtein_distance (typo, *cand);
+ if (dist < best_distance)
+ {
+ best_distance = dist;
+ best = *cand;
+ }
+ cand++;
+ }
+ /* If more than half of the letters were misspelled, the suggestion is
+ likely to be meaningless. */
+ if (best)
+ {
+ unsigned int cutoff = MAX (strlen (typo), strlen (best)) / 2;
+
+ if (best_distance > cutoff)
+ {
+ XDELETEVEC (candidates);
+ return NULL;
+ }
+ XDELETEVEC (candidates);
+ }
+ return best;
+}
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 685e3f5..37775b1 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -2682,6 +2682,43 @@ resolve_specific_f (gfc_expr *expr)
return true;
}

+/* Recursively append candidate SYM to CANDIDATES. Store the number of
+ candidates in CANDIDATES_LEN. */
+
+static void
+lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
+ char **&candidates,
+ size_t &candidates_len)
+{
+ gfc_symtree *p;
+
+ if (sym == NULL)
+ return;
+ if ((sym->n.sym->ts.type != BT_UNKNOWN || sym->n.sym->attr.external)
+ && sym->n.sym->attr.flavor == FL_PROCEDURE)
+ vec_push (candidates, candidates_len, sym->name);
+
+ p = sym->left;
+ if (p)
+ lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
+
+ p = sym->right;
+ if (p)
+ lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
+}
+
+
+/* Lookup function FN fuzzily, taking names in SYMROOT into account. */
+
+const char*
+gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *symroot)
+{
+ char **candidates = NULL;
+ size_t candidates_len = 0;
+ lookup_function_fuzzy_find_candidates (symroot, candidates, candidates_len);
+ return gfc_closest_fuzzy_match (fn, candidates);
+}
+

/* Resolve a procedure call not known to be generic nor specific. */

@@ -2732,8 +2769,15 @@ set_type:

if (ts->type == BT_UNKNOWN)
{
- gfc_error ("Function %qs at %L has no IMPLICIT type",
- sym->name, &expr->where);
+ const char *guessed
+ = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
+ if (guessed)
+ gfc_error ("Function %qs at %L has no IMPLICIT type"
+ "; did you mean %qs?",
+ sym->name, &expr->where, guessed);
+ else
+ gfc_error ("Function %qs at %L has no IMPLICIT type",
+ sym->name, &expr->where);
return false;
}
else
@@ -3505,6 +3549,46 @@ compare_shapes (gfc_expr *op1, gfc_expr *op2)
}


+/* Recursively append candidate UOP to CANDIDATES. Store the number of
+ candidates in CANDIDATES_LEN. */
+static void
+lookup_uop_fuzzy_find_candidates (gfc_symtree *uop,
+ char **&candidates,
+ size_t &candidates_len)
+{
+ gfc_symtree *p;
+
+ if (uop == NULL)
+ return;
+
+ /* Not sure how to properly filter here. Use all for a start.
+ n.uop.op is NULL for empty interface operators (is that legal?) disregard
+ these as i suppose they don't make terribly sense. */
+
+ if (uop->n.uop->op != NULL)
+ vec_push (candidates, candidates_len, uop->name);
+
+ p = uop->left;
+ if (p)
+ lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
+
+ p = uop->right;
+ if (p)
+ lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
+}
+
+/* Lookup user-operator OP fuzzily, taking names in UOP into account. */
+
+static const char*
+lookup_uop_fuzzy (const char *op, gfc_symtree *uop)
+{
+ char **candidates = NULL;
+ size_t candidates_len = 0;
+ lookup_uop_fuzzy_find_candidates (uop, candidates, candidates_len);
+ return gfc_closest_fuzzy_match (op, candidates);
+}
+
+
/* Resolve an operator expression node. This can involve replacing the
operation with a user defined function call. */

@@ -3703,7 +3787,16 @@ resolve_operator (gfc_expr *e)

case INTRINSIC_USER:
if (e->value.op.uop->op == NULL)
- sprintf (msg, _("Unknown operator '%s' at %%L"), e->value.op.uop->name);
+ {
+ const char *name = e->value.op.uop->name;
+ const char *guessed;
+ guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root);
+ if (guessed)
+ sprintf (msg, _("Unknown operator '%s' at %%L; did you mean '%s'?"),
+ name, guessed);
+ else
+ sprintf (msg, _("Unknown operator '%s' at %%L"), name);
+ }
else if (op2 == NULL)
sprintf (msg, _("Operand of user operator '%s' at %%L is %s"),
e->value.op.uop->name, gfc_typename (&op1->ts));
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index ff9aff9..1499603 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -235,6 +235,44 @@ gfc_get_default_type (const char *name, gfc_namespace *ns)
}


+/* Recursively append candidate SYM to CANDIDATES. Store the number of
+ candidates in CANDIDATES_LEN. */
+
+static void
+lookup_symbol_fuzzy_find_candidates (gfc_symtree *sym,
+ char **&candidates,
+ size_t &candidates_len)
+{
+ gfc_symtree *p;
+
+ if (sym == NULL)
+ return;
+
+ if (sym->n.sym->ts.type != BT_UNKNOWN && sym->n.sym->ts.type != BT_PROCEDURE)
+ vec_push (candidates, candidates_len, sym->name);
+ p = sym->left;
+ if (p)
+ lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len);
+
+ p = sym->right;
+ if (p)
+ lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len);
+}
+
+
+/* Lookup symbol SYM_NAME fuzzily, taking names in SYMBOL into account. */
+
+static const char*
+lookup_symbol_fuzzy (const char *sym_name, gfc_symbol *symbol)
+{
+ char **candidates = NULL;
+ size_t candidates_len = 0;
+ lookup_symbol_fuzzy_find_candidates (symbol->ns->sym_root, candidates,
+ candidates_len);
+ return gfc_closest_fuzzy_match (sym_name, candidates);
+}
+
+
/* Given a pointer to a symbol, set its type according to the first
letter of its name. Fails if the letter in question has no default
type. */
@@ -253,8 +291,14 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
{
if (error_flag && !sym->attr.untyped)
{
- gfc_error ("Symbol %qs at %L has no IMPLICIT type",
- sym->name, &sym->declared_at);
+ const char *guessed = lookup_symbol_fuzzy (sym->name, sym);
+ if (guessed)
+ gfc_error ("Symbol %qs at %L has no IMPLICIT type"
+ "; did you mean %qs?",
+ sym->name, &sym->declared_at, guessed);
+ else
+ gfc_error ("Symbol %qs at %L has no IMPLICIT type",
+ sym->name, &sym->declared_at);
sym->attr.untyped = 1; /* Ensure we only give an error once. */
}

@@ -2188,6 +2232,30 @@ bad:
}


+/* Recursively append candidate COMPONENT structures to CANDIDATES. Store
+ the number of total candidates in CANDIDATES_LEN. */
+
+static void
+lookup_component_fuzzy_find_candidates (gfc_component *component,
+ char **&candidates,
+ size_t &candidates_len)
+{
+ for (gfc_component *p = component; p; p = p->next)
+ vec_push (candidates, candidates_len, p->name);
+}
+
+/* Lookup component MEMBER fuzzily, taking names in COMPONENT into account. */
+
+static const char*
+lookup_component_fuzzy (const char *member, gfc_component *component)
+{
+ char **candidates = NULL;
+ size_t candidates_len = 0;
+ lookup_component_fuzzy_find_candidates (component, candidates,
+ candidates_len);
+ return gfc_closest_fuzzy_match (member, candidates);
+}
+
/* Given a derived type node and a component name, try to locate the
component structure. Returns the NULL pointer if the component is
not found or the components are private. If noaccess is set, no access
@@ -2238,8 +2306,16 @@ gfc_find_component (gfc_symbol *sym, const char *name,
}

if (p == NULL && !silent)
- gfc_error ("%qs at %C is not a member of the %qs structure",
- name, sym->name);
+ {
+ const char *guessed = lookup_component_fuzzy (name, sym->components);
+ if (guessed)
+ gfc_error ("%qs at %C is not a member of the %qs structure"
+ "; did you mean %qs?",
+ name, sym->name, guessed);
+ else
+ gfc_error ("%qs at %C is not a member of the %qs structure",
+ name, sym->name);
+ }

return p;
}
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-operator.f90 b/gcc/testsuite/gfortran.dg/spellcheck-operator.f90
new file mode 100644
index 0000000..810a770
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-operator.f90
@@ -0,0 +1,30 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+module mymod1
+ implicit none
+ contains
+ function something_good (iarg1)
+ integer :: something_good
+ integer, intent(in) :: iarg1
+ something_good = iarg1 + 42
+ end function something_good
+end module mymod1
+
+program spellchekc
+ use mymod1
+ implicit none
+
+ interface operator (.mywrong.)
+ module procedure something_wring ! { dg-error "Procedure .something_wring. in operator interface .mywrong. at .1. is neither function nor subroutine; did you mean .something_good.\\?|User operator procedure .something_wring. at .1. must be a FUNCTION" }
+ end interface
+
+ interface operator (.mygood.)
+ module procedure something_good
+ end interface
+
+ integer :: i, j, added
+ i = 0
+ j = 0
+ added = .mygoof. j ! { dg-error "Unknown operator .mygoof. at .1.; did you mean .mygood.\\?" }
+end program spellchekc
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-parameter.f90 b/gcc/testsuite/gfortran.dg/spellcheck-parameter.f90
new file mode 100644
index 0000000..715c5ab
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-parameter.f90
@@ -0,0 +1,15 @@
+! { dg-do compile }
+! Contributed by Joost VandeVondele
+! test levenshtein based spelling suggestions for keyword arguments
+
+module test
+contains
+ subroutine mysub(iarg1)
+ integer :: iarg1
+ end subroutine
+end module
+
+use test
+call mysub(iarg=1) ! { dg-error "Keyword argument .iarg. at .1. is not in the procedure; did you mean .iarg1.\\?" }
+
+end
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90 b/gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90
new file mode 100644
index 0000000..3b7f716
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90
@@ -0,0 +1,41 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+module mymod1
+ implicit none
+ contains
+ function something_else (iarg1)
+ integer :: something_else
+ integer, intent(in) :: iarg1
+ something_else = iarg1 + 42
+ end function something_else
+ function add_fourtytwo (iarg1)
+ integer :: add_fourtytwo
+ integer, intent(in) :: iarg1
+ add_fourtytwo = iarg1 + 42
+ end function add_fourtytwo
+end module mymod1
+
+function myadd(iarg1, iarg2)
+ implicit none
+ integer :: myadd
+ integer, intent(in) :: iarg1, iarg2
+ myadd = iarg1 + iarg2
+end function myadd
+
+program spellchekc
+ use mymod1, something_good => something_else
+ implicit none
+
+ integer :: myadd, i, j, myvar
+ i = 0
+ j = 0
+
+ j = something_goof(j) ! { dg-error "no IMPLICIT type; did you mean .something_good.\\?" }
+ j = myaddd(i, j) ! { dg-error "no IMPLICIT type; did you mean .myadd.\\?" }
+ if (j /= 42) call abort
+ j = add_fourtytow(i, j) ! { dg-error "no IMPLICIT type; did you mean .add_fourtytwo.\\?" }
+ myval = myadd(i, j) ! { dg-error "no IMPLICIT type; did you mean .myvar.\\?" }
+ if (j /= 42 * 2) call abort
+
+end program spellchekc
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90 b/gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90
new file mode 100644
index 0000000..fbd4dcd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+
+program spellchekc
+ implicit none (external)
+
+ interface
+ subroutine bark_unless_zero(iarg)
+ implicit none
+ integer, intent(in) :: iarg
+ end subroutine bark_unless_zero
+ end interface
+
+ integer :: i
+ i = 0
+
+ if (i /= 1) call abort
+ call bark_unless_0(i) ! { dg-error "not explicitly declared; did you mean .bark_unless_zero.\\?" }
+! call complain_about_0(i) ! { -dg-error "not explicitly declared; did you mean .complain_about_zero.\\?" }
+
+contains
+! We cannot reliably see this ATM, would need an unambiguous bit somewhere
+ subroutine complain_about_zero(iarg)
+ integer, intent(in) :: iarg
+ if (iarg /= 0) call abort
+ end subroutine complain_about_zero
+
+end program spellchekc
+
+subroutine bark_unless_zero(iarg)
+ implicit none
+ integer, intent(in) :: iarg
+ if (iarg /= 0) call abort
+end subroutine bark_unless_zero
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-structure.f90 b/gcc/testsuite/gfortran.dg/spellcheck-structure.f90
new file mode 100644
index 0000000..929e05f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-structure.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+implicit none
+
+!!!!!!!!!!!!!! structure tests !!!!!!!!!!!!!!
+type type1
+ real :: radius
+ integer :: i
+end type type1
+
+type type2
+ integer :: myint
+ type(type1) :: mytype
+end type type2
+
+type type3
+ type(type2) :: type_2
+end type type3
+type type4
+ type(type3) :: type_3
+end type type4
+
+type(type1) :: t1
+t1%radiuz = .0 ! { dg-error ".radiuz. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+t1%x = .0 ! { dg-error ".x. at .1. is not a member of the .type1. structure" }
+type(type2) :: t2
+t2%mytape%radius = .0 ! { dg-error ".mytape. at .1. is not a member of the .type2. structure; did you mean .mytype.\\?" }
+t2%mytype%radious = .0 ! { dg-error ".radious. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+type(type4) :: t4
+t4%type_3%type_2%mytype%radium = 88.0 ! { dg-error ".radium. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+
+!!!!!!!!!!!!!! symbol tests !!!!!!!!!!!!!!
+integer :: iarg1
+iarg2 = 1 ! { dg-error "Symbol .iarg2. at .1. has no IMPLICIT type; did you mean .iarg1.\\?" }
+end

[Bernhard Reutner-Fischer]

Changes for v2 -> v3:

- rebased

Changes for v1 -> v2:

- subroutines using interfaces
- keyword arguments (named parameters)

Rewrite C++ autovec in plain C.
Factor out levenshtein distance handling into a commonly used
gfc_closest_fuzzy_match().

gcc/fortran/ChangeLog

2015-12-27 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* gfortran.h (gfc_lookup_function_fuzzy): New declaration.
(gfc_closest_fuzzy_match): New declaration.
(vec_push): New definition.
* misc.c (gfc_closest_fuzzy_match): New definition.
* resolve.c: Include spellcheck.h.
(lookup_function_fuzzy_find_candidates): New static function.
(lookup_uop_fuzzy_find_candidates): Likewise.
(lookup_uop_fuzzy): Likewise.
(resolve_operator) <INTRINSIC_USER>: Call lookup_uop_fuzzy.
(gfc_lookup_function_fuzzy): New definition.
(resolve_unknown_f): Call gfc_lookup_function_fuzzy.
* interface.c (check_interface0): Likewise.
(lookup_arg_fuzzy_find_candidates): New static function.
(lookup_arg_fuzzy ): Likewise.
(compare_actual_formal): Call lookup_arg_fuzzy.
* symbol.c: Include spellcheck.h.
(lookup_symbol_fuzzy_find_candidates): New static function.
(lookup_symbol_fuzzy): Likewise.
(gfc_set_default_type): Call lookup_symbol_fuzzy.
(lookup_component_fuzzy_find_candidates): New static function.
(lookup_component_fuzzy): Likewise.
(gfc_find_component): Call lookup_component_fuzzy.

gcc/testsuite/ChangeLog

2015-12-27 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* gfortran.dg/spellcheck-operator.f90: New testcase.
* gfortran.dg/spellcheck-procedure_1.f90: New testcase.
* gfortran.dg/spellcheck-procedure_2.f90: New testcase.
* gfortran.dg/spellcheck-structure.f90: New testcase.
* gfortran.dg/spellcheck-parameter.f90: New testcase.

---

David Malcolm's nice Levenshtein distance spelling check helpers
were used in some parts of other frontends. This proposed patch adds
some spelling corrections to the fortran frontend.

Suggestions are printed if we can find a suitable name, currently
perusing a very simple cutoff factor:
/* If more than half of the letters were misspelled, the suggestion is
likely to be meaningless. */
cutoff = MAX (strlen (typo), strlen (best_guess)) / 2;
which effectively skips names with less than 4 characters.
For e.g. structures, one could try to be much smarter in an attempt to
also provide suggestions for single-letter members/components.

This patch covers (at least partly):
- user-defined operators
- structures (types and their components)
- functions
- symbols (variables)
- subroutines using interfaces
- keyword arguments (named parameters)

If anybody has a testcase where a spelling-suggestion would make sense
then please pass it along so we maybe can add support for GCC-7.

Signed-off-by: Bernhard Reutner-Fischer <***@gmail.com>
---
gcc/fortran/gfortran.h | 12 +++
gcc/fortran/interface.c | 72 +++++++++++++--
gcc/fortran/misc.c | 39 ++++++++
gcc/fortran/resolve.c | 100 ++++++++++++++++++++-
gcc/fortran/symbol.c | 84 ++++++++++++++++-
gcc/testsuite/gfortran.dg/spellcheck-operator.f90 | 30 +++++++
gcc/testsuite/gfortran.dg/spellcheck-parameter.f90 | 15 ++++
.../gfortran.dg/spellcheck-procedure_1.f90 | 41 +++++++++
.../gfortran.dg/spellcheck-procedure_2.f90 | 35 ++++++++
gcc/testsuite/gfortran.dg/spellcheck-structure.f90 | 35 ++++++++
10 files changed, 446 insertions(+), 17 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-operator.f90
create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-parameter.f90
create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90
create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90
create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-structure.f90

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 33fffd8..5c0c403 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2669,6 +2669,17 @@ void gfc_done_2 (void);

int get_c_kind (const char *, CInteropKind_t *);

+const char *gfc_closest_fuzzy_match (const char *, char **);
+static inline void
+vec_push (char **&optr, size_t &osz, const char *elt)
+{
+ /* {auto,}vec.safe_push () replacement. Don't ask.. */
+ // if (strlen (elt) < 4) return; premature optimization: eliminated by cutoff
+ optr = XRESIZEVEC (char *, optr, osz + 2);
+ optr[osz] = CONST_CAST (char *, elt);
+ optr[++osz] = NULL;
+}
+
/* options.c */
unsigned int gfc_option_lang_mask (void);
void gfc_init_options_struct (struct gcc_options *);
@@ -3088,6 +3099,7 @@ bool gfc_type_is_extensible (gfc_symbol *);
bool gfc_resolve_intrinsic (gfc_symbol *, locus *);
bool gfc_explicit_interface_required (gfc_symbol *, char *, int);
extern int gfc_do_concurrent_flag;
+const char* gfc_lookup_function_fuzzy (const char *, gfc_symtree *);


/* array.c */
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index ac53f01..ea64c0e 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1587,13 +1587,27 @@ check_interface0 (gfc_interface *p, const char *interface_name)
|| !p->sym->attr.if_source)
&& p->sym->attr.flavor != FL_DERIVED)
{
+ const char *guessed
+ = gfc_lookup_function_fuzzy (p->sym->name, p->sym->ns->sym_root);
+
if (p->sym->attr.external)
- gfc_error ("Procedure %qs in %s at %L has no explicit interface",
- p->sym->name, interface_name, &p->sym->declared_at);
+ if (guessed)
+ gfc_error ("Procedure %qs in %s at %L has no explicit interface"
+ "; did you mean %qs?",
+ p->sym->name, interface_name, &p->sym->declared_at,
+ guessed);
+ else
+ gfc_error ("Procedure %qs in %s at %L has no explicit interface",
+ p->sym->name, interface_name, &p->sym->declared_at);
else
- gfc_error ("Procedure %qs in %s at %L is neither function nor "
- "subroutine", p->sym->name, interface_name,
- &p->sym->declared_at);
+ if (guessed)
+ gfc_error ("Procedure %qs in %s at %L is neither function nor "
+ "subroutine; did you mean %qs?", p->sym->name,
+ interface_name, &p->sym->declared_at, guessed);
+ else
+ gfc_error ("Procedure %qs in %s at %L is neither function nor "
+ "subroutine", p->sym->name, interface_name,
+ &p->sym->declared_at);
return 1;
}

@@ -2577,6 +2591,31 @@ is_procptr_result (gfc_expr *expr)
}


+/* Recursively append candidate argument ARG to CANDIDATES. Store the
+ number of total candidates in CANDIDATES_LEN. */
+
+static void
+lookup_arg_fuzzy_find_candidates (gfc_formal_arglist *arg,
+ char **&candidates,
+ size_t &candidates_len)
+{
+ for (gfc_formal_arglist *p = arg; p && p->sym; p = p->next)
+ vec_push (candidates, candidates_len, p->sym->name);
+}
+
+
+/* Lookup argument ARG fuzzily, taking names in ARGUMENTS into account. */
+
+static const char*
+lookup_arg_fuzzy (const char *arg, gfc_formal_arglist *arguments)
+{
+ char **candidates = NULL;
+ size_t candidates_len = 0;
+ lookup_arg_fuzzy_find_candidates (arguments, candidates, candidates_len);
+ return gfc_closest_fuzzy_match (arg, candidates);
+}
+
+
/* Given formal and actual argument lists, see if they are compatible.
If they are compatible, the actual argument list is sorted to
correspond with the formal list, and elements for missing optional
@@ -2629,8 +2668,16 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
if (f == NULL)
{
if (where)
- gfc_error ("Keyword argument %qs at %L is not in "
- "the procedure", a->name, &a->expr->where);
+ {
+ const char *guessed = lookup_arg_fuzzy (a->name, formal);
+ if (guessed)
+ gfc_error ("Keyword argument %qs at %L is not in "
+ "the procedure; did you mean %qs?",
+ a->name, &a->expr->where, guessed);
+ else
+ gfc_error ("Keyword argument %qs at %L is not in "
+ "the procedure", a->name, &a->expr->where);
+ }
return 0;
}

@@ -3329,8 +3376,15 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
{
if (sym->ns->has_implicit_none_export && sym->attr.proc == PROC_UNKNOWN)
{
- gfc_error ("Procedure %qs called at %L is not explicitly declared",
- sym->name, where);
+ const char *guessed
+ = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
+ if (guessed)
+ gfc_error ("Procedure %qs called at %L is not explicitly declared"
+ "; did you mean %qs?",
+ sym->name, where, guessed);
+ else
+ gfc_error ("Procedure %qs called at %L is not explicitly declared",
+ sym->name, where);
return false;
}
if (warn_implicit_interface)
diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
index 405bae0..72ed311 100644
--- a/gcc/fortran/misc.c
+++ b/gcc/fortran/misc.c
@@ -22,6 +22,7 @@ along with GCC; see the file COPYING3. If not see
#include "system.h"
#include "coretypes.h"
#include "gfortran.h"
+#include "spellcheck.h"


/* Initialize a typespec to unknown. */
@@ -274,3 +275,41 @@ get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])

return ISOCBINDING_INVALID;
}
+
+
+/* For a given name TYPO, determine the best candidate from CANDIDATES
+ perusing Levenshtein distance. Frees CANDIDATES before returning. */
+
+const char *
+gfc_closest_fuzzy_match (const char *typo, char **candidates)
+{
+ /* Determine closest match. */
+ const char *best = NULL;
+ char **cand = candidates;
+ edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+
+ while (cand && *cand)
+ {
+ edit_distance_t dist = levenshtein_distance (typo, *cand);
+ if (dist < best_distance)
+ {
+ best_distance = dist;
+ best = *cand;
+ }
+ cand++;
+ }
+ /* If more than half of the letters were misspelled, the suggestion is
+ likely to be meaningless. */
+ if (best)
+ {
+ unsigned int cutoff = MAX (strlen (typo), strlen (best)) / 2;
+
+ if (best_distance > cutoff)
+ {
+ XDELETEVEC (candidates);
+ return NULL;
+ }
+ XDELETEVEC (candidates);
+ }
+ return best;
+}
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 556c846..27e4ddd 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -2687,6 +2687,43 @@ resolve_specific_f (gfc_expr *expr)
return true;
}

+/* Recursively append candidate SYM to CANDIDATES. Store the number of
+ candidates in CANDIDATES_LEN. */
+
+static void
+lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
+ char **&candidates,
+ size_t &candidates_len)
+{
+ gfc_symtree *p;
+
+ if (sym == NULL)
+ return;
+ if ((sym->n.sym->ts.type != BT_UNKNOWN || sym->n.sym->attr.external)
+ && sym->n.sym->attr.flavor == FL_PROCEDURE)
+ vec_push (candidates, candidates_len, sym->name);
+
+ p = sym->left;
+ if (p)
+ lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
+
+ p = sym->right;
+ if (p)
+ lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
+}
+
+
+/* Lookup function FN fuzzily, taking names in SYMROOT into account. */
+
+const char*
+gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *symroot)
+{
+ char **candidates = NULL;
+ size_t candidates_len = 0;
+ lookup_function_fuzzy_find_candidates (symroot, candidates, candidates_len);
+ return gfc_closest_fuzzy_match (fn, candidates);
+}
+

/* Resolve a procedure call not known to be generic nor specific. */

@@ -2737,8 +2774,15 @@ set_type:

if (ts->type == BT_UNKNOWN)
{
- gfc_error ("Function %qs at %L has no IMPLICIT type",
- sym->name, &expr->where);
+ const char *guessed
+ = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
+ if (guessed)
+ gfc_error ("Function %qs at %L has no IMPLICIT type"
+ "; did you mean %qs?",
+ sym->name, &expr->where, guessed);
+ else
+ gfc_error ("Function %qs at %L has no IMPLICIT type",
+ sym->name, &expr->where);
return false;
}
else
@@ -3510,6 +3554,46 @@ compare_shapes (gfc_expr *op1, gfc_expr *op2)
}


+/* Recursively append candidate UOP to CANDIDATES. Store the number of
+ candidates in CANDIDATES_LEN. */
+static void
+lookup_uop_fuzzy_find_candidates (gfc_symtree *uop,
+ char **&candidates,
+ size_t &candidates_len)
+{
+ gfc_symtree *p;
+
+ if (uop == NULL)
+ return;
+
+ /* Not sure how to properly filter here. Use all for a start.
+ n.uop.op is NULL for empty interface operators (is that legal?) disregard
+ these as i suppose they don't make terribly sense. */
+
+ if (uop->n.uop->op != NULL)
+ vec_push (candidates, candidates_len, uop->name);
+
+ p = uop->left;
+ if (p)
+ lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
+
+ p = uop->right;
+ if (p)
+ lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
+}
+
+/* Lookup user-operator OP fuzzily, taking names in UOP into account. */
+
+static const char*
+lookup_uop_fuzzy (const char *op, gfc_symtree *uop)
+{
+ char **candidates = NULL;
+ size_t candidates_len = 0;
+ lookup_uop_fuzzy_find_candidates (uop, candidates, candidates_len);
+ return gfc_closest_fuzzy_match (op, candidates);
+}
+
+
/* Resolve an operator expression node. This can involve replacing the
operation with a user defined function call. */

@@ -3708,8 +3792,16 @@ resolve_operator (gfc_expr *e)

case INTRINSIC_USER:
if (e->value.op.uop->op == NULL)
- sprintf (msg, _("Unknown operator %%<%s%%> at %%L"),
- e->value.op.uop->name);
+ {
+ const char *name = e->value.op.uop->name;
+ const char *guessed;
+ guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root);
+ if (guessed)
+ sprintf (msg, _("Unknown operator %%<%s%%> at %%L; did you mean '%s'?"),
+ name, guessed);
+ else
+ sprintf (msg, _("Unknown operator %%<%s%%> at %%L"), name);
+ }
else if (op2 == NULL)
sprintf (msg, _("Operand of user operator %%<%s%%> at %%L is %s"),
e->value.op.uop->name, gfc_typename (&op1->ts));
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 8efd12c..da7154e 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -235,6 +235,44 @@ gfc_get_default_type (const char *name, gfc_namespace *ns)
}


+/* Recursively append candidate SYM to CANDIDATES. Store the number of
+ candidates in CANDIDATES_LEN. */
+
+static void
+lookup_symbol_fuzzy_find_candidates (gfc_symtree *sym,
+ char **&candidates,
+ size_t &candidates_len)
+{
+ gfc_symtree *p;
+
+ if (sym == NULL)
+ return;
+
+ if (sym->n.sym->ts.type != BT_UNKNOWN && sym->n.sym->ts.type != BT_PROCEDURE)
+ vec_push (candidates, candidates_len, sym->name);
+ p = sym->left;
+ if (p)
+ lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len);
+
+ p = sym->right;
+ if (p)
+ lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len);
+}
+
+
+/* Lookup symbol SYM_NAME fuzzily, taking names in SYMBOL into account. */
+
+static const char*
+lookup_symbol_fuzzy (const char *sym_name, gfc_symbol *symbol)
+{
+ char **candidates = NULL;
+ size_t candidates_len = 0;
+ lookup_symbol_fuzzy_find_candidates (symbol->ns->sym_root, candidates,
+ candidates_len);
+ return gfc_closest_fuzzy_match (sym_name, candidates);
+}
+
+
/* Given a pointer to a symbol, set its type according to the first
letter of its name. Fails if the letter in question has no default
type. */
@@ -253,8 +291,14 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
{
if (error_flag && !sym->attr.untyped)
{
- gfc_error ("Symbol %qs at %L has no IMPLICIT type",
- sym->name, &sym->declared_at);
+ const char *guessed = lookup_symbol_fuzzy (sym->name, sym);
+ if (guessed)
+ gfc_error ("Symbol %qs at %L has no IMPLICIT type"
+ "; did you mean %qs?",
+ sym->name, &sym->declared_at, guessed);
+ else
+ gfc_error ("Symbol %qs at %L has no IMPLICIT type",
+ sym->name, &sym->declared_at);
sym->attr.untyped = 1; /* Ensure we only give an error once. */
}

@@ -2188,6 +2232,30 @@ bad:
}


+/* Recursively append candidate COMPONENT structures to CANDIDATES. Store
+ the number of total candidates in CANDIDATES_LEN. */
+
+static void
+lookup_component_fuzzy_find_candidates (gfc_component *component,
+ char **&candidates,
+ size_t &candidates_len)
+{
+ for (gfc_component *p = component; p; p = p->next)
+ vec_push (candidates, candidates_len, p->name);
+}
+
+/* Lookup component MEMBER fuzzily, taking names in COMPONENT into account. */
+
+static const char*
+lookup_component_fuzzy (const char *member, gfc_component *component)
+{
+ char **candidates = NULL;
+ size_t candidates_len = 0;
+ lookup_component_fuzzy_find_candidates (component, candidates,
+ candidates_len);
+ return gfc_closest_fuzzy_match (member, candidates);
+}
+
/* Given a derived type node and a component name, try to locate the
component structure. Returns the NULL pointer if the component is
not found or the components are private. If noaccess is set, no access
@@ -2238,8 +2306,16 @@ gfc_find_component (gfc_symbol *sym, const char *name,
}

if (p == NULL && !silent)
- gfc_error ("%qs at %C is not a member of the %qs structure",
- name, sym->name);
+ {
+ const char *guessed = lookup_component_fuzzy (name, sym->components);
+ if (guessed)
+ gfc_error ("%qs at %C is not a member of the %qs structure"
+ "; did you mean %qs?",
+ name, sym->name, guessed);
+ else
+ gfc_error ("%qs at %C is not a member of the %qs structure",
+ name, sym->name);
+ }

return p;
}
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-operator.f90 b/gcc/testsuite/gfortran.dg/spellcheck-operator.f90
new file mode 100644
index 0000000..810a770
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-operator.f90
@@ -0,0 +1,30 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+module mymod1
+ implicit none
+ contains
+ function something_good (iarg1)
+ integer :: something_good
+ integer, intent(in) :: iarg1
+ something_good = iarg1 + 42
+ end function something_good
+end module mymod1
+
+program spellchekc
+ use mymod1
+ implicit none
+
+ interface operator (.mywrong.)
+ module procedure something_wring ! { dg-error "Procedure .something_wring. in operator interface .mywrong. at .1. is neither function nor subroutine; did you mean .something_good.\\?|User operator procedure .something_wring. at .1. must be a FUNCTION" }
+ end interface
+
+ interface operator (.mygood.)
+ module procedure something_good
+ end interface
+
+ integer :: i, j, added
+ i = 0
+ j = 0
+ added = .mygoof. j ! { dg-error "Unknown operator .mygoof. at .1.; did you mean .mygood.\\?" }
+end program spellchekc
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-parameter.f90 b/gcc/testsuite/gfortran.dg/spellcheck-parameter.f90
new file mode 100644
index 0000000..715c5ab
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-parameter.f90
@@ -0,0 +1,15 @@
+! { dg-do compile }
+! Contributed by Joost VandeVondele
+! test levenshtein based spelling suggestions for keyword arguments
+
+module test
+contains
+ subroutine mysub(iarg1)
+ integer :: iarg1
+ end subroutine
+end module
+
+use test
+call mysub(iarg=1) ! { dg-error "Keyword argument .iarg. at .1. is not in the procedure; did you mean .iarg1.\\?" }
+
+end
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90 b/gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90
new file mode 100644
index 0000000..3b7f716
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90
@@ -0,0 +1,41 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+module mymod1
+ implicit none
+ contains
+ function something_else (iarg1)
+ integer :: something_else
+ integer, intent(in) :: iarg1
+ something_else = iarg1 + 42
+ end function something_else
+ function add_fourtytwo (iarg1)
+ integer :: add_fourtytwo
+ integer, intent(in) :: iarg1
+ add_fourtytwo = iarg1 + 42
+ end function add_fourtytwo
+end module mymod1
+
+function myadd(iarg1, iarg2)
+ implicit none
+ integer :: myadd
+ integer, intent(in) :: iarg1, iarg2
+ myadd = iarg1 + iarg2
+end function myadd
+
+program spellchekc
+ use mymod1, something_good => something_else
+ implicit none
+
+ integer :: myadd, i, j, myvar
+ i = 0
+ j = 0
+
+ j = something_goof(j) ! { dg-error "no IMPLICIT type; did you mean .something_good.\\?" }
+ j = myaddd(i, j) ! { dg-error "no IMPLICIT type; did you mean .myadd.\\?" }
+ if (j /= 42) call abort
+ j = add_fourtytow(i, j) ! { dg-error "no IMPLICIT type; did you mean .add_fourtytwo.\\?" }
+ myval = myadd(i, j) ! { dg-error "no IMPLICIT type; did you mean .myvar.\\?" }
+ if (j /= 42 * 2) call abort
+
+end program spellchekc
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90 b/gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90
new file mode 100644
index 0000000..a6ea5f9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+
+program spellchekc
+ implicit none (external) ! { dg-warning "GNU Extension: IMPORT NONE with spec list" }
+
+ interface
+ subroutine bark_unless_zero(iarg)
+ implicit none
+ integer, intent(in) :: iarg
+ end subroutine bark_unless_zero
+ end interface
+
+ integer :: i
+ i = 0
+
+ if (i /= 1) call abort
+ call bark_unless_0(i) ! { dg-error "not explicitly declared; did you mean .bark_unless_zero.\\?" }
+! call complain_about_0(i) ! { -dg-error "not explicitly declared; did you mean .complain_about_zero.\\?" }
+
+contains
+! We cannot reliably see this ATM, would need an unambiguous bit somewhere
+ subroutine complain_about_zero(iarg)
+ integer, intent(in) :: iarg
+ if (iarg /= 0) call abort
+ end subroutine complain_about_zero
+
+end program spellchekc
+
+subroutine bark_unless_zero(iarg)
+ implicit none
+ integer, intent(in) :: iarg
+ if (iarg /= 0) call abort
+end subroutine bark_unless_zero
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-structure.f90 b/gcc/testsuite/gfortran.dg/spellcheck-structure.f90
new file mode 100644
index 0000000..929e05f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-structure.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+implicit none
+
+!!!!!!!!!!!!!! structure tests !!!!!!!!!!!!!!
+type type1
+ real :: radius
+ integer :: i
+end type type1
+
+type type2
+ integer :: myint
+ type(type1) :: mytype
+end type type2
+
+type type3
+ type(type2) :: type_2
+end type type3
+type type4
+ type(type3) :: type_3
+end type type4
+
+type(type1) :: t1
+t1%radiuz = .0 ! { dg-error ".radiuz. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+t1%x = .0 ! { dg-error ".x. at .1. is not a member of the .type1. structure" }
+type(type2) :: t2
+t2%mytape%radius = .0 ! { dg-error ".mytape. at .1. is not a member of the .type2. structure; did you mean .mytype.\\?" }
+t2%mytype%radious = .0 ! { dg-error ".radious. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+type(type4) :: t4
+t4%type_3%type_2%mytype%radium = 88.0 ! { dg-error ".radium. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+
+!!!!!!!!!!!!!! symbol tests !!!!!!!!!!!!!!
+integer :: iarg1
+iarg2 = 1 ! { dg-error "Symbol .iarg2. at .1. has no IMPLICIT type; did you mean .iarg1.\\?" }
+end

[David Malcolm]

On Sat, 2016-03-05 at 23:46 +0100, Bernhard Reutner-Fischer wrote:
[...]

Post by Bernhard Reutner-Fischer
diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
index 405bae0..72ed311 100644
--- a/gcc/fortran/misc.c
+++ b/gcc/fortran/misc.c

[...]

Post by Bernhard Reutner-Fischer
@@ -274,3 +275,41 @@ get_c_kind(const char *c_kind_name,teropKind_tki
nds_table[])
return ISOCBINDING_INVALID;
}
+
+
+/* For a given name TYPO, determine the best candidate from
CANDIDATES
+ perusing Levenshtein distance. Frees CANDIDATES before
returning. */
+
+const char *
+gfc_closest_fuzzy_match (const char *typo, char **candidates)
+{
+ /* Determine closest match. */
+ const char *best = NULL;
+ char **cand = candidates;
+ edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+
+ while (cand && *cand)
+ {
+ edit_distance_t dist = levenshtein_distance (typo, *cand);
+ if (dist < best_distance)
+ {
+ best_distance = dist;
+ best = *cand;
+ }
+ cand++;
+ }
+ /* If more than half of the letters were misspelled, the
suggestion is
+ likely to be meaningless. */
+ if (best)
+ {
+ unsigned int cutoff = MAX (strlen (typo), strlen (best)) / 2;
+
+ if (best_distance > cutoff)
+ {
+ XDELETEVEC (candidates);
+ return NULL;
+ }
+ XDELETEVEC (candidates);
+ }
+ return best;
+}

FWIW, there are two overloaded variants of levenshtein_distance in
gcc/spellcheck.h, the first of which takes a pair of strlen values;
your patch uses the second one:

extern edit_distance_t
levenshtein_distance (const char *s, int len_s,
const char *t, int len_t);

extern edit_distance_t
levenshtein_distance (const char *s, const char *t);

So one minor tweak you may want to consider here is to calculate
strlen (typo)
once at the top of gfc_closest_fuzzy_match, and then pass it in to the
4-arg variant of levenshtein_distance, which would avoid recalculating
strlen (typo) for every candidate.

I can't comment on the rest of the patch (I'm not a Fortran expert),
though it seems sane to

Hope this is constructive
Dave

[Bernhard Reutner-Fischer]

Post by David Malcolm
[...]

Post by Bernhard Reutner-Fischer
diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
index 405bae0..72ed311 100644
--- a/gcc/fortran/misc.c
+++ b/gcc/fortran/misc.c

[...]

Post by Bernhard Reutner-Fischer
@@ -274,3 +275,41 @@ get_c_kind(const char *c_kind_name,teropKind_tki
nds_table[])
return ISOCBINDING_INVALID;
}
+
+
+/* For a given name TYPO, determine the best candidate from
CANDIDATES
+ perusing Levenshtein distance. Frees CANDIDATES before
returning. */
+
+const char *
+gfc_closest_fuzzy_match (const char *typo, char **candidates)
+{
+ /* Determine closest match. */
+ const char *best = NULL;
+ char **cand = candidates;
+ edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+
+ while (cand && *cand)
+ {
+ edit_distance_t dist = levenshtein_distance (typo, *cand);
+ if (dist < best_distance)
+ {
+ best_distance = dist;
+ best = *cand;
+ }
+ cand++;
+ }
+ /* If more than half of the letters were misspelled, the
suggestion is
+ likely to be meaningless. */
+ if (best)
+ {
+ unsigned int cutoff = MAX (strlen (typo), strlen (best)) / 2;
+
+ if (best_distance > cutoff)
+ {
+ XDELETEVEC (candidates);
+ return NULL;
+ }
+ XDELETEVEC (candidates);
+ }
+ return best;
+}

FWIW, there are two overloaded variants of levenshtein_distance in
gcc/spellcheck.h, the first of which takes a pair of strlen values;
extern edit_distance_t
levenshtein_distance (const char *s, int len_s,
const char *t, int len_t);
extern edit_distance_t
levenshtein_distance (const char *s, const char *t);
So one minor tweak you may want to consider here is to calculate
strlen (typo)
once at the top of gfc_closest_fuzzy_match, and then pass it in to the
4-arg variant of levenshtein_distance, which would avoid recalculating
strlen (typo) for every candidate.

I've pondered this back then but came to the conclusion to use the variant without len because to use the 4 argument variant I would have stored the candidates strlen in the vector too and was not convinced about the memory footprint for that would be justified. Maybe it is, but I would prefer the following tweak in the 4 argument variant:
If you would amend the 4 argument variant with a

if (len_t == -1)
len_t = strlen (t);
before the
  if (len_s == 0)
    return len_t;
  if (len_t == 0)
    return len_s;

checks then I'd certainly use the 4 arg variant :)

WDYT?

Post by David Malcolm
I can't comment on the rest of the patch (I'm not a Fortran expert),
though it seems sane to
Hope this is constructive

It is, thanks for your thoughts!

cheers,

[David Malcolm]

On March 7, 2016 3:57:16 PM GMT+01:00, David Malcolm <

Post by David Malcolm
[...]

Post by Bernhard Reutner-Fischer
diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
index 405bae0..72ed311 100644
--- a/gcc/fortran/misc.c
+++ b/gcc/fortran/misc.c

[...]

Post by Bernhard Reutner-Fischer
@@ -274,3 +275,41 @@ get_c_kind(const char
*c_kind_name,teropKind_tki
nds_table[])
return ISOCBINDING_INVALID;
}
+
+
+/* For a given name TYPO, determine the best candidate from CANDIDATES
+ perusing Levenshtein distance. Frees CANDIDATES before returning. */
+
+const char *
+gfc_closest_fuzzy_match (const char *typo, char **candidates)
+{
+ /* Determine closest match. */
+ const char *best = NULL;
+ char **cand = candidates;
+ edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+
+ while (cand && *cand)
+ {
+ edit_distance_t dist = levenshtein_distance (typo, *cand);
+ if (dist < best_distance)
+ {
+ best_distance = dist;
+ best = *cand;
+ }
+ cand++;
+ }
+ /* If more than half of the letters were misspelled, the suggestion is
+ likely to be meaningless. */
+ if (best)
+ {
+ unsigned int cutoff = MAX (strlen (typo), strlen (best)) / 2;
+
+ if (best_distance > cutoff)
+ {
+ XDELETEVEC (candidates);
+ return NULL;
+ }
+ XDELETEVEC (candidates);
+ }
+ return best;
+}

FWIW, there are two overloaded variants of levenshtein_distance in
gcc/spellcheck.h, the first of which takes a pair of strlen values;
extern edit_distance_t
levenshtein_distance (const char *s, int len_s,
const char *t, int len_t);
extern edit_distance_t
levenshtein_distance (const char *s, const char *t);
So one minor tweak you may want to consider here is to calculate
strlen (typo)
once at the top of gfc_closest_fuzzy_match, and then pass it in to the
4-arg variant of levenshtein_distance, which would avoid
recalculating
strlen (typo) for every candidate.

I've pondered this back then but came to the conclusion to use the
variant without len because to use the 4 argument variant I would
have stored the candidates strlen in the vector too

Why would you need to do that? You can simply call strlen inside the
loop instead; something like:

size_t strlen_typo = strlen (typo);
while (cand && *cand)
{
edit_distance_t dist = levenshtein_distance (typo, strlen_typo,
*cand, strlen (*cand));

etc

and was not convinced about the memory footprint for that would be
justified. Maybe it is, but I would prefer the following tweak in the
If you would amend the 4 argument variant with a
if (len_t == -1)
len_t = strlen (t);
before the
if (len_s == 0)
return len_t;
if (len_t == 0)
return len_s;
checks then I'd certainly use the 4 arg variant :)
WDYT?

Post by David Malcolm
I can't comment on the rest of the patch (I'm not a Fortran
expert),
though it seems sane to
Hope this is constructive

It is, thanks for your thoughts!
cheers,

[Bernhard Reutner-Fischer]

Hi,

Ok for trunk?

Changes for v4 -> v3:

- rebased
- Use 4 argument levenshtein_distance() to save multiple strlen(typo)
calls as suggested by dmalcolm

Changes for v2 -> v3:

- rebased

Changes for v1 -> v2:

- subroutines using interfaces
- keyword arguments (named parameters)

Rewrite C++ autovec in plain C.
Factor out levenshtein distance handling into a commonly used
gfc_closest_fuzzy_match().

gcc/fortran/ChangeLog

2015-12-27 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* gfortran.h (gfc_lookup_function_fuzzy): New declaration.
(gfc_closest_fuzzy_match): New declaration.
(vec_push): New definition.
* misc.c (gfc_closest_fuzzy_match): New definition.
* resolve.c: Include spellcheck.h.
(lookup_function_fuzzy_find_candidates): New static function.
(lookup_uop_fuzzy_find_candidates): Likewise.
(lookup_uop_fuzzy): Likewise.
(resolve_operator) <INTRINSIC_USER>: Call lookup_uop_fuzzy.
(gfc_lookup_function_fuzzy): New definition.
(resolve_unknown_f): Call gfc_lookup_function_fuzzy.
* interface.c (check_interface0): Likewise.
(lookup_arg_fuzzy_find_candidates): New static function.
(lookup_arg_fuzzy ): Likewise.
(compare_actual_formal): Call lookup_arg_fuzzy.
* symbol.c: Include spellcheck.h.
(lookup_symbol_fuzzy_find_candidates): New static function.
(lookup_symbol_fuzzy): Likewise.
(gfc_set_default_type): Call lookup_symbol_fuzzy.
(lookup_component_fuzzy_find_candidates): New static function.
(lookup_component_fuzzy): Likewise.
(gfc_find_component): Call lookup_component_fuzzy.

gcc/testsuite/ChangeLog

2015-12-27 Bernhard Reutner-Fischer <***@gcc.gnu.org>

* gfortran.dg/spellcheck-operator.f90: New testcase.
* gfortran.dg/spellcheck-procedure_1.f90: New testcase.
* gfortran.dg/spellcheck-procedure_2.f90: New testcase.
* gfortran.dg/spellcheck-structure.f90: New testcase.
* gfortran.dg/spellcheck-parameter.f90: New testcase.

---

David Malcolm's nice Levenshtein distance spelling check helpers
were used in some parts of other frontends. This proposed patch adds
some spelling corrections to the fortran frontend.

Suggestions are printed if we can find a suitable name, currently
perusing a very simple cutoff factor:
/* If more than half of the letters were misspelled, the suggestion is
likely to be meaningless. */
cutoff = MAX (strlen (typo), strlen (best_guess)) / 2;
which effectively skips names with less than 4 characters.
For e.g. structures, one could try to be much smarter in an attempt to
also provide suggestions for single-letter members/components.

This patch covers (at least partly):
- user-defined operators
- structures (types and their components)
- functions
- symbols (variables)

If anybody has a testcase where a spelling-suggestion would make sense
then please pass it along so we maybe can add support for GCC-7.

Signed-off-by: Bernhard Reutner-Fischer <***@gmail.com>
---
gcc/fortran/gfortran.h | 12 +++
gcc/fortran/interface.c | 72 +++++++++++++--
gcc/fortran/misc.c | 41 +++++++++
gcc/fortran/resolve.c | 100 ++++++++++++++++++++-
gcc/fortran/symbol.c | 86 +++++++++++++++++-
gcc/testsuite/gfortran.dg/spellcheck-operator.f90 | 30 +++++++
gcc/testsuite/gfortran.dg/spellcheck-parameter.f90 | 15 ++++
.../gfortran.dg/spellcheck-procedure_1.f90 | 41 +++++++++
.../gfortran.dg/spellcheck-procedure_2.f90 | 35 ++++++++
gcc/testsuite/gfortran.dg/spellcheck-structure.f90 | 35 ++++++++
10 files changed, 450 insertions(+), 17 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-operator.f90
create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-parameter.f90
create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90
create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90
create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-structure.f90

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 0bb71cb..5d43c2d 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2682,6 +2682,17 @@ void gfc_done_2 (void);

int get_c_kind (const char *, CInteropKind_t *);

+const char *gfc_closest_fuzzy_match (const char *, char **);
+static inline void
+vec_push (char **&optr, size_t &osz, const char *elt)
+{
+ /* {auto,}vec.safe_push () replacement. Don't ask.. */
+ // if (strlen (elt) < 4) return; premature optimization: eliminated by cutoff
+ optr = XRESIZEVEC (char *, optr, osz + 2);
+ optr[osz] = CONST_CAST (char *, elt);
+ optr[++osz] = NULL;
+}
+
/* options.c */
unsigned int gfc_option_lang_mask (void);
void gfc_init_options_struct (struct gcc_options *);
@@ -3103,6 +3114,7 @@ bool gfc_type_is_extensible (gfc_symbol *);
bool gfc_resolve_intrinsic (gfc_symbol *, locus *);
bool gfc_explicit_interface_required (gfc_symbol *, char *, int);
extern int gfc_do_concurrent_flag;
+const char* gfc_lookup_function_fuzzy (const char *, gfc_symtree *);


/* array.c */
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index b012de5..bef514c 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1694,13 +1694,27 @@ check_interface0 (gfc_interface *p, const char *interface_name)
|| !p->sym->attr.if_source)
&& !gfc_fl_struct (p->sym->attr.flavor))
{
+ const char *guessed
+ = gfc_lookup_function_fuzzy (p->sym->name, p->sym->ns->sym_root);
+
if (p->sym->attr.external)
- gfc_error ("Procedure %qs in %s at %L has no explicit interface",
- p->sym->name, interface_name, &p->sym->declared_at);
+ if (guessed)
+ gfc_error ("Procedure %qs in %s at %L has no explicit interface"
+ "; did you mean %qs?",
+ p->sym->name, interface_name, &p->sym->declared_at,
+ guessed);
+ else
+ gfc_error ("Procedure %qs in %s at %L has no explicit interface",
+ p->sym->name, interface_name, &p->sym->declared_at);
else
- gfc_error ("Procedure %qs in %s at %L is neither function nor "
- "subroutine", p->sym->name, interface_name,
- &p->sym->declared_at);
+ if (guessed)
+ gfc_error ("Procedure %qs in %s at %L is neither function nor "
+ "subroutine; did you mean %qs?", p->sym->name,
+ interface_name, &p->sym->declared_at, guessed);
+ else
+ gfc_error ("Procedure %qs in %s at %L is neither function nor "
+ "subroutine", p->sym->name, interface_name,
+ &p->sym->declared_at);
return 1;
}

@@ -2684,6 +2698,31 @@ is_procptr_result (gfc_expr *expr)
}


+/* Recursively append candidate argument ARG to CANDIDATES. Store the
+ number of total candidates in CANDIDATES_LEN. */
+
+static void
+lookup_arg_fuzzy_find_candidates (gfc_formal_arglist *arg,
+ char **&candidates,
+ size_t &candidates_len)
+{
+ for (gfc_formal_arglist *p = arg; p && p->sym; p = p->next)
+ vec_push (candidates, candidates_len, p->sym->name);
+}
+
+
+/* Lookup argument ARG fuzzily, taking names in ARGUMENTS into account. */
+
+static const char*
+lookup_arg_fuzzy (const char *arg, gfc_formal_arglist *arguments)
+{
+ char **candidates = NULL;
+ size_t candidates_len = 0;
+ lookup_arg_fuzzy_find_candidates (arguments, candidates, candidates_len);
+ return gfc_closest_fuzzy_match (arg, candidates);
+}
+
+
/* Given formal and actual argument lists, see if they are compatible.
If they are compatible, the actual argument list is sorted to
correspond with the formal list, and elements for missing optional
@@ -2736,8 +2775,16 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
if (f == NULL)
{
if (where)
- gfc_error ("Keyword argument %qs at %L is not in "
- "the procedure", a->name, &a->expr->where);
+ {
+ const char *guessed = lookup_arg_fuzzy (a->name, formal);
+ if (guessed)
+ gfc_error ("Keyword argument %qs at %L is not in "
+ "the procedure; did you mean %qs?",
+ a->name, &a->expr->where, guessed);
+ else
+ gfc_error ("Keyword argument %qs at %L is not in "
+ "the procedure", a->name, &a->expr->where);
+ }
return 0;
}

@@ -3436,8 +3483,15 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
{
if (sym->ns->has_implicit_none_export && sym->attr.proc == PROC_UNKNOWN)
{
- gfc_error ("Procedure %qs called at %L is not explicitly declared",
- sym->name, where);
+ const char *guessed
+ = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
+ if (guessed)
+ gfc_error ("Procedure %qs called at %L is not explicitly declared"
+ "; did you mean %qs?",
+ sym->name, where, guessed);
+ else
+ gfc_error ("Procedure %qs called at %L is not explicitly declared",
+ sym->name, where);
return false;
}
if (warn_implicit_interface)
diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
index 1747ff2..dd17f46 100644
--- a/gcc/fortran/misc.c
+++ b/gcc/fortran/misc.c
@@ -22,6 +22,7 @@ along with GCC; see the file COPYING3. If not see
#include "system.h"
#include "coretypes.h"
#include "gfortran.h"
+#include "spellcheck.h"


/* Initialize a typespec to unknown. */
@@ -280,3 +281,43 @@ get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])

return ISOCBINDING_INVALID;
}
+
+
+/* For a given name TYPO, determine the best candidate from CANDIDATES
+ perusing Levenshtein distance. Frees CANDIDATES before returning. */
+
+const char *
+gfc_closest_fuzzy_match (const char *typo, char **candidates)
+{
+ /* Determine closest match. */
+ const char *best = NULL;
+ char **cand = candidates;
+ edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+ const size_t tl = strlen (typo);
+
+ while (cand && *cand)
+ {
+ edit_distance_t dist = levenshtein_distance (typo, tl, *cand,
+ strlen (*cand));
+ if (dist < best_distance)
+ {
+ best_distance = dist;
+ best = *cand;
+ }
+ cand++;
+ }
+ /* If more than half of the letters were misspelled, the suggestion is
+ likely to be meaningless. */
+ if (best)
+ {
+ unsigned int cutoff = MAX (tl, strlen (best)) / 2;
+
+ if (best_distance > cutoff)
+ {
+ XDELETEVEC (candidates);
+ return NULL;
+ }
+ XDELETEVEC (candidates);
+ }
+ return best;
+}
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 77f8c10..089afa3 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -2693,6 +2693,43 @@ resolve_specific_f (gfc_expr *expr)
return true;
}

+/* Recursively append candidate SYM to CANDIDATES. Store the number of
+ candidates in CANDIDATES_LEN. */
+
+static void
+lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
+ char **&candidates,
+ size_t &candidates_len)
+{
+ gfc_symtree *p;
+
+ if (sym == NULL)
+ return;
+ if ((sym->n.sym->ts.type != BT_UNKNOWN || sym->n.sym->attr.external)
+ && sym->n.sym->attr.flavor == FL_PROCEDURE)
+ vec_push (candidates, candidates_len, sym->name);
+
+ p = sym->left;
+ if (p)
+ lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
+
+ p = sym->right;
+ if (p)
+ lookup_function_fuzzy_find_candidates (p, candidates, candidates_len);
+}
+
+
+/* Lookup function FN fuzzily, taking names in SYMROOT into account. */
+
+const char*
+gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *symroot)
+{
+ char **candidates = NULL;
+ size_t candidates_len = 0;
+ lookup_function_fuzzy_find_candidates (symroot, candidates, candidates_len);
+ return gfc_closest_fuzzy_match (fn, candidates);
+}
+

/* Resolve a procedure call not known to be generic nor specific. */

@@ -2743,8 +2780,15 @@ set_type:

if (ts->type == BT_UNKNOWN)
{
- gfc_error ("Function %qs at %L has no IMPLICIT type",
- sym->name, &expr->where);
+ const char *guessed
+ = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
+ if (guessed)
+ gfc_error ("Function %qs at %L has no IMPLICIT type"
+ "; did you mean %qs?",
+ sym->name, &expr->where, guessed);
+ else
+ gfc_error ("Function %qs at %L has no IMPLICIT type",
+ sym->name, &expr->where);
return false;
}
else
@@ -3516,6 +3560,46 @@ compare_shapes (gfc_expr *op1, gfc_expr *op2)
}


+/* Recursively append candidate UOP to CANDIDATES. Store the number of
+ candidates in CANDIDATES_LEN. */
+static void
+lookup_uop_fuzzy_find_candidates (gfc_symtree *uop,
+ char **&candidates,
+ size_t &candidates_len)
+{
+ gfc_symtree *p;
+
+ if (uop == NULL)
+ return;
+
+ /* Not sure how to properly filter here. Use all for a start.
+ n.uop.op is NULL for empty interface operators (is that legal?) disregard
+ these as i suppose they don't make terribly sense. */
+
+ if (uop->n.uop->op != NULL)
+ vec_push (candidates, candidates_len, uop->name);
+
+ p = uop->left;
+ if (p)
+ lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
+
+ p = uop->right;
+ if (p)
+ lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
+}
+
+/* Lookup user-operator OP fuzzily, taking names in UOP into account. */
+
+static const char*
+lookup_uop_fuzzy (const char *op, gfc_symtree *uop)
+{
+ char **candidates = NULL;
+ size_t candidates_len = 0;
+ lookup_uop_fuzzy_find_candidates (uop, candidates, candidates_len);
+ return gfc_closest_fuzzy_match (op, candidates);
+}
+
+
/* Resolve an operator expression node. This can involve replacing the
operation with a user defined function call. */

@@ -3714,8 +3798,16 @@ resolve_operator (gfc_expr *e)

case INTRINSIC_USER:
if (e->value.op.uop->op == NULL)
- sprintf (msg, _("Unknown operator %%<%s%%> at %%L"),
- e->value.op.uop->name);
+ {
+ const char *name = e->value.op.uop->name;
+ const char *guessed;
+ guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root);
+ if (guessed)
+ sprintf (msg, _("Unknown operator %%<%s%%> at %%L; did you mean '%s'?"),
+ name, guessed);
+ else
+ sprintf (msg, _("Unknown operator %%<%s%%> at %%L"), name);
+ }
else if (op2 == NULL)
sprintf (msg, _("Operand of user operator %%<%s%%> at %%L is %s"),
e->value.op.uop->name, gfc_typename (&op1->ts));
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 0ee7dec..776610c 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -236,6 +236,44 @@ gfc_get_default_type (const char *name, gfc_namespace *ns)
}


+/* Recursively append candidate SYM to CANDIDATES. Store the number of
+ candidates in CANDIDATES_LEN. */
+
+static void
+lookup_symbol_fuzzy_find_candidates (gfc_symtree *sym,
+ char **&candidates,
+ size_t &candidates_len)
+{
+ gfc_symtree *p;
+
+ if (sym == NULL)
+ return;
+
+ if (sym->n.sym->ts.type != BT_UNKNOWN && sym->n.sym->ts.type != BT_PROCEDURE)
+ vec_push (candidates, candidates_len, sym->name);
+ p = sym->left;
+ if (p)
+ lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len);
+
+ p = sym->right;
+ if (p)
+ lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len);
+}
+
+
+/* Lookup symbol SYM_NAME fuzzily, taking names in SYMBOL into account. */
+
+static const char*
+lookup_symbol_fuzzy (const char *sym_name, gfc_symbol *symbol)
+{
+ char **candidates = NULL;
+ size_t candidates_len = 0;
+ lookup_symbol_fuzzy_find_candidates (symbol->ns->sym_root, candidates,
+ candidates_len);
+ return gfc_closest_fuzzy_match (sym_name, candidates);
+}
+
+
/* Given a pointer to a symbol, set its type according to the first
letter of its name. Fails if the letter in question has no default
type. */
@@ -254,8 +292,14 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
{
if (error_flag && !sym->attr.untyped)
{
- gfc_error ("Symbol %qs at %L has no IMPLICIT type",
- sym->name, &sym->declared_at);
+ const char *guessed = lookup_symbol_fuzzy (sym->name, sym);
+ if (guessed)
+ gfc_error ("Symbol %qs at %L has no IMPLICIT type"
+ "; did you mean %qs?",
+ sym->name, &sym->declared_at, guessed);
+ else
+ gfc_error ("Symbol %qs at %L has no IMPLICIT type",
+ sym->name, &sym->declared_at);
sym->attr.untyped = 1; /* Ensure we only give an error once. */
}

@@ -2233,6 +2277,32 @@ find_union_component (gfc_symbol *un, const char *name,
}


+/* Recursively append candidate COMPONENT structures to CANDIDATES. Store
+ the number of total candidates in CANDIDATES_LEN. */
+
+static void
+lookup_component_fuzzy_find_candidates (gfc_component *component,
+ char **&candidates,
+ size_t &candidates_len)
+{
+ for (gfc_component *p = component; p; p = p->next)
+ vec_push (candidates, candidates_len, p->name);
+}
+
+
+/* Lookup component MEMBER fuzzily, taking names in COMPONENT into account. */
+
+static const char*
+lookup_component_fuzzy (const char *member, gfc_component *component)
+{
+ char **candidates = NULL;
+ size_t candidates_len = 0;
+ lookup_component_fuzzy_find_candidates (component, candidates,
+ candidates_len);
+ return gfc_closest_fuzzy_match (member, candidates);
+}
+
+
/* Given a derived type node and a component name, try to locate the
component structure. Returns the NULL pointer if the component is
not found or the components are private. If noaccess is set, no access
@@ -2330,8 +2400,16 @@ gfc_find_component (gfc_symbol *sym, const char *name,
}

if (p == NULL && !silent)
- gfc_error ("%qs at %C is not a member of the %qs structure",
- name, sym->name);
+ {
+ const char *guessed = lookup_component_fuzzy (name, sym->components);
+ if (guessed)
+ gfc_error ("%qs at %C is not a member of the %qs structure"
+ "; did you mean %qs?",
+ name, sym->name, guessed);
+ else
+ gfc_error ("%qs at %C is not a member of the %qs structure",
+ name, sym->name);
+ }

/* Component was found; build the ultimate component reference. */
if (p != NULL && ref)
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-operator.f90 b/gcc/testsuite/gfortran.dg/spellcheck-operator.f90
new file mode 100644
index 0000000..810a770
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-operator.f90
@@ -0,0 +1,30 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+module mymod1
+ implicit none
+ contains
+ function something_good (iarg1)
+ integer :: something_good
+ integer, intent(in) :: iarg1
+ something_good = iarg1 + 42
+ end function something_good
+end module mymod1
+
+program spellchekc
+ use mymod1
+ implicit none
+
+ interface operator (.mywrong.)
+ module procedure something_wring ! { dg-error "Procedure .something_wring. in operator interface .mywrong. at .1. is neither function nor subroutine; did you mean .something_good.\\?|User operator procedure .something_wring. at .1. must be a FUNCTION" }
+ end interface
+
+ interface operator (.mygood.)
+ module procedure something_good
+ end interface
+
+ integer :: i, j, added
+ i = 0
+ j = 0
+ added = .mygoof. j ! { dg-error "Unknown operator .mygoof. at .1.; did you mean .mygood.\\?" }
+end program spellchekc
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-parameter.f90 b/gcc/testsuite/gfortran.dg/spellcheck-parameter.f90
new file mode 100644
index 0000000..715c5ab
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-parameter.f90
@@ -0,0 +1,15 @@
+! { dg-do compile }
+! Contributed by Joost VandeVondele
+! test levenshtein based spelling suggestions for keyword arguments
+
+module test
+contains
+ subroutine mysub(iarg1)
+ integer :: iarg1
+ end subroutine
+end module
+
+use test
+call mysub(iarg=1) ! { dg-error "Keyword argument .iarg. at .1. is not in the procedure; did you mean .iarg1.\\?" }
+
+end
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90 b/gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90
new file mode 100644
index 0000000..3b7f716
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90
@@ -0,0 +1,41 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+module mymod1
+ implicit none
+ contains
+ function something_else (iarg1)
+ integer :: something_else
+ integer, intent(in) :: iarg1
+ something_else = iarg1 + 42
+ end function something_else
+ function add_fourtytwo (iarg1)
+ integer :: add_fourtytwo
+ integer, intent(in) :: iarg1
+ add_fourtytwo = iarg1 + 42
+ end function add_fourtytwo
+end module mymod1
+
+function myadd(iarg1, iarg2)
+ implicit none
+ integer :: myadd
+ integer, intent(in) :: iarg1, iarg2
+ myadd = iarg1 + iarg2
+end function myadd
+
+program spellchekc
+ use mymod1, something_good => something_else
+ implicit none
+
+ integer :: myadd, i, j, myvar
+ i = 0
+ j = 0
+
+ j = something_goof(j) ! { dg-error "no IMPLICIT type; did you mean .something_good.\\?" }
+ j = myaddd(i, j) ! { dg-error "no IMPLICIT type; did you mean .myadd.\\?" }
+ if (j /= 42) call abort
+ j = add_fourtytow(i, j) ! { dg-error "no IMPLICIT type; did you mean .add_fourtytwo.\\?" }
+ myval = myadd(i, j) ! { dg-error "no IMPLICIT type; did you mean .myvar.\\?" }
+ if (j /= 42 * 2) call abort
+
+end program spellchekc
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90 b/gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90
new file mode 100644
index 0000000..a6ea5f9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+
+program spellchekc
+ implicit none (external) ! { dg-warning "GNU Extension: IMPORT NONE with spec list" }
+
+ interface
+ subroutine bark_unless_zero(iarg)
+ implicit none
+ integer, intent(in) :: iarg
+ end subroutine bark_unless_zero
+ end interface
+
+ integer :: i
+ i = 0
+
+ if (i /= 1) call abort
+ call bark_unless_0(i) ! { dg-error "not explicitly declared; did you mean .bark_unless_zero.\\?" }
+! call complain_about_0(i) ! { -dg-error "not explicitly declared; did you mean .complain_about_zero.\\?" }
+
+contains
+! We cannot reliably see this ATM, would need an unambiguous bit somewhere
+ subroutine complain_about_zero(iarg)
+ integer, intent(in) :: iarg
+ if (iarg /= 0) call abort
+ end subroutine complain_about_zero
+
+end program spellchekc
+
+subroutine bark_unless_zero(iarg)
+ implicit none
+ integer, intent(in) :: iarg
+ if (iarg /= 0) call abort
+end subroutine bark_unless_zero
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-structure.f90 b/gcc/testsuite/gfortran.dg/spellcheck-structure.f90
new file mode 100644
index 0000000..929e05f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-structure.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+implicit none
+
+!!!!!!!!!!!!!! structure tests !!!!!!!!!!!!!!
+type type1
+ real :: radius
+ integer :: i
+end type type1
+
+type type2
+ integer :: myint
+ type(type1) :: mytype
+end type type2
+
+type type3
+ type(type2) :: type_2
+end type type3
+type type4
+ type(type3) :: type_3
+end type type4
+
+type(type1) :: t1
+t1%radiuz = .0 ! { dg-error ".radiuz. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+t1%x = .0 ! { dg-error ".x. at .1. is not a member of the .type1. structure" }
+type(type2) :: t2
+t2%mytape%radius = .0 ! { dg-error ".mytape. at .1. is not a member of the .type2. structure; did you mean .mytype.\\?" }
+t2%mytype%radious = .0 ! { dg-error ".radious. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+type(type4) :: t4
+t4%type_3%type_2%mytype%radium = 88.0 ! { dg-error ".radium. at .1. is not a member of the .type1. structure; did you mean .radius.\\?" }
+
+!!!!!!!!!!!!!! symbol tests !!!!!!!!!!!!!!
+integer :: iarg1
+iarg2 = 1 ! { dg-error "Symbol .iarg2. at .1. has no IMPLICIT type; did you mean .iarg1.\\?" }
+end

[VandeVondele Joost]

From my point of view, would be really nice to have.

Joost

[Bernhard Reutner-Fischer]

Ping

Post by Bernhard Reutner-Fischer
Hi,
Ok for trunk?
- rebased
- Use 4 argument levenshtein_distance() to save multiple strlen(typo)
calls as suggested by dmalcolm
- rebased
- subroutines using interfaces
- keyword arguments (named parameters)
Rewrite C++ autovec in plain C.
Factor out levenshtein distance handling into a commonly used
gfc_closest_fuzzy_match().
gcc/fortran/ChangeLog
* gfortran.h (gfc_lookup_function_fuzzy): New declaration.
(gfc_closest_fuzzy_match): New declaration.
(vec_push): New definition.
* misc.c (gfc_closest_fuzzy_match): New definition.
* resolve.c: Include spellcheck.h.
(lookup_function_fuzzy_find_candidates): New static function.
(lookup_uop_fuzzy_find_candidates): Likewise.
(lookup_uop_fuzzy): Likewise.
(resolve_operator) <INTRINSIC_USER>: Call lookup_uop_fuzzy.
(gfc_lookup_function_fuzzy): New definition.
(resolve_unknown_f): Call gfc_lookup_function_fuzzy.
* interface.c (check_interface0): Likewise.
(lookup_arg_fuzzy_find_candidates): New static function.
(lookup_arg_fuzzy ): Likewise.
(compare_actual_formal): Call lookup_arg_fuzzy.
* symbol.c: Include spellcheck.h.
(lookup_symbol_fuzzy_find_candidates): New static function.
(lookup_symbol_fuzzy): Likewise.
(gfc_set_default_type): Call lookup_symbol_fuzzy.
(lookup_component_fuzzy_find_candidates): New static function.
(lookup_component_fuzzy): Likewise.
(gfc_find_component): Call lookup_component_fuzzy.
gcc/testsuite/ChangeLog
* gfortran.dg/spellcheck-operator.f90: New testcase.
* gfortran.dg/spellcheck-procedure_1.f90: New testcase.
* gfortran.dg/spellcheck-procedure_2.f90: New testcase.
* gfortran.dg/spellcheck-structure.f90: New testcase.
* gfortran.dg/spellcheck-parameter.f90: New testcase.
---
David Malcolm's nice Levenshtein distance spelling check helpers
were used in some parts of other frontends. This proposed patch adds
some spelling corrections to the fortran frontend.
Suggestions are printed if we can find a suitable name, currently
/* If more than half of the letters were misspelled, the suggestion is
likely to be meaningless. */
cutoff = MAX (strlen (typo), strlen (best_guess)) / 2;
which effectively skips names with less than 4 characters.
For e.g. structures, one could try to be much smarter in an attempt to
also provide suggestions for single-letter members/components.
- user-defined operators
- structures (types and their components)
- functions
- symbols (variables)
If anybody has a testcase where a spelling-suggestion would make sense
then please pass it along so we maybe can add support for GCC-7.
---
gcc/fortran/gfortran.h | 12 +++
gcc/fortran/interface.c | 72
+++++++++++++--
gcc/fortran/misc.c | 41 +++++++++
gcc/fortran/resolve.c | 100
++++++++++++++++++++-
gcc/fortran/symbol.c | 86
+++++++++++++++++-
gcc/testsuite/gfortran.dg/spellcheck-operator.f90 | 30 +++++++
gcc/testsuite/gfortran.dg/spellcheck-parameter.f90 | 15 ++++
.../gfortran.dg/spellcheck-procedure_1.f90 | 41 +++++++++
.../gfortran.dg/spellcheck-procedure_2.f90 | 35 ++++++++
gcc/testsuite/gfortran.dg/spellcheck-structure.f90 | 35 ++++++++
10 files changed, 450 insertions(+), 17 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-operator.f90
create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-parameter.f90
create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90
create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90
create mode 100644 gcc/testsuite/gfortran.dg/spellcheck-structure.f90
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 0bb71cb..5d43c2d 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2682,6 +2682,17 @@ void gfc_done_2 (void);
int get_c_kind (const char *, CInteropKind_t *);
+const char *gfc_closest_fuzzy_match (const char *, char **);
+static inline void
+vec_push (char **&optr, size_t &osz, const char *elt)
+{
+ /* {auto,}vec.safe_push () replacement. Don't ask.. */
+ // if (strlen (elt) < 4) return; premature optimization: eliminated by cutoff
+ optr = XRESIZEVEC (char *, optr, osz + 2);
+ optr[osz] = CONST_CAST (char *, elt);
+ optr[++osz] = NULL;
+}
+
/* options.c */
unsigned int gfc_option_lang_mask (void);
void gfc_init_options_struct (struct gcc_options *);
@@ -3103,6 +3114,7 @@ bool gfc_type_is_extensible (gfc_symbol *);
bool gfc_resolve_intrinsic (gfc_symbol *, locus *);
bool gfc_explicit_interface_required (gfc_symbol *, char *, int);
extern int gfc_do_concurrent_flag;
+const char* gfc_lookup_function_fuzzy (const char *, gfc_symtree *);
/* array.c */
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index b012de5..bef514c 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1694,13 +1694,27 @@ check_interface0 (gfc_interface *p, const char *interface_name)
|| !p->sym->attr.if_source)
&& !gfc_fl_struct (p->sym->attr.flavor))
{
+ const char *guessed
+ = gfc_lookup_function_fuzzy (p->sym->name, p->sym->ns->sym_root);
+
if (p->sym->attr.external)
- gfc_error ("Procedure %qs in %s at %L has no explicit interface",
- p->sym->name, interface_name, &p->sym->declared_at);
+ if (guessed)
+ gfc_error ("Procedure %qs in %s at %L has no explicit
interface"
+ "; did you mean %qs?",
+ p->sym->name, interface_name, &p->sym->declared_at,
+ guessed);
+ else
+ gfc_error ("Procedure %qs in %s at %L has no explicit
interface",
+ p->sym->name, interface_name, &p->sym->declared_at);
else
- gfc_error ("Procedure %qs in %s at %L is neither function nor "
- "subroutine", p->sym->name, interface_name,
- &p->sym->declared_at);
+ if (guessed)
+ gfc_error ("Procedure %qs in %s at %L is neither function nor "
+ "subroutine; did you mean %qs?", p->sym->name,
+ interface_name, &p->sym->declared_at, guessed);
+ else
+ gfc_error ("Procedure %qs in %s at %L is neither function nor "
+ "subroutine", p->sym->name, interface_name,
+ &p->sym->declared_at);
return 1;
}
@@ -2684,6 +2698,31 @@ is_procptr_result (gfc_expr *expr)
}
+/* Recursively append candidate argument ARG to CANDIDATES. Store the
+ number of total candidates in CANDIDATES_LEN. */
+
+static void
+lookup_arg_fuzzy_find_candidates (gfc_formal_arglist *arg,
+ char **&candidates,
+ size_t &candidates_len)
+{
+ for (gfc_formal_arglist *p = arg; p && p->sym; p = p->next)
+ vec_push (candidates, candidates_len, p->sym->name);
+}
+
+
+/* Lookup argument ARG fuzzily, taking names in ARGUMENTS into
account. */
+
+static const char*
+lookup_arg_fuzzy (const char *arg, gfc_formal_arglist *arguments)
+{
+ char **candidates = NULL;
+ size_t candidates_len = 0;
+ lookup_arg_fuzzy_find_candidates (arguments, candidates,
candidates_len);
+ return gfc_closest_fuzzy_match (arg, candidates);
+}
+
+
/* Given formal and actual argument lists, see if they are compatible.
If they are compatible, the actual argument list is sorted to
correspond with the formal list, and elements for missing optional
@@ -2736,8 +2775,16 @@ compare_actual_formal (gfc_actual_arglist **ap,
gfc_formal_arglist *formal,
if (f == NULL)
{
if (where)
- gfc_error ("Keyword argument %qs at %L is not in "
- "the procedure", a->name, &a->expr->where);
+ {
+ const char *guessed = lookup_arg_fuzzy (a->name, formal);
+ if (guessed)
+ gfc_error ("Keyword argument %qs at %L is not in "
+ "the procedure; did you mean %qs?",
+ a->name, &a->expr->where, guessed);
+ else
+ gfc_error ("Keyword argument %qs at %L is not in "
+ "the procedure", a->name, &a->expr->where);
+ }
return 0;
}
@@ -3436,8 +3483,15 @@ gfc_procedure_use (gfc_symbol *sym,
gfc_actual_arglist **ap, locus *where)
{
if (sym->ns->has_implicit_none_export && sym->attr.proc ==
PROC_UNKNOWN)
{
- gfc_error ("Procedure %qs called at %L is not explicitly declared",
- sym->name, where);
+ const char *guessed
+ = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
+ if (guessed)
+ gfc_error ("Procedure %qs called at %L is not explicitly
declared"
+ "; did you mean %qs?",
+ sym->name, where, guessed);
+ else
+ gfc_error ("Procedure %qs called at %L is not explicitly
declared",
+ sym->name, where);
return false;
}
if (warn_implicit_interface)
diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
index 1747ff2..dd17f46 100644
--- a/gcc/fortran/misc.c
+++ b/gcc/fortran/misc.c
@@ -22,6 +22,7 @@ along with GCC; see the file COPYING3. If not see
#include "system.h"
#include "coretypes.h"
#include "gfortran.h"
+#include "spellcheck.h"
/* Initialize a typespec to unknown. */
@@ -280,3 +281,43 @@ get_c_kind(const char *c_kind_name, CInteropKind_t kinds_table[])
return ISOCBINDING_INVALID;
}
+
+
+/* For a given name TYPO, determine the best candidate from CANDIDATES
+ perusing Levenshtein distance. Frees CANDIDATES before returning.
*/
+
+const char *
+gfc_closest_fuzzy_match (const char *typo, char **candidates)
+{
+ /* Determine closest match. */
+ const char *best = NULL;
+ char **cand = candidates;
+ edit_distance_t best_distance = MAX_EDIT_DISTANCE;
+ const size_t tl = strlen (typo);
+
+ while (cand && *cand)
+ {
+ edit_distance_t dist = levenshtein_distance (typo, tl, *cand,
+ strlen (*cand));
+ if (dist < best_distance)
+ {
+ best_distance = dist;
+ best = *cand;
+ }
+ cand++;
+ }
+ /* If more than half of the letters were misspelled, the suggestion is
+ likely to be meaningless. */
+ if (best)
+ {
+ unsigned int cutoff = MAX (tl, strlen (best)) / 2;
+
+ if (best_distance > cutoff)
+ {
+ XDELETEVEC (candidates);
+ return NULL;
+ }
+ XDELETEVEC (candidates);
+ }
+ return best;
+}
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 77f8c10..089afa3 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -2693,6 +2693,43 @@ resolve_specific_f (gfc_expr *expr)
return true;
}
+/* Recursively append candidate SYM to CANDIDATES. Store the number of
+ candidates in CANDIDATES_LEN. */
+
+static void
+lookup_function_fuzzy_find_candidates (gfc_symtree *sym,
+ char **&candidates,
+ size_t &candidates_len)
+{
+ gfc_symtree *p;
+
+ if (sym == NULL)
+ return;
+ if ((sym->n.sym->ts.type != BT_UNKNOWN || sym->n.sym->attr.external)
+ && sym->n.sym->attr.flavor == FL_PROCEDURE)
+ vec_push (candidates, candidates_len, sym->name);
+
+ p = sym->left;
+ if (p)
+ lookup_function_fuzzy_find_candidates (p, candidates,
candidates_len);
+
+ p = sym->right;
+ if (p)
+ lookup_function_fuzzy_find_candidates (p, candidates,
candidates_len);
+}
+
+
+/* Lookup function FN fuzzily, taking names in SYMROOT into account.
*/
+
+const char*
+gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *symroot)
+{
+ char **candidates = NULL;
+ size_t candidates_len = 0;
+ lookup_function_fuzzy_find_candidates (symroot, candidates,
candidates_len);
+ return gfc_closest_fuzzy_match (fn, candidates);
+}
+
/* Resolve a procedure call not known to be generic nor specific. */
if (ts->type == BT_UNKNOWN)
{
- gfc_error ("Function %qs at %L has no IMPLICIT type",
- sym->name, &expr->where);
+ const char *guessed
+ = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root);
+ if (guessed)
+ gfc_error ("Function %qs at %L has no IMPLICIT type"
+ "; did you mean %qs?",
+ sym->name, &expr->where, guessed);
+ else
+ gfc_error ("Function %qs at %L has no IMPLICIT type",
+ sym->name, &expr->where);
return false;
}
else
@@ -3516,6 +3560,46 @@ compare_shapes (gfc_expr *op1, gfc_expr *op2)
}
+/* Recursively append candidate UOP to CANDIDATES. Store the number of
+ candidates in CANDIDATES_LEN. */
+static void
+lookup_uop_fuzzy_find_candidates (gfc_symtree *uop,
+ char **&candidates,
+ size_t &candidates_len)
+{
+ gfc_symtree *p;
+
+ if (uop == NULL)
+ return;
+
+ /* Not sure how to properly filter here. Use all for a start.
+ n.uop.op is NULL for empty interface operators (is that legal?) disregard
+ these as i suppose they don't make terribly sense. */
+
+ if (uop->n.uop->op != NULL)
+ vec_push (candidates, candidates_len, uop->name);
+
+ p = uop->left;
+ if (p)
+ lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
+
+ p = uop->right;
+ if (p)
+ lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len);
+}
+
+/* Lookup user-operator OP fuzzily, taking names in UOP into account.
*/
+
+static const char*
+lookup_uop_fuzzy (const char *op, gfc_symtree *uop)
+{
+ char **candidates = NULL;
+ size_t candidates_len = 0;
+ lookup_uop_fuzzy_find_candidates (uop, candidates, candidates_len);
+ return gfc_closest_fuzzy_match (op, candidates);
+}
+
+
/* Resolve an operator expression node. This can involve replacing the
operation with a user defined function call. */
@@ -3714,8 +3798,16 @@ resolve_operator (gfc_expr *e)
if (e->value.op.uop->op == NULL)
- sprintf (msg, _("Unknown operator %%<%s%%> at %%L"),
- e->value.op.uop->name);
+ {
+ const char *name = e->value.op.uop->name;
+ const char *guessed;
+ guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root);
+ if (guessed)
+ sprintf (msg, _("Unknown operator %%<%s%%> at %%L; did you mean '%s'?"),
+ name, guessed);
+ else
+ sprintf (msg, _("Unknown operator %%<%s%%> at %%L"), name);
+ }
else if (op2 == NULL)
sprintf (msg, _("Operand of user operator %%<%s%%> at %%L is %s"),
e->value.op.uop->name, gfc_typename (&op1->ts));
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 0ee7dec..776610c 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -236,6 +236,44 @@ gfc_get_default_type (const char *name,
gfc_namespace *ns)
}
+/* Recursively append candidate SYM to CANDIDATES. Store the number of
+ candidates in CANDIDATES_LEN. */
+
+static void
+lookup_symbol_fuzzy_find_candidates (gfc_symtree *sym,
+ char **&candidates,
+ size_t &candidates_len)
+{
+ gfc_symtree *p;
+
+ if (sym == NULL)
+ return;
+
+ if (sym->n.sym->ts.type != BT_UNKNOWN && sym->n.sym->ts.type != BT_PROCEDURE)
+ vec_push (candidates, candidates_len, sym->name);
+ p = sym->left;
+ if (p)
+ lookup_symbol_fuzzy_find_candidates (p, candidates,
candidates_len);
+
+ p = sym->right;
+ if (p)
+ lookup_symbol_fuzzy_find_candidates (p, candidates,
candidates_len);
+}
+
+
+/* Lookup symbol SYM_NAME fuzzily, taking names in SYMBOL into
account. */
+
+static const char*
+lookup_symbol_fuzzy (const char *sym_name, gfc_symbol *symbol)
+{
+ char **candidates = NULL;
+ size_t candidates_len = 0;
+ lookup_symbol_fuzzy_find_candidates (symbol->ns->sym_root,
candidates,
+ candidates_len);
+ return gfc_closest_fuzzy_match (sym_name, candidates);
+}
+
+
/* Given a pointer to a symbol, set its type according to the first
letter of its name. Fails if the letter in question has no default
type. */
@@ -254,8 +292,14 @@ gfc_set_default_type (gfc_symbol *sym, int
error_flag, gfc_namespace *ns)
{
if (error_flag && !sym->attr.untyped)
{
- gfc_error ("Symbol %qs at %L has no IMPLICIT type",
- sym->name, &sym->declared_at);
+ const char *guessed = lookup_symbol_fuzzy (sym->name, sym);
+ if (guessed)
+ gfc_error ("Symbol %qs at %L has no IMPLICIT type"
+ "; did you mean %qs?",
+ sym->name, &sym->declared_at, guessed);
+ else
+ gfc_error ("Symbol %qs at %L has no IMPLICIT type",
+ sym->name, &sym->declared_at);
sym->attr.untyped = 1; /* Ensure we only give an error once. */
}
@@ -2233,6 +2277,32 @@ find_union_component (gfc_symbol *un, const char *name,
}
+/* Recursively append candidate COMPONENT structures to CANDIDATES.
Store
+ the number of total candidates in CANDIDATES_LEN. */
+
+static void
+lookup_component_fuzzy_find_candidates (gfc_component *component,
+ char **&candidates,
+ size_t &candidates_len)
+{
+ for (gfc_component *p = component; p; p = p->next)
+ vec_push (candidates, candidates_len, p->name);
+}
+
+
+/* Lookup component MEMBER fuzzily, taking names in COMPONENT into account. */
+
+static const char*
+lookup_component_fuzzy (const char *member, gfc_component *component)
+{
+ char **candidates = NULL;
+ size_t candidates_len = 0;
+ lookup_component_fuzzy_find_candidates (component, candidates,
+ candidates_len);
+ return gfc_closest_fuzzy_match (member, candidates);
+}
+
+
/* Given a derived type node and a component name, try to locate the
component structure. Returns the NULL pointer if the component is
not found or the components are private. If noaccess is set, no access
@@ -2330,8 +2400,16 @@ gfc_find_component (gfc_symbol *sym, const char *name,
}
if (p == NULL && !silent)
- gfc_error ("%qs at %C is not a member of the %qs structure",
- name, sym->name);
+ {
+ const char *guessed = lookup_component_fuzzy (name,
sym->components);
+ if (guessed)
+ gfc_error ("%qs at %C is not a member of the %qs structure"
+ "; did you mean %qs?",
+ name, sym->name, guessed);
+ else
+ gfc_error ("%qs at %C is not a member of the %qs structure",
+ name, sym->name);
+ }
/* Component was found; build the ultimate component reference. */
if (p != NULL && ref)
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-operator.f90
b/gcc/testsuite/gfortran.dg/spellcheck-operator.f90
new file mode 100644
index 0000000..810a770
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-operator.f90
@@ -0,0 +1,30 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+module mymod1
+ implicit none
+ contains
+ function something_good (iarg1)
+ integer :: something_good
+ integer, intent(in) :: iarg1
+ something_good = iarg1 + 42
+ end function something_good
+end module mymod1
+
+program spellchekc
+ use mymod1
+ implicit none
+
+ interface operator (.mywrong.)
+ module procedure something_wring ! { dg-error "Procedure
.something_wring. in operator interface .mywrong. at .1. is neither
function nor subroutine; did you mean .something_good.\\?|User operator
procedure .something_wring. at .1. must be a FUNCTION" }
+ end interface
+
+ interface operator (.mygood.)
+ module procedure something_good
+ end interface
+
+ integer :: i, j, added
+ i = 0
+ j = 0
+ added = .mygoof. j ! { dg-error "Unknown operator .mygoof. at .1.;
did you mean .mygood.\\?" }
+end program spellchekc
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-parameter.f90
b/gcc/testsuite/gfortran.dg/spellcheck-parameter.f90
new file mode 100644
index 0000000..715c5ab
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-parameter.f90
@@ -0,0 +1,15 @@
+! { dg-do compile }
+! Contributed by Joost VandeVondele
+! test levenshtein based spelling suggestions for keyword arguments
+
+module test
+contains
+ subroutine mysub(iarg1)
+ integer :: iarg1
+ end subroutine
+end module
+
+use test
+call mysub(iarg=1) ! { dg-error "Keyword argument .iarg. at .1. is not
in the procedure; did you mean .iarg1.\\?" }
+
+end
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90
b/gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90
new file mode 100644
index 0000000..3b7f716
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-procedure_1.f90
@@ -0,0 +1,41 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+module mymod1
+ implicit none
+ contains
+ function something_else (iarg1)
+ integer :: something_else
+ integer, intent(in) :: iarg1
+ something_else = iarg1 + 42
+ end function something_else
+ function add_fourtytwo (iarg1)
+ integer :: add_fourtytwo
+ integer, intent(in) :: iarg1
+ add_fourtytwo = iarg1 + 42
+ end function add_fourtytwo
+end module mymod1
+
+function myadd(iarg1, iarg2)
+ implicit none
+ integer :: myadd
+ integer, intent(in) :: iarg1, iarg2
+ myadd = iarg1 + iarg2
+end function myadd
+
+program spellchekc
+ use mymod1, something_good => something_else
+ implicit none
+
+ integer :: myadd, i, j, myvar
+ i = 0
+ j = 0
+
+ j = something_goof(j) ! { dg-error "no IMPLICIT type; did you mean .something_good.\\?" }
+ j = myaddd(i, j) ! { dg-error "no IMPLICIT type; did you mean .myadd.\\?" }
+ if (j /= 42) call abort
+ j = add_fourtytow(i, j) ! { dg-error "no IMPLICIT type; did you mean .add_fourtytwo.\\?" }
+ myval = myadd(i, j) ! { dg-error "no IMPLICIT type; did you mean .myvar.\\?" }
+ if (j /= 42 * 2) call abort
+
+end program spellchekc
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90
b/gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90
new file mode 100644
index 0000000..a6ea5f9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-procedure_2.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+
+
+program spellchekc
+ implicit none (external) ! { dg-warning "GNU Extension: IMPORT NONE with spec list" }
+
+ interface
+ subroutine bark_unless_zero(iarg)
+ implicit none
+ integer, intent(in) :: iarg
+ end subroutine bark_unless_zero
+ end interface
+
+ integer :: i
+ i = 0
+
+ if (i /= 1) call abort
+ call bark_unless_0(i) ! { dg-error "not explicitly declared; did you
mean .bark_unless_zero.\\?" }
+! call complain_about_0(i) ! { -dg-error "not explicitly declared;
did you mean .complain_about_zero.\\?" }
+
+contains
+! We cannot reliably see this ATM, would need an unambiguous bit somewhere
+ subroutine complain_about_zero(iarg)
+ integer, intent(in) :: iarg
+ if (iarg /= 0) call abort
+ end subroutine complain_about_zero
+
+end program spellchekc
+
+subroutine bark_unless_zero(iarg)
+ implicit none
+ integer, intent(in) :: iarg
+ if (iarg /= 0) call abort
+end subroutine bark_unless_zero
diff --git a/gcc/testsuite/gfortran.dg/spellcheck-structure.f90
b/gcc/testsuite/gfortran.dg/spellcheck-structure.f90
new file mode 100644
index 0000000..929e05f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/spellcheck-structure.f90
@@ -0,0 +1,35 @@
+! { dg-do compile }
+! test levenshtein based spelling suggestions
+implicit none
+
+!!!!!!!!!!!!!! structure tests !!!!!!!!!!!!!!
+type type1
+ real :: radius
+ integer :: i
+end type type1
+
+type type2
+ integer :: myint
+ type(type1) :: mytype
+end type type2
+
+type type3
+ type(type2) :: type_2
+end type type3
+type type4
+ type(type3) :: type_3
+end type type4
+
+type(type1) :: t1
+t1%radiuz = .0 ! { dg-error ".radiuz. at .1. is not a member of the
.type1. structure; did you mean .radius.\\?" }
+t1%x = .0 ! { dg-error ".x. at .1. is not a member of the .type1. structure" }
+type(type2) :: t2
+t2%mytape%radius = .0 ! { dg-error ".mytape. at .1. is not a member of
the .type2. structure; did you mean .mytype.\\?" }
+t2%mytype%radious = .0 ! { dg-error ".radious. at .1. is not a member
of the .type1. structure; did you mean .radius.\\?" }
+type(type4) :: t4
+t4%type_3%type_2%mytype%radium = 88.0 ! { dg-error ".radium. at .1. is
not a member of the .type1. structure; did you mean .radius.\\?" }
+
+!!!!!!!!!!!!!! symbol tests !!!!!!!!!!!!!!
+integer :: iarg1
+iarg2 = 1 ! { dg-error "Symbol .iarg2. at .1. has no IMPLICIT type;
did you mean .iarg1.\\?" }
+end

[Jerry DeLisle]

Ping

Post by Bernhard Reutner-Fischer
Hi,
Ok for trunk?

I think this is OK, can we get one other gfortran person to concur?

Jerry

[Janne Blomqvist]

Ok for my part too.

Post by Jerry DeLisle

Ping
On June 18, 2016 9:58:47 PM GMT+02:00, Bernhard Reutner-Fischer

Post by Bernhard Reutner-Fischer
Hi,
Ok for trunk?

I think this is OK, can we get one other gfortran person to concur?
Jerry

[Bernhard Reutner-Fischer]

Post by Janne Blomqvist
Ok for my part too.

Post by Jerry DeLisle

Ping
On June 18, 2016 9:58:47 PM GMT+02:00, Bernhard Reutner-Fischer

Post by Bernhard Reutner-Fischer
Hi,
Ok for trunk?

I think this is OK, can we get one other gfortran person to concur?

Finally committed as r253877 after another round of boostrapping and
regtesting on x86_64-foo-linux.

thanks,

[Bernhard Reutner-Fischer]

[forgot to CC gcc-patches]

Post by Bernhard Reutner-Fischer
Hi,
Ok for trunk?

This was ACKed about a year ago by Janne and Jerry and since there were
no objections in the meantime i've installed this first step towards
providing spelling suggestions in the fortran FE as r253877.

cheers,

Post by Bernhard Reutner-Fischer
- rebased
- Use 4 argument levenshtein_distance() to save multiple strlen(typo)
calls as suggested by dmalcolm
- rebased
- subroutines using interfaces
- keyword arguments (named parameters)
Rewrite C++ autovec in plain C.
Factor out levenshtein distance handling into a commonly used
gfc_closest_fuzzy_match().
gcc/fortran/ChangeLog
* gfortran.h (gfc_lookup_function_fuzzy): New declaration.
(gfc_closest_fuzzy_match): New declaration.
(vec_push): New definition.
* misc.c (gfc_closest_fuzzy_match): New definition.
* resolve.c: Include spellcheck.h.
(lookup_function_fuzzy_find_candidates): New static function.
(lookup_uop_fuzzy_find_candidates): Likewise.
(lookup_uop_fuzzy): Likewise.
(resolve_operator) <INTRINSIC_USER>: Call lookup_uop_fuzzy.
(gfc_lookup_function_fuzzy): New definition.
(resolve_unknown_f): Call gfc_lookup_function_fuzzy.
* interface.c (check_interface0): Likewise.
(lookup_arg_fuzzy_find_candidates): New static function.
(lookup_arg_fuzzy ): Likewise.
(compare_actual_formal): Call lookup_arg_fuzzy.
* symbol.c: Include spellcheck.h.
(lookup_symbol_fuzzy_find_candidates): New static function.
(lookup_symbol_fuzzy): Likewise.
(gfc_set_default_type): Call lookup_symbol_fuzzy.
(lookup_component_fuzzy_find_candidates): New static function.
(lookup_component_fuzzy): Likewise.
(gfc_find_component): Call lookup_component_fuzzy.
gcc/testsuite/ChangeLog
* gfortran.dg/spellcheck-operator.f90: New testcase.
* gfortran.dg/spellcheck-procedure_1.f90: New testcase.
* gfortran.dg/spellcheck-procedure_2.f90: New testcase.
* gfortran.dg/spellcheck-structure.f90: New testcase.
* gfortran.dg/spellcheck-parameter.f90: New testcase.
---
David Malcolm's nice Levenshtein distance spelling check helpers
were used in some parts of other frontends. This proposed patch adds
some spelling corrections to the fortran frontend.
Suggestions are printed if we can find a suitable name, currently
/* If more than half of the letters were misspelled, the suggestion is
likely to be meaningless. */
cutoff = MAX (strlen (typo), strlen (best_guess)) / 2;
which effectively skips names with less than 4 characters.
For e.g. structures, one could try to be much smarter in an attempt to
also provide suggestions for single-letter members/components.
- user-defined operators
- structures (types and their components)
- functions
- symbols (variables)
If anybody has a testcase where a spelling-suggestion would make sense
then please pass it along so we maybe can add support for GCC-7.

[VandeVondele Joost]

Today, I ran 'gfortran -static-libfortran test.f90' and was very pleased with the answer:

gfortran: error: unrecognized command line option ‘-static-libfortran’; did you mean ‘-static-libgfortran’?

So thanks David, and hopefully we get this user experience for the FE as well.

Joost

[VandeVondele Joost]

So, I have tested the patch, it seems to work well.

I would really like to see this feature in the compiler, I'm sure it will help people developing Fortran code.

cat test.f90

MODULE test
CONTAINS
SUBROUTINE foo(bar)
INTEGER :: bar
END SUBROUTINE
END MODULE
USE test
CALL foo(baz=1)
END

[Tobias Burnus]

[...]

Post by David Malcolm

Post by Mikael Morin
It seems you are considering some candidates more than once here.

[...]

Post by David Malcolm

Post by Mikael Morin
You have to start the lookup with the current namespace's sym_root (not
with fun), otherwise you'll miss some candidates.
You may also want to query parent namespaces for host-associated symbols.

[...]

I think the current patch doesn't not address those (as stated) and I think
that some suggestions should honour the attributes better (variable vs.
subroutine vs. function etc.). But I very much like the general patch.

Post by David Malcolm
I can't comment on Mikael's observations, but here's an updated version
of Bernhard's patch which moves the duplicated code into a new
"find_closest_string" function in gcc/spellcheck.c.

That change looks good to me.

BTW: I think you should write a quip for https://gcc.gnu.org/gcc-6/changes.html

Tobias

PS: Talking about the release notes, my feeling is that both the wiki and
the release notes miss some changes, but I have to admit that I am really
out of sync. It currently only lists Submodules at the Wiki,
https://gcc.gnu.org/wiki/GFortran/News#GCC6
and https://gcc.gnu.org/gcc-6/changes.html has a few other items. (Both
should be synced crosswise.) As additional item, I know of coarray events
but there must be more items.

[Gerald Pfeifer]

Post by Tobias Burnus
PS: Talking about the release notes, my feeling is that both the wiki and
the release notes miss some changes, but I have to admit that I am really
out of sync. It currently only lists Submodules at the Wiki,
https://gcc.gnu.org/wiki/GFortran/News#GCC6
and https://gcc.gnu.org/gcc-6/changes.html has a few other items. (Both
should be synced crosswise.)

I would be really good to see all changes land in changes.html in
time, since this is what the majority of users -- and press, as I
have seen -- consumes.

(Why do the Wiki and the formal release notes need to be synced
cross-wise? Couldn't you just move things from the Wiki to the
release notes to avoid duplication?)

Gerald

[Bernhard Reutner-Fischer]

Ping.

Post by Bernhard Reutner-Fischer
A couple of places used gfc_add_component_ref(expr, "string") instead of
the defines from gfortran.h
Regstrapped without regressions, ok for trunk stage3 now / next stage1?
gcc/fortran/ChangeLog
* class.c (gfc_add_class_array_ref): Call gfc_add_data_component()
instead of gfc_add_component_ref().
(gfc_get_len_component): Call gfc_add_len_component() instead of
gfc_add_component_ref().
* trans-intrinsic.c (gfc_conv_intrinsic_loc): Call
gfc_add_data_component() instead of gfc_add_component_ref().
* trans.c (gfc_add_finalizer_call): Call
gfc_add_final_component() and gfc_add_size_component() instead
of gfc_add_component_ref.
---
gcc/fortran/class.c | 4 ++--
gcc/fortran/trans-intrinsic.c | 2 +-
gcc/fortran/trans.c | 4 ++--
3 files changed, 5 insertions(+), 5 deletions(-)
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 8b49ae9..027cb89 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -258,7 +258,7 @@ gfc_add_class_array_ref (gfc_expr *e)
int rank = CLASS_DATA (e)->as->rank;
gfc_array_spec *as = CLASS_DATA (e)->as;
gfc_ref *ref = NULL;
- gfc_add_component_ref (e, "_data");
+ gfc_add_data_component (e);
e->rank = rank;
for (ref = e->ref; ref; ref = ref->next)
if (!ref->next)
@@ -584,7 +584,7 @@ gfc_get_len_component (gfc_expr *e)
ref = ref->next;
}
/* And replace if with a ref to the _len component. */
- gfc_add_component_ref (ptr, "_len");
+ gfc_add_len_component (ptr);
return ptr;
}
diff --git a/gcc/fortran/trans-intrinsic.c
b/gcc/fortran/trans-intrinsic.c
index 1dabc26..2ef0709 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -7112,7 +7112,7 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
if (arg_expr->rank == 0)
{
if (arg_expr->ts.type == BT_CLASS)
- gfc_add_component_ref (arg_expr, "_data");
+ gfc_add_data_component (arg_expr);
gfc_conv_expr_reference (se, arg_expr);
}
else
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 2a91c35..14dad0f 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1132,11 +1132,11 @@ gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2)
final_expr = gfc_copy_expr (expr);
gfc_add_vptr_component (final_expr);
- gfc_add_component_ref (final_expr, "_final");
+ gfc_add_final_component (final_expr);
elem_size = gfc_copy_expr (expr);
gfc_add_vptr_component (elem_size);
- gfc_add_component_ref (elem_size, "_size");
+ gfc_add_size_component (elem_size);
}
gcc_assert (final_expr->expr_type == EXPR_VARIABLE);

[Paul Richard Thomas]

Hi Bernhard,

Thanks for doing some of this tidying up. The patch is OK to commit on
both trunk and 6-branch. It might be worth going back to 5-branch as
well, if you feel up to it.

Cheers

Paul

On 18 June 2016 at 21:47, Bernhard Reutner-Fischer

Ping.

Post by Bernhard Reutner-Fischer
A couple of places used gfc_add_component_ref(expr, "string") instead of
the defines from gfortran.h
Regstrapped without regressions, ok for trunk stage3 now / next stage1?
gcc/fortran/ChangeLog
* class.c (gfc_add_class_array_ref): Call gfc_add_data_component()
instead of gfc_add_component_ref().
(gfc_get_len_component): Call gfc_add_len_component() instead of
gfc_add_component_ref().
* trans-intrinsic.c (gfc_conv_intrinsic_loc): Call
gfc_add_data_component() instead of gfc_add_component_ref().
* trans.c (gfc_add_finalizer_call): Call
gfc_add_final_component() and gfc_add_size_component() instead
of gfc_add_component_ref.
---
gcc/fortran/class.c | 4 ++--
gcc/fortran/trans-intrinsic.c | 2 +-
gcc/fortran/trans.c | 4 ++--
3 files changed, 5 insertions(+), 5 deletions(-)
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c
index 8b49ae9..027cb89 100644
--- a/gcc/fortran/class.c
+++ b/gcc/fortran/class.c
@@ -258,7 +258,7 @@ gfc_add_class_array_ref (gfc_expr *e)
int rank = CLASS_DATA (e)->as->rank;
gfc_array_spec *as = CLASS_DATA (e)->as;
gfc_ref *ref = NULL;
- gfc_add_component_ref (e, "_data");
+ gfc_add_data_component (e);
e->rank = rank;
for (ref = e->ref; ref; ref = ref->next)
if (!ref->next)
@@ -584,7 +584,7 @@ gfc_get_len_component (gfc_expr *e)
ref = ref->next;
}
/* And replace if with a ref to the _len component. */
- gfc_add_component_ref (ptr, "_len");
+ gfc_add_len_component (ptr);
return ptr;
}
diff --git a/gcc/fortran/trans-intrinsic.c
b/gcc/fortran/trans-intrinsic.c
index 1dabc26..2ef0709 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -7112,7 +7112,7 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
if (arg_expr->rank == 0)
{
if (arg_expr->ts.type == BT_CLASS)
- gfc_add_component_ref (arg_expr, "_data");
+ gfc_add_data_component (arg_expr);
gfc_conv_expr_reference (se, arg_expr);
}
else
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 2a91c35..14dad0f 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1132,11 +1132,11 @@ gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2)
final_expr = gfc_copy_expr (expr);
gfc_add_vptr_component (final_expr);
- gfc_add_component_ref (final_expr, "_final");
+ gfc_add_final_component (final_expr);
elem_size = gfc_copy_expr (expr);
gfc_add_vptr_component (elem_size);
- gfc_add_component_ref (elem_size, "_size");
+ gfc_add_size_component (elem_size);
}
gcc_assert (final_expr->expr_type == EXPR_VARIABLE);

[Bernhard Reutner-Fischer]

Post by Paul Richard Thomas
Hi Bernhard,
Thanks for doing some of this tidying up. The patch is OK to commit on
both trunk and 6-branch. It might be worth going back to 5-branch as
well, if you feel up to it.

Applied to trunk as r237580 so far.

thanks,