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

tob@archimedes:~/scratch/gcc> head -n 15 ../intrinsic_use.diff

Browse Source 
2010-07-11  Tobias Burnus  <burnus@net-b.de>

        PR fortran/44702
        * module.c (sort_iso_c_rename_list): Remove.
        (import_iso_c_binding_module,use_iso_fortran_env_module):
        Allow multiple imports of the same symbol.

2010-07-11  Tobias Burnus  <burnus@net-b.de>

        PR fortran/44702
        * gfortran.dg/use_rename_6.f90: New.
        * gfortran.dg/use_iso_c_binding.f90: Update dg-error.

From-SVN: r162061
This commit is contained in:
Tobias Burnus 2010-07-11 23:29:30 +02:00 committed by Tobias Burnus
parent 5bf935c3c8
commit ee08f2e522
5 changed files with 114 additions and 155 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
gcc/fortran/ChangeLog
View File

@ -1,3 +1,10 @@
2010-07-11 Tobias Burnus <burnus@net-b.de>
PR fortran/44702
* module.c (sort_iso_c_rename_list): Remove.
(import_iso_c_binding_module,use_iso_fortran_env_module):
Allow multiple imports of the same symbol.
2010-07-11 Mikael Morin <mikael@gcc.gnu.org>
* arith.c (gfc_arith_done_1): Release mpfr internal caches.

212
gcc/fortran/module.c
View File

@ -5201,53 +5201,6 @@ gfc_dump_module (const char *name, int dump_flag)
}
static void
sort_iso_c_rename_list (void)
{
gfc_use_rename *tmp_list = NULL;
gfc_use_rename *curr;
gfc_use_rename *kinds_used[ISOCBINDING_NUMBER] = {NULL};
int c_kind;
int i;
for (curr = gfc_rename_list; curr; curr = curr->next)
{
c_kind = get_c_kind (curr->use_name, c_interop_kinds_table);
if (c_kind == ISOCBINDING_INVALID || c_kind == ISOCBINDING_LAST)
{
gfc_error ("Symbol '%s' referenced at %L does not exist in "
"intrinsic module ISO_C_BINDING.", curr->use_name,
&curr->where);
}
else
/* Put it in the list. */
kinds_used[c_kind] = curr;
}
/* Make a new (sorted) rename list. */
i = 0;
while (i < ISOCBINDING_NUMBER && kinds_used[i] == NULL)
i++;
if (i < ISOCBINDING_NUMBER)
{
tmp_list = kinds_used[i];
i++;
curr = tmp_list;
for (; i < ISOCBINDING_NUMBER; i++)
if (kinds_used[i] != NULL)
{
curr->next = kinds_used[i];
curr = curr->next;
curr->next = NULL;
}
}
gfc_rename_list = tmp_list;
}
/* Import the intrinsic ISO_C_BINDING module, generating symbols in
the current namespace for all named constants, pointer types, and
procedures in the module unless the only clause was used or a rename
@ -5261,7 +5214,6 @@ import_iso_c_binding_module (void)
const char *iso_c_module_name = "__iso_c_binding";
gfc_use_rename *u;
int i;
char *local_name;
/* Look only in the current namespace. */
mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
@ -5286,57 +5238,32 @@ import_iso_c_binding_module (void)
/* Generate the symbols for the named constants representing
the kinds for intrinsic data types. */
if (only_flag)
for (i = 0; i < ISOCBINDING_NUMBER; i++)
{
/* Sort the rename list because there are dependencies between types
and procedures (e.g., c_loc needs c_ptr). */
sort_iso_c_rename_list ();
bool found = false;
for (u = gfc_rename_list; u; u = u->next)
{
i = get_c_kind (u->use_name, c_interop_kinds_table);
if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
{
u->found = 1;
found = true;
generate_isocbinding_symbol (iso_c_module_name,
(iso_c_binding_symbol) i,
u->local_name);
}
if (i == ISOCBINDING_INVALID || i == ISOCBINDING_LAST)
{
gfc_error ("Symbol '%s' referenced at %L does not exist in "
"intrinsic module ISO_C_BINDING.", u->use_name,
&u->where);
continue;
}
generate_isocbinding_symbol (iso_c_module_name,
(iso_c_binding_symbol) i,
u->local_name);
}
}
else
{
for (i = 0; i < ISOCBINDING_NUMBER; i++)
{
local_name = NULL;
for (u = gfc_rename_list; u; u = u->next)
{
if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
{
local_name = u->local_name;
u->found = 1;
break;
}
}
generate_isocbinding_symbol (iso_c_module_name,
(iso_c_binding_symbol) i,
local_name);
}
if (!found && !only_flag)
generate_isocbinding_symbol (iso_c_module_name,
(iso_c_binding_symbol) i, NULL);
}
for (u = gfc_rename_list; u; u = u->next)
{
if (u->found)
continue;
for (u = gfc_rename_list; u; u = u->next)
{
if (u->found)
continue;
gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
"module ISO_C_BINDING", u->use_name, &u->where);
}
}
gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
"module ISO_C_BINDING", u->use_name, &u->where);
}
}
@ -5378,7 +5305,6 @@ static void
use_iso_fortran_env_module (void)
{
static char mod[] = "iso_fortran_env";
const char *local_name;
gfc_use_rename *u;
gfc_symbol *mod_sym;
gfc_symtree *mod_symtree;
@ -5414,60 +5340,41 @@ use_iso_fortran_env_module (void)
"non-intrinsic module name used previously", mod);
/* Generate the symbols for the module integer named constants. */
if (only_flag)
for (u = gfc_rename_list; u; u = u->next)
{
for (i = 0; symbol[i].name; i++)
if (strcmp (symbol[i].name, u->use_name) == 0)
break;
if (symbol[i].name == NULL)
{
gfc_error ("Symbol '%s' referenced at %L does not exist in "
"intrinsic module ISO_FORTRAN_ENV", u->use_name,
&u->where);
continue;
}
if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
&& symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
"from intrinsic module ISO_FORTRAN_ENV at %L is "
"incompatible with option %s", &u->where,
gfc_option.flag_default_integer
? "-fdefault-integer-8" : "-fdefault-real-8");
if (gfc_notify_std (symbol[i].standard, "The symbol '%s', referrenced "
"at %C, is not in the selected standard",
symbol[i].name) == FAILURE)
continue;
create_int_parameter (u->local_name[0] ? u->local_name
: symbol[i].name,
symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
symbol[i].id);
}
else
for (i = 0; symbol[i].name; i++)
{
for (i = 0; symbol[i].name; i++)
bool found = false;
for (u = gfc_rename_list; u; u = u->next)
{
local_name = NULL;
for (u = gfc_rename_list; u; u = u->next)
if (strcmp (symbol[i].name, u->use_name) == 0)
{
if (strcmp (symbol[i].name, u->use_name) == 0)
{
local_name = u->local_name;
u->found = 1;
break;
}
}
found = true;
u->found = 1;
if (u && gfc_notify_std (symbol[i].standard, "The symbol '%s', "
"referrenced at %C, is not in the selected "
"standard", symbol[i].name) == FAILURE)
continue;
else if ((gfc_option.allow_std & symbol[i].standard) == 0)
if (gfc_notify_std (symbol[i].standard, "The symbol '%s', "
"referrenced at %C, is not in the selected "
"standard", symbol[i].name) == FAILURE)
continue;
if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
&& symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named "
"constant from intrinsic module "
"ISO_FORTRAN_ENV at %C is incompatible with "
"option %s",
gfc_option.flag_default_integer
? "-fdefault-integer-8"
: "-fdefault-real-8");
create_int_parameter (u->local_name[0] ? u->local_name : u->use_name,
symbol[i].value, mod,
INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
}
}
if (!found && !only_flag)
{
if ((gfc_option.allow_std & symbol[i].standard) == 0)
continue;
if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
@ -5478,19 +5385,18 @@ use_iso_fortran_env_module (void)
gfc_option.flag_default_integer
? "-fdefault-integer-8" : "-fdefault-real-8");
create_int_parameter (local_name ? local_name : symbol[i].name,
symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
symbol[i].id);
create_int_parameter (symbol[i].name, symbol[i].value, mod,
INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
}
}
for (u = gfc_rename_list; u; u = u->next)
{
if (u->found)
continue;
for (u = gfc_rename_list; u; u = u->next)
{
if (u->found)
continue;
gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
"module ISO_FORTRAN_ENV", u->use_name, &u->where);
}
}
}

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
2010-07-11 Tobias Burnus <burnus@net-b.de>
PR fortran/44702
* gfortran.dg/use_rename_6.f90: New.
* gfortran.dg/use_iso_c_binding.f90: Update dg-error.
2010-07-11 Janus Weil <janus@gcc.gnu.org>
PR fortran/44869

4
gcc/testsuite/gfortran.dg/use_iso_c_binding.f90
View File

@ -7,12 +7,12 @@
! intrinsic one. --Rickett, 09.26.06
module use_stmt_0
! this is an error because c_ptr_2 does not exist
use, intrinsic :: iso_c_binding, only: c_ptr_2 ! { dg-error "Symbol 'c_ptr_2' referenced at \\(1\\) does not exist" }
use, intrinsic :: iso_c_binding, only: c_ptr_2 ! { dg-error "Symbol 'c_ptr_2' referenced at \\(1\\) not found" }
end module use_stmt_0
module use_stmt_1
! this is an error because c_ptr_2 does not exist
use iso_c_binding, only: c_ptr_2 ! { dg-error "Symbol 'c_ptr_2' referenced at \\(1\\) does not exist" }
use iso_c_binding, only: c_ptr_2 ! { dg-error "Symbol 'c_ptr_2' referenced at \\(1\\) not found" }
end module use_stmt_1
module use_stmt_2

40
gcc/testsuite/gfortran.dg/use_rename_6.f90 Normal file
View File

@ -0,0 +1,40 @@
! { dg-do compile }
! { dg-options "-fdump-tree-original" }
!
! PR fortran/44702
!
! Based on a test case by Joe Krahn.
!
! Multiple import of the same symbol was failing for
! intrinsic modules.
!
subroutine one()
use iso_c_binding, only: a => c_ptr, b => c_ptr, c_ptr
implicit none
type(a) :: x
type(b) :: y
type(c_ptr) :: z
end subroutine one
subroutine two()
use iso_c_binding, a => c_ptr, b => c_ptr
implicit none
type(a) :: x
type(b) :: y
end subroutine two
subroutine three()
use iso_fortran_env, only: a => error_unit, b => error_unit, error_unit
implicit none
if(a /= b) call shall_not_be_there()
if(a /= error_unit) call shall_not_be_there()
end subroutine three
subroutine four()
use iso_fortran_env, a => error_unit, b => error_unit
implicit none
if(a /= b) call shall_not_be_there()
end subroutine four
! { dg-final { scan-tree-dump-times "shall_not_be_there" 0 "original" } }
! { dg-final { cleanup-tree-dump "original" } }