Commit e9078ebb by Tobias Burnus Committed by Tobias Burnus

re PR fortran/51578 (Import of same symbol via different modules and renaming)

2012-01-09  Tobias Burnus  <burnus@net-b.de>

        PR fortran/51578
        * gfortran.h (gfc_use_list):
        * match.h (gfc_use_module): Rename to ...
        (gfc_use_modules): ... this.
        * module.c (use_locus, specified_nonint, specified_int): Remove
        global variable.
        (module_name): Change type to const char*, used with gfc_get_string.
        (module_list): New global variable.
        (free_rename): Free argument not global var.
        (gfc_match_use): Save match to module_list.
        (load_generic_interfaces, read_module): Don't free symtree.
        (write_dt_extensions, gfc_dump_module): Fix module-name I/O due to the
        type change of module_name.
        (write_symbol0, write_generic): Optimize due to the type change.
        (import_iso_c_binding_module, use_iso_fortran_env_module): Use
        locus of rename->where.
        (gfc_use_module): Take module_list as argument.
        (gfc_use_modules): New function.
        (gfc_module_init_2, gfc_module_done_2): Init module_list, rename_list.
        * parse.c (last_was_use_stmt): New global variable.
        (use_modules): New function.
        (decode_specification_statement, decode_statement): Move USE match up
        and call use_modules.
        (next_free, next_fixed): Call use_modules.
        (accept_statement): Don't call gfc_module_use.

2012-01-09  Tobias Burnus  <burnus@net-b.de>

        PR fortran/51578
        * gfortran.dg/use_17.f90: New.

From-SVN: r183010
parent d18a0a84
2012-01-09 Tobias Burnus <burnus@net-b.de>
PR fortran/51578
* gfortran.h (gfc_use_list):
* match.h (gfc_use_module): Rename to ...
(gfc_use_modules): ... this.
* module.c (use_locus, specified_nonint, specified_int): Remove
global variable.
(module_name): Change type to const char*, used with gfc_get_string.
(module_list): New global variable.
(free_rename): Free argument not global var.
(gfc_match_use): Save match to module_list.
(load_generic_interfaces, read_module): Don't free symtree.
(write_dt_extensions, gfc_dump_module): Fix module-name I/O due to the
type change of module_name.
(write_symbol0, write_generic): Optimize due to the type change.
(import_iso_c_binding_module, use_iso_fortran_env_module): Use
locus of rename->where.
(gfc_use_module): Take module_list as argument.
(gfc_use_modules): New function.
(gfc_module_init_2, gfc_module_done_2): Init module_list, rename_list.
* parse.c (last_was_use_stmt): New global variable.
(use_modules): New function.
(decode_specification_statement, decode_statement): Move USE match up
and call use_modules.
(next_free, next_fixed): Call use_modules.
(accept_statement): Don't call gfc_module_use.
2012-01-06 Tobias Burnus <burnus@net-b.de> 2012-01-06 Tobias Burnus <burnus@net-b.de>
* trans-openmp.c (gfc_omp_clause_dtor, gfc_trans_omp_array_reduction): * trans-openmp.c (gfc_omp_clause_dtor, gfc_trans_omp_array_reduction):
......
...@@ -1299,7 +1299,9 @@ gfc_use_rename; ...@@ -1299,7 +1299,9 @@ gfc_use_rename;
typedef struct gfc_use_list typedef struct gfc_use_list
{ {
const char *module_name; const char *module_name;
int only_flag; bool intrinsic;
bool non_intrinsic;
bool only_flag;
struct gfc_use_rename *rename; struct gfc_use_rename *rename;
locus where; locus where;
/* Next USE statement. */ /* Next USE statement. */
......
/* All matcher functions. /* All matcher functions.
Copyright (C) 2003, 2005, 2007, 2008, 2010 Copyright (C) 2003, 2005, 2007, 2008, 2010, 2012
Free Software Foundation, Inc. Free Software Foundation, Inc.
Contributed by Steven Bosscher Contributed by Steven Bosscher
...@@ -249,7 +249,7 @@ match gfc_match_expr (gfc_expr **); ...@@ -249,7 +249,7 @@ match gfc_match_expr (gfc_expr **);
/* module.c. */ /* module.c. */
match gfc_match_use (void); match gfc_match_use (void);
void gfc_use_module (void); void gfc_use_modules (void);
#endif /* GFC_MATCH_H */ #endif /* GFC_MATCH_H */
/* Handle modules, which amounts to loading and saving symbols and /* Handle modules, which amounts to loading and saving symbols and
their attendant structures. their attendant structures.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
2009, 2010, 2011 2009, 2010, 2011, 2012
Free Software Foundation, Inc. Free Software Foundation, Inc.
Contributed by Andy Vaught Contributed by Andy Vaught
...@@ -188,10 +188,8 @@ static FILE *module_fp; ...@@ -188,10 +188,8 @@ static FILE *module_fp;
static struct md5_ctx ctx; static struct md5_ctx ctx;
/* The name of the module we're reading (USE'ing) or writing. */ /* The name of the module we're reading (USE'ing) or writing. */
static char module_name[GFC_MAX_SYMBOL_LEN + 1]; static const char *module_name;
static gfc_use_list *module_list;
/* The way the module we're reading was specified. */
static bool specified_nonint, specified_int;
static int module_line, module_column, only_flag; static int module_line, module_column, only_flag;
static int prev_module_line, prev_module_column, prev_character; static int prev_module_line, prev_module_column, prev_character;
...@@ -207,8 +205,6 @@ static int symbol_number; /* Counter for assigning symbol numbers */ ...@@ -207,8 +205,6 @@ static int symbol_number; /* Counter for assigning symbol numbers */
/* Tells mio_expr_ref to make symbols for unused equivalence members. */ /* Tells mio_expr_ref to make symbols for unused equivalence members. */
static bool in_load_equiv; static bool in_load_equiv;
static locus use_locus;
/*****************************************************************/ /*****************************************************************/
...@@ -519,14 +515,14 @@ add_fixup (int integer, void *gp) ...@@ -519,14 +515,14 @@ add_fixup (int integer, void *gp)
/* Free the rename list left behind by a USE statement. */ /* Free the rename list left behind by a USE statement. */
static void static void
free_rename (void) free_rename (gfc_use_rename *list)
{ {
gfc_use_rename *next; gfc_use_rename *next;
for (; gfc_rename_list; gfc_rename_list = next) for (; list; list = next)
{ {
next = gfc_rename_list->next; next = list->next;
free (gfc_rename_list); free (list);
} }
} }
...@@ -541,9 +537,9 @@ gfc_match_use (void) ...@@ -541,9 +537,9 @@ gfc_match_use (void)
interface_type type, type2; interface_type type, type2;
gfc_intrinsic_op op; gfc_intrinsic_op op;
match m; match m;
gfc_use_list *use_list;
specified_int = false; use_list = gfc_get_use_list ();
specified_nonint = false;
if (gfc_match (" , ") == MATCH_YES) if (gfc_match (" , ") == MATCH_YES)
{ {
...@@ -551,19 +547,19 @@ gfc_match_use (void) ...@@ -551,19 +547,19 @@ gfc_match_use (void)
{ {
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: module " if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: module "
"nature in USE statement at %C") == FAILURE) "nature in USE statement at %C") == FAILURE)
return MATCH_ERROR; goto cleanup;
if (strcmp (module_nature, "intrinsic") == 0) if (strcmp (module_nature, "intrinsic") == 0)
specified_int = true; use_list->intrinsic = true;
else else
{ {
if (strcmp (module_nature, "non_intrinsic") == 0) if (strcmp (module_nature, "non_intrinsic") == 0)
specified_nonint = true; use_list->non_intrinsic = true;
else else
{ {
gfc_error ("Module nature in USE statement at %C shall " gfc_error ("Module nature in USE statement at %C shall "
"be either INTRINSIC or NON_INTRINSIC"); "be either INTRINSIC or NON_INTRINSIC");
return MATCH_ERROR; goto cleanup;
} }
} }
} }
...@@ -576,6 +572,7 @@ gfc_match_use (void) ...@@ -576,6 +572,7 @@ gfc_match_use (void)
|| strcmp (module_nature, "non_intrinsic") == 0) || strcmp (module_nature, "non_intrinsic") == 0)
gfc_error ("\"::\" was expected after module nature at %C " gfc_error ("\"::\" was expected after module nature at %C "
"but was not found"); "but was not found");
free (use_list);
return m; return m;
} }
} }
...@@ -585,35 +582,41 @@ gfc_match_use (void) ...@@ -585,35 +582,41 @@ gfc_match_use (void)
if (m == MATCH_YES && if (m == MATCH_YES &&
gfc_notify_std (GFC_STD_F2003, "Fortran 2003: " gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
"\"USE :: module\" at %C") == FAILURE) "\"USE :: module\" at %C") == FAILURE)
return MATCH_ERROR; goto cleanup;
if (m != MATCH_YES) if (m != MATCH_YES)
{ {
m = gfc_match ("% "); m = gfc_match ("% ");
if (m != MATCH_YES) if (m != MATCH_YES)
{
free (use_list);
return m; return m;
} }
} }
}
use_locus = gfc_current_locus; use_list->where = gfc_current_locus;
m = gfc_match_name (module_name); m = gfc_match_name (name);
if (m != MATCH_YES) if (m != MATCH_YES)
{
free (use_list);
return m; return m;
}
free_rename (); use_list->module_name = gfc_get_string (name);
only_flag = 0;
if (gfc_match_eos () == MATCH_YES) if (gfc_match_eos () == MATCH_YES)
return MATCH_YES; goto done;
if (gfc_match_char (',') != MATCH_YES) if (gfc_match_char (',') != MATCH_YES)
goto syntax; goto syntax;
if (gfc_match (" only :") == MATCH_YES) if (gfc_match (" only :") == MATCH_YES)
only_flag = 1; use_list->only_flag = true;
if (gfc_match_eos () == MATCH_YES) if (gfc_match_eos () == MATCH_YES)
return MATCH_YES; goto done;
for (;;) for (;;)
{ {
...@@ -622,8 +625,8 @@ gfc_match_use (void) ...@@ -622,8 +625,8 @@ gfc_match_use (void)
new_use->where = gfc_current_locus; new_use->where = gfc_current_locus;
new_use->found = 0; new_use->found = 0;
if (gfc_rename_list == NULL) if (use_list->rename == NULL)
gfc_rename_list = new_use; use_list->rename = new_use;
else else
tail->next = new_use; tail->next = new_use;
tail = new_use; tail = new_use;
...@@ -653,7 +656,7 @@ gfc_match_use (void) ...@@ -653,7 +656,7 @@ gfc_match_use (void)
if (type == INTERFACE_USER_OP) if (type == INTERFACE_USER_OP)
new_use->op = INTRINSIC_USER; new_use->op = INTRINSIC_USER;
if (only_flag) if (use_list->only_flag)
{ {
if (m != MATCH_YES) if (m != MATCH_YES)
strcpy (new_use->use_name, name); strcpy (new_use->use_name, name);
...@@ -684,11 +687,11 @@ gfc_match_use (void) ...@@ -684,11 +687,11 @@ gfc_match_use (void)
goto cleanup; goto cleanup;
} }
if (strcmp (new_use->use_name, module_name) == 0 if (strcmp (new_use->use_name, use_list->module_name) == 0
|| strcmp (new_use->local_name, module_name) == 0) || strcmp (new_use->local_name, use_list->module_name) == 0)
{ {
gfc_error ("The name '%s' at %C has already been used as " gfc_error ("The name '%s' at %C has already been used as "
"an external module name.", module_name); "an external module name.", use_list->module_name);
goto cleanup; goto cleanup;
} }
break; break;
...@@ -707,15 +710,27 @@ gfc_match_use (void) ...@@ -707,15 +710,27 @@ gfc_match_use (void)
goto syntax; goto syntax;
} }
done:
if (module_list)
{
gfc_use_list *last = module_list;
while (last->next)
last = last->next;
last->next = use_list;
}
else
module_list = use_list;
return MATCH_YES; return MATCH_YES;
syntax: syntax:
gfc_syntax_error (ST_USE); gfc_syntax_error (ST_USE);
cleanup: cleanup:
free_rename (); free_rename (use_list->rename);
free (use_list);
return MATCH_ERROR; return MATCH_ERROR;
} }
/* Given a name and a number, inst, return the inst name /* Given a name and a number, inst, return the inst name
...@@ -4016,20 +4031,7 @@ load_generic_interfaces (void) ...@@ -4016,20 +4031,7 @@ load_generic_interfaces (void)
if (!sym) if (!sym)
{ {
/* Make the symbol inaccessible if it has been added by a USE if (st)
statement without an ONLY(11.3.2). */
if (st && only_flag
&& !st->n.sym->attr.use_only
&& !st->n.sym->attr.use_rename
&& strcmp (st->n.sym->module, module_name) == 0)
{
sym = st->n.sym;
gfc_delete_symtree (&gfc_current_ns->sym_root, name);
st = gfc_get_unique_symtree (gfc_current_ns);
st->n.sym = sym;
sym = NULL;
}
else if (st)
{ {
sym = st->n.sym; sym = st->n.sym;
if (strcmp (st->name, p) != 0) if (strcmp (st->name, p) != 0)
...@@ -4046,7 +4048,7 @@ load_generic_interfaces (void) ...@@ -4046,7 +4048,7 @@ load_generic_interfaces (void)
{ {
gfc_get_symbol (p, NULL, &sym); gfc_get_symbol (p, NULL, &sym);
sym->name = gfc_get_string (name); sym->name = gfc_get_string (name);
sym->module = gfc_get_string (module_name); sym->module = module_name;
sym->attr.flavor = FL_PROCEDURE; sym->attr.flavor = FL_PROCEDURE;
sym->attr.generic = 1; sym->attr.generic = 1;
sym->attr.use_assoc = 1; sym->attr.use_assoc = 1;
...@@ -4434,7 +4436,7 @@ check_for_ambiguous (gfc_symbol *st_sym, pointer_info *info) ...@@ -4434,7 +4436,7 @@ check_for_ambiguous (gfc_symbol *st_sym, pointer_info *info)
the new symbol is generic there can be no ambiguity. */ the new symbol is generic there can be no ambiguity. */
if (st_sym->attr.generic if (st_sym->attr.generic
&& st_sym->module && st_sym->module
&& strcmp (st_sym->module, module_name)) && st_sym->module != module_name)
{ {
/* The new symbol's attributes have not yet been read. Since /* The new symbol's attributes have not yet been read. Since
we need attr.generic, read it directly. */ we need attr.generic, read it directly. */
...@@ -4609,16 +4611,6 @@ read_module (void) ...@@ -4609,16 +4611,6 @@ read_module (void)
{ {
st = gfc_find_symtree (gfc_current_ns->sym_root, name); st = gfc_find_symtree (gfc_current_ns->sym_root, name);
/* Delete the symtree if the symbol has been added by a USE
statement without an ONLY(11.3.2). Remember that the rsym
will be the same as the symbol found in the symtree, for
this case. */
if (st && (only_flag || info->u.rsym.renamed)
&& !st->n.sym->attr.use_only
&& !st->n.sym->attr.use_rename
&& info->u.rsym.sym == st->n.sym)
gfc_delete_symtree (&gfc_current_ns->sym_root, name);
/* Create a symtree node in the current namespace for this /* Create a symtree node in the current namespace for this
symbol. */ symbol. */
st = check_unique_name (p) st = check_unique_name (p)
...@@ -4649,9 +4641,6 @@ read_module (void) ...@@ -4649,9 +4641,6 @@ read_module (void)
if (strcmp (name, p) != 0) if (strcmp (name, p) != 0)
sym->attr.use_rename = 1; sym->attr.use_rename = 1;
/* We need to set the only_flag here so that symbols from the
same USE...ONLY but earlier are not deleted from the tree in
the gfc_delete_symtree above. */
sym->attr.use_only = only_flag; sym->attr.use_only = only_flag;
/* Store the symtree pointing to this symbol. */ /* Store the symtree pointing to this symbol. */
...@@ -4976,7 +4965,14 @@ write_dt_extensions (gfc_symtree *st) ...@@ -4976,7 +4965,14 @@ write_dt_extensions (gfc_symtree *st)
if (st->n.sym->module != NULL) if (st->n.sym->module != NULL)
mio_pool_string (&st->n.sym->module); mio_pool_string (&st->n.sym->module);
else else
mio_internal_string (module_name); {
char name[GFC_MAX_SYMBOL_LEN + 1];
if (iomode == IO_OUTPUT)
strcpy (name, module_name);
mio_internal_string (name);
if (iomode == IO_INPUT)
module_name = gfc_get_string (name);
}
mio_rparen (); mio_rparen ();
} }
...@@ -5051,7 +5047,7 @@ write_symbol0 (gfc_symtree *st) ...@@ -5051,7 +5047,7 @@ write_symbol0 (gfc_symtree *st)
sym = st->n.sym; sym = st->n.sym;
if (sym->module == NULL) if (sym->module == NULL)
sym->module = gfc_get_string (module_name); sym->module = module_name;
if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
&& !sym->attr.subroutine && !sym->attr.function) && !sym->attr.subroutine && !sym->attr.function)
...@@ -5142,7 +5138,7 @@ write_generic (gfc_symtree *st) ...@@ -5142,7 +5138,7 @@ write_generic (gfc_symtree *st)
return; return;
if (sym->module == NULL) if (sym->module == NULL)
sym->module = gfc_get_string (module_name); sym->module = module_name;
mio_symbol_interface (&st->name, &sym->module, &sym->generic); mio_symbol_interface (&st->name, &sym->module, &sym->generic);
} }
...@@ -5378,7 +5374,7 @@ gfc_dump_module (const char *name, int dump_flag) ...@@ -5378,7 +5374,7 @@ gfc_dump_module (const char *name, int dump_flag)
/* Write the module itself. */ /* Write the module itself. */
iomode = IO_OUTPUT; iomode = IO_OUTPUT;
strcpy (module_name, name); module_name = gfc_get_string (name);
init_pi_tree (); init_pi_tree ();
...@@ -5537,8 +5533,8 @@ import_iso_c_binding_module (void) ...@@ -5537,8 +5533,8 @@ import_iso_c_binding_module (void)
if (not_in_std) if (not_in_std)
{ {
gfc_error ("The symbol '%s', referenced at %C, is not " gfc_error ("The symbol '%s', referenced at %L, is not "
"in the selected standard", name); "in the selected standard", name, &u->where);
continue; continue;
} }
...@@ -5817,16 +5813,17 @@ use_iso_fortran_env_module (void) ...@@ -5817,16 +5813,17 @@ use_iso_fortran_env_module (void)
u->found = 1; u->found = 1;
if (gfc_notify_std (symbol[i].standard, "The symbol '%s', " if (gfc_notify_std (symbol[i].standard, "The symbol '%s', "
"referenced at %C, is not in the selected " "referenced at %L, is not in the selected "
"standard", symbol[i].name) == FAILURE) "standard", symbol[i].name,
&u->where) == FAILURE)
continue; continue;
if ((gfc_option.flag_default_integer || gfc_option.flag_default_real) if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
&& symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE) && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named " gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named "
"constant from intrinsic module " "constant from intrinsic module "
"ISO_FORTRAN_ENV at %C is incompatible with " "ISO_FORTRAN_ENV at %L is incompatible with "
"option %s", "option %s", &u->where,
gfc_option.flag_default_integer gfc_option.flag_default_integer
? "-fdefault-integer-8" ? "-fdefault-integer-8"
: "-fdefault-real-8"); : "-fdefault-real-8");
...@@ -5959,8 +5956,8 @@ use_iso_fortran_env_module (void) ...@@ -5959,8 +5956,8 @@ use_iso_fortran_env_module (void)
/* Process a USE directive. */ /* Process a USE directive. */
void static void
gfc_use_module (void) gfc_use_module (gfc_use_list *module)
{ {
char *filename; char *filename;
gfc_state_data *p; gfc_state_data *p;
...@@ -5969,9 +5966,12 @@ gfc_use_module (void) ...@@ -5969,9 +5966,12 @@ gfc_use_module (void)
gfc_use_list *use_stmt; gfc_use_list *use_stmt;
locus old_locus = gfc_current_locus; locus old_locus = gfc_current_locus;
gfc_current_locus = use_locus; gfc_current_locus = module->where;
module_name = module->module_name;
gfc_rename_list = module->rename;
only_flag = module->only_flag;
filename = (char *) alloca (strlen (module_name) + strlen (MODULE_EXTENSION) filename = XALLOCAVEC (char, strlen (module_name) + strlen (MODULE_EXTENSION)
+ 1); + 1);
strcpy (filename, module_name); strcpy (filename, module_name);
strcat (filename, MODULE_EXTENSION); strcat (filename, MODULE_EXTENSION);
...@@ -5979,12 +5979,12 @@ gfc_use_module (void) ...@@ -5979,12 +5979,12 @@ gfc_use_module (void)
/* First, try to find an non-intrinsic module, unless the USE statement /* First, try to find an non-intrinsic module, unless the USE statement
specified that the module is intrinsic. */ specified that the module is intrinsic. */
module_fp = NULL; module_fp = NULL;
if (!specified_int) if (!module->intrinsic)
module_fp = gfc_open_included_file (filename, true, true); module_fp = gfc_open_included_file (filename, true, true);
/* Then, see if it's an intrinsic one, unless the USE statement /* Then, see if it's an intrinsic one, unless the USE statement
specified that the module is non-intrinsic. */ specified that the module is non-intrinsic. */
if (module_fp == NULL && !specified_nonint) if (module_fp == NULL && !module->non_intrinsic)
{ {
if (strcmp (module_name, "iso_fortran_env") == 0 if (strcmp (module_name, "iso_fortran_env") == 0
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ISO_FORTRAN_ENV " && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ISO_FORTRAN_ENV "
...@@ -5992,6 +5992,7 @@ gfc_use_module (void) ...@@ -5992,6 +5992,7 @@ gfc_use_module (void)
{ {
use_iso_fortran_env_module (); use_iso_fortran_env_module ();
gfc_current_locus = old_locus; gfc_current_locus = old_locus;
module->intrinsic = true;
return; return;
} }
...@@ -6001,12 +6002,13 @@ gfc_use_module (void) ...@@ -6001,12 +6002,13 @@ gfc_use_module (void)
{ {
import_iso_c_binding_module(); import_iso_c_binding_module();
gfc_current_locus = old_locus; gfc_current_locus = old_locus;
module->intrinsic = true;
return; return;
} }
module_fp = gfc_open_intrinsic_module (filename); module_fp = gfc_open_intrinsic_module (filename);
if (module_fp == NULL && specified_int) if (module_fp == NULL && module->intrinsic)
gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C", gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
module_name); module_name);
} }
...@@ -6083,11 +6085,7 @@ gfc_use_module (void) ...@@ -6083,11 +6085,7 @@ gfc_use_module (void)
fclose (module_fp); fclose (module_fp);
use_stmt = gfc_get_use_list (); use_stmt = gfc_get_use_list ();
use_stmt->module_name = gfc_get_string (module_name); *use_stmt = *module;
use_stmt->only_flag = only_flag;
use_stmt->rename = gfc_rename_list;
use_stmt->where = use_locus;
gfc_rename_list = NULL;
use_stmt->next = gfc_current_ns->use_stmts; use_stmt->next = gfc_current_ns->use_stmts;
gfc_current_ns->use_stmts = use_stmt; gfc_current_ns->use_stmts = use_stmt;
...@@ -6095,6 +6093,93 @@ gfc_use_module (void) ...@@ -6095,6 +6093,93 @@ gfc_use_module (void)
} }
/* Process all USE directives. */
void
gfc_use_modules (void)
{
gfc_use_list *next, *seek, *last;
for (next = module_list; next; next = next->next)
{
bool non_intrinsic = next->non_intrinsic;
bool intrinsic = next->intrinsic;
bool neither = !non_intrinsic && !intrinsic;
for (seek = next->next; seek; seek = seek->next)
{
if (next->module_name != seek->module_name)
continue;
if (seek->non_intrinsic)
non_intrinsic = true;
else if (seek->intrinsic)
intrinsic = true;
else
neither = true;
}
if (intrinsic && neither && !non_intrinsic)
{
char *filename;
FILE *fp;
filename = XALLOCAVEC (char,
strlen (next->module_name)
+ strlen (MODULE_EXTENSION) + 1);
strcpy (filename, next->module_name);
strcat (filename, MODULE_EXTENSION);
fp = gfc_open_included_file (filename, true, true);
if (fp != NULL)
{
non_intrinsic = true;
fclose (fp);
}
}
last = next;
for (seek = next->next; seek; seek = last->next)
{
if (next->module_name != seek->module_name)
{
last = seek;
continue;
}
if ((!next->intrinsic && !seek->intrinsic)
|| (next->intrinsic && seek->intrinsic)
|| !non_intrinsic)
{
if (!seek->only_flag)
next->only_flag = false;
if (seek->rename)
{
gfc_use_rename *r = seek->rename;
while (r->next)
r = r->next;
r->next = next->rename;
next->rename = seek->rename;
}
last->next = seek->next;
free (seek);
}
else
last = seek;
}
}
for (; module_list; module_list = next)
{
next = module_list->next;
gfc_use_module (module_list);
if (module_list->intrinsic)
free_rename (module_list->rename);
free (module_list);
}
gfc_rename_list = NULL;
}
void void
gfc_free_use_stmts (gfc_use_list *use_stmts) gfc_free_use_stmts (gfc_use_list *use_stmts)
{ {
...@@ -6118,11 +6203,14 @@ void ...@@ -6118,11 +6203,14 @@ void
gfc_module_init_2 (void) gfc_module_init_2 (void)
{ {
last_atom = ATOM_LPAREN; last_atom = ATOM_LPAREN;
gfc_rename_list = NULL;
module_list = NULL;
} }
void void
gfc_module_done_2 (void) gfc_module_done_2 (void)
{ {
free_rename (); free_rename (gfc_rename_list);
gfc_rename_list = NULL;
} }
/* Main parser. /* Main parser.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
2009, 2010, 2011 2009, 2010, 2011, 2012
Free Software Foundation, Inc. Free Software Foundation, Inc.
Contributed by Andy Vaught Contributed by Andy Vaught
...@@ -37,6 +37,7 @@ static locus label_locus; ...@@ -37,6 +37,7 @@ static locus label_locus;
static jmp_buf eof_buf; static jmp_buf eof_buf;
gfc_state_data *gfc_state_stack; gfc_state_data *gfc_state_stack;
static bool last_was_use_stmt = false;
/* TODO: Re-order functions to kill these forward decls. */ /* TODO: Re-order functions to kill these forward decls. */
static void check_statement_label (gfc_statement); static void check_statement_label (gfc_statement);
...@@ -74,6 +75,26 @@ match_word (const char *str, match (*subr) (void), locus *old_locus) ...@@ -74,6 +75,26 @@ match_word (const char *str, match (*subr) (void), locus *old_locus)
} }
/* Load symbols from all USE statements encounted in this scoping unit. */
static void
use_modules (void)
{
gfc_error_buf old_error;
gfc_push_error (&old_error);
gfc_buffer_error (0);
gfc_use_modules ();
gfc_buffer_error (1);
gfc_pop_error (&old_error);
gfc_commit_symbols ();
gfc_warning_check ();
gfc_current_ns->old_cl_list = gfc_current_ns->cl_list;
gfc_current_ns->old_equiv = gfc_current_ns->equiv;
last_was_use_stmt = false;
}
/* Figure out what the next statement is, (mostly) regardless of /* Figure out what the next statement is, (mostly) regardless of
proper ordering. The do...while(0) is there to prevent if/else proper ordering. The do...while(0) is there to prevent if/else
ambiguity. */ ambiguity. */
...@@ -108,8 +129,19 @@ decode_specification_statement (void) ...@@ -108,8 +129,19 @@ decode_specification_statement (void)
old_locus = gfc_current_locus; old_locus = gfc_current_locus;
if (match_word ("use", gfc_match_use, &old_locus) == MATCH_YES)
{
last_was_use_stmt = true;
return ST_USE;
}
else
{
undo_new_statement ();
if (last_was_use_stmt)
use_modules ();
}
match ("import", gfc_match_import, ST_IMPORT); match ("import", gfc_match_import, ST_IMPORT);
match ("use", gfc_match_use, ST_USE);
if (gfc_current_block ()->result->ts.type != BT_DERIVED) if (gfc_current_block ()->result->ts.type != BT_DERIVED)
goto end_of_block; goto end_of_block;
...@@ -252,6 +284,22 @@ decode_statement (void) ...@@ -252,6 +284,22 @@ decode_statement (void)
old_locus = gfc_current_locus; old_locus = gfc_current_locus;
c = gfc_peek_ascii_char ();
if (c == 'u')
{
if (match_word ("use", gfc_match_use, &old_locus) == MATCH_YES)
{
last_was_use_stmt = true;
return ST_USE;
}
else
undo_new_statement ();
}
if (last_was_use_stmt)
use_modules ();
/* Try matching a data declaration or function declaration. The /* Try matching a data declaration or function declaration. The
input "REALFUNCTIONA(N)" can mean several things in different input "REALFUNCTIONA(N)" can mean several things in different
contexts, so it (and its relatives) get special treatment. */ contexts, so it (and its relatives) get special treatment. */
...@@ -322,8 +370,6 @@ decode_statement (void) ...@@ -322,8 +370,6 @@ decode_statement (void)
statement, we eliminate most possibilities by peeking at the statement, we eliminate most possibilities by peeking at the
first character. */ first character. */
c = gfc_peek_ascii_char ();
switch (c) switch (c)
{ {
case 'a': case 'a':
...@@ -454,7 +500,6 @@ decode_statement (void) ...@@ -454,7 +500,6 @@ decode_statement (void)
case 'u': case 'u':
match ("unlock", gfc_match_unlock, ST_UNLOCK); match ("unlock", gfc_match_unlock, ST_UNLOCK);
match ("use", gfc_match_use, ST_USE);
break; break;
case 'v': case 'v':
...@@ -713,6 +758,8 @@ next_free (void) ...@@ -713,6 +758,8 @@ next_free (void)
gcc_assert (c == ' ' || c == '\t'); gcc_assert (c == ' ' || c == '\t');
gfc_gobble_whitespace (); gfc_gobble_whitespace ();
if (last_was_use_stmt)
use_modules ();
return decode_omp_directive (); return decode_omp_directive ();
} }
...@@ -801,7 +848,8 @@ next_fixed (void) ...@@ -801,7 +848,8 @@ next_fixed (void)
gfc_error ("Bad continuation line at %C"); gfc_error ("Bad continuation line at %C");
return ST_NONE; return ST_NONE;
} }
if (last_was_use_stmt)
use_modules ();
return decode_omp_directive (); return decode_omp_directive ();
} }
/* FALLTHROUGH */ /* FALLTHROUGH */
...@@ -1595,10 +1643,6 @@ accept_statement (gfc_statement st) ...@@ -1595,10 +1643,6 @@ accept_statement (gfc_statement st)
{ {
switch (st) switch (st)
{ {
case ST_USE:
gfc_use_module ();
break;
case ST_IMPLICIT_NONE: case ST_IMPLICIT_NONE:
gfc_set_implicit_none (); gfc_set_implicit_none ();
break; break;
......
2012-01-09 Tobias Burnus <burnus@net-b.de>
PR fortran/51578
* gfortran.dg/use_17.f90: New.
2012-01-09 Gary Funck <gary@intrepid.com> 2012-01-09 Gary Funck <gary@intrepid.com>
PR preprocessor/33919 PR preprocessor/33919
......
! { dg-do compile }
!
! PR fortran/51578
!
! Contributed by Billy Backer
!
! Check that indict importing of the symbol "axx" works
! even if renaming prevent the direct import.
!
module mod1
integer :: axx=2
end module mod1
module mod2
use mod1
end module mod2
subroutine sub1
use mod1, oxx=>axx
use mod2
implicit none
print*,axx ! Valid - was working before
end subroutine sub1
subroutine sub2
use mod2
use mod1, oxx=>axx
implicit none
print*,axx ! Valid - was failing before
end subroutine sub2
subroutine test1
use :: iso_c_binding
use, intrinsic :: iso_c_binding, only: c_double_orig => c_double
integer :: c_double
integer, parameter :: p1 = c_int, p2 = c_double_orig
end subroutine test1
! { dg-final { cleanup-modules "mod1 mod2" } }
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment