2010-09-26 Tobias Burnus <burnus@net-b.de>
PR fortran/40569
PR fortran/40568
* intrinsic.h (gfc_simplify_compiler_options,
gfc_simplify_compiler_version): New prototypes.
* intrinsic.c (gfc_intrinsic_function_by_id,
make_from_module): New functions.
(gfc_find_function, gfc_find_subroutine, gfc_generic_intrinsic,
gfc_specific_intrinsic): Don't return module intrinsics.
(add_functions): Add compiler_options, compiler_version.
(gfc_intrinsic_func_interface): Also lookup symbol by ISYM ID.
* symbol.c (std_for_isocbinding_symbol): Add version check for
NAMED_FUNCTIONS.
* iso-fortran-env.def: Add compiler_options, compiler_version.
* iso-c-binding.def: Add c_sizeof.
* gfortran.h (gfc_intrinsic_sym): Add from_module:1.
(iso_c_binding_symbol, iso_fortran_env_symbol): Add NAMED_FUNCTIONS.
(gfc_intrinsic_function_by_id): New prototype.
* module.c (create_intrinsic_function): New function.
(import_iso_c_binding_module, use_iso_fortran_env_module): Use it.
* trans-types.c (init_c_interop_kinds): Add NAMED_FUNCTIONS.
* resolve.c (resolve_intrinsic): Try also to resolve intrinsics
by ISYM ID.
* simplify.c (gfc_simplify_compiler_options,
gfc_simplify_compiler_version): New functions.
2010-09-26 Tobias Burnus <burnus@net-b.de>
PR fortran/40569
PR fortran/40568
* gfortran.dg/storage_size_2.f08: Fix test.
* gfortran.dg/c_sizeof_1.f90: Fix test.
* gfortran.dg/c_sizeof_2.f90: Update dg-error.
* gfortran.dg/c_sizeof_3.f90: New.
* gfortran.dg/c_sizeof_4.f90: New.
* gfortran.dg/iso_c_binding_compiler_1.f90: New.
* gfortran.dg/iso_c_binding_compiler_2.f90: New.
===================================================================
@@ -814,6 +814,22 @@ find_sym (gfc_intrinsic_sym *start, int
}
+gfc_intrinsic_sym *
+gfc_intrinsic_function_by_id (gfc_isym_id id)
+{
+ gfc_intrinsic_sym *start = functions;
+ while (true)
+ {
+ if (id == start->id)
+ return start;
+
+ start++;
+ }
+
+ return NULL;
+}
+
+
/* Given a name, find a function in the intrinsic function table.
Returns NULL if not found. */
@@ -823,10 +839,10 @@ gfc_find_function (const char *name)
gfc_intrinsic_sym *sym;
sym = find_sym (functions, nfunc, name);
- if (!sym)
+ if (!sym || sym->from_module)
sym = find_sym (conversion, nconv, name);
- return sym;
+ return (!sym || sym->from_module) ? NULL : sym;
}
@@ -836,7 +852,9 @@ gfc_find_function (const char *name)
gfc_intrinsic_sym *
gfc_find_subroutine (const char *name)
{
- return find_sym (subroutines, nsub, name);
+ gfc_intrinsic_sym *sym;
+ sym = find_sym (subroutines, nsub, name);
+ return (!sym || sym->from_module) ? NULL : sym;
}
@@ -849,7 +867,7 @@ gfc_generic_intrinsic (const char *name)
gfc_intrinsic_sym *sym;
sym = gfc_find_function (name);
- return (sym == NULL) ? 0 : sym->generic;
+ return (sym == NULL || sym->from_module) ? 0 : sym->generic;
}
@@ -862,7 +880,7 @@ gfc_specific_intrinsic (const char *name
gfc_intrinsic_sym *sym;
sym = gfc_find_function (name);
- return (sym == NULL) ? 0 : sym->specific;
+ return (sym == NULL || sym->from_module) ? 0 : sym->specific;
}
@@ -1014,6 +1032,15 @@ make_noreturn (void)
next_sym[-1].noreturn = 1;
}
+
+/* Mark current intrinsic as module intrinsic. */
+static void
+make_from_module (void)
+{
+ if (sizing == SZ_NOTHING)
+ next_sym[-1].from_module = 1;
+}
+
/* Set the attr.value of the current procedure. */
static void
@@ -2607,10 +2634,23 @@ add_functions (void)
x, BT_UNKNOWN, 0, REQUIRED);
make_generic ("sizeof", GFC_ISYM_SIZEOF, GFC_STD_GNU);
-
+
+ /* C_SIZEOF is part of ISO_C_BINDING. */
add_sym_1 ("c_sizeof", GFC_ISYM_C_SIZEOF, CLASS_INQUIRY, ACTUAL_NO,
BT_INTEGER, ii, GFC_STD_F2008, gfc_check_c_sizeof, NULL, NULL,
x, BT_UNKNOWN, 0, REQUIRED);
+ make_from_module();
+
+ /* COMPILER_OPTIONS and COMPILER_VERSION are part of ISO_FORTRAN_ENV. */
+ add_sym_0 ("compiler_options", GFC_ISYM_COMPILER_OPTIONS, CLASS_IMPURE,
+ ACTUAL_NO, BT_CHARACTER, 1, GFC_STD_F2008,
+ NULL, gfc_simplify_compiler_options, NULL);
+ make_from_module();
+
+ add_sym_0 ("compiler_version", GFC_ISYM_COMPILER_VERSION, CLASS_IMPURE,
+ ACTUAL_NO, BT_CHARACTER, 1, GFC_STD_F2008,
+ NULL, gfc_simplify_compiler_version, NULL);
+ make_from_module();
add_sym_1 ("spacing", GFC_ISYM_SPACING, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
gfc_check_x, gfc_simplify_spacing, gfc_resolve_spacing,
@@ -4012,7 +4052,14 @@ gfc_intrinsic_func_interface (gfc_expr *
name = expr->symtree->n.sym->name;
- isym = specific = gfc_find_function (name);
+ if (expr->symtree->n.sym->intmod_sym_id)
+ {
+ int id = expr->symtree->n.sym->intmod_sym_id;
+ isym = specific = gfc_intrinsic_function_by_id ((gfc_isym_id) id);
+ }
+ else
+ isym = specific = gfc_find_function (name);
+
if (isym == NULL)
{
if (!error_flag)
===================================================================
@@ -4280,6 +4280,13 @@ std_for_isocbinding_symbol (int id)
return d;
#include "iso-c-binding.def"
#undef NAMED_INTCST
+
+#define NAMED_FUNCTION(a,b,c,d) \
+ case a:\
+ return d;
+#include "iso-c-binding.def"
+#undef NAMED_FUNCTION
+
default:
return GFC_STD_F2003;
}
===================================================================
@@ -27,6 +27,9 @@ along with GCC; see the file COPYING3.
# define NAMED_KINDARRAY(a,b,c,d)
#endif
+#ifndef NAMED_FUNCTION
+# define NAMED_FUNCTION(a,b,c,d)
+#endif
/* The arguments to NAMED_INTCST are:
-- an internal name
@@ -97,5 +100,17 @@ NAMED_KINDARRAY (ISOFORTRAN_LOGICAL_KIND
NAMED_KINDARRAY (ISOFORTRAN_REAL_KINDS, "real_kinds", \
gfc_real_kinds, GFC_STD_F2008)
+/* The arguments to NAMED_FUNCTIONS are:
+ -- the ISYM
+ -- the symbol name in the module, as seen by Fortran code
+ -- the Fortran standard */
+
+NAMED_FUNCTION (ISOFORTRAN_COMPILER_OPTIONS, "compiler_options", \
+ GFC_ISYM_COMPILER_OPTIONS, GFC_STD_F2008)
+NAMED_FUNCTION (ISOFORTRAN_COMPILER_VERSION, "compiler_version", \
+ GFC_ISYM_COMPILER_VERSION, GFC_STD_F2008)
+
+
#undef NAMED_INTCST
#undef NAMED_KINDARRAY
+#undef NAMED_FUNCTION
===================================================================
@@ -246,6 +246,8 @@ gfc_expr *gfc_simplify_btest (gfc_expr *
gfc_expr *gfc_simplify_ceiling (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_char (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_cmplx (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_compiler_options (void);
+gfc_expr *gfc_simplify_compiler_version (void);
gfc_expr *gfc_simplify_complex (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_conjg (gfc_expr *);
gfc_expr *gfc_simplify_cos (gfc_expr *);
===================================================================
@@ -343,6 +343,8 @@ enum gfc_isym_id
GFC_ISYM_CHMOD,
GFC_ISYM_CMPLX,
GFC_ISYM_COMMAND_ARGUMENT_COUNT,
+ GFC_ISYM_COMPILER_OPTIONS,
+ GFC_ISYM_COMPILER_VERSION,
GFC_ISYM_COMPLEX,
GFC_ISYM_CONJG,
GFC_ISYM_CONVERSION,
@@ -614,6 +616,7 @@ gfc_reverse;
#define NAMED_INTCST(a,b,c,d) a,
#define NAMED_KINDARRAY(a,b,c,d) a,
+#define NAMED_FUNCTION(a,b,c,d) a,
typedef enum
{
ISOFORTRANENV_INVALID = -1,
@@ -621,7 +624,9 @@ typedef enum
ISOFORTRANENV_LAST, ISOFORTRANENV_NUMBER = ISOFORTRANENV_LAST
}
iso_fortran_env_symbol;
+#undef NAMED_INTCST
#undef NAMED_KINDARRAY
+#undef NAMED_FUNCTION
#define NAMED_INTCST(a,b,c,d) a,
#define NAMED_REALCST(a,b,c) a,
@@ -631,6 +636,7 @@ iso_fortran_env_symbol;
#define NAMED_CHARCST(a,b,c) a,
#define DERIVED_TYPE(a,b,c) a,
#define PROCEDURE(a,b) a,
+#define NAMED_FUNCTION(a,b,c,d) a,
typedef enum
{
ISOCBINDING_INVALID = -1,
@@ -647,6 +653,7 @@ iso_c_binding_symbol;
#undef NAMED_CHARCST
#undef DERIVED_TYPE
#undef PROCEDURE
+#undef NAMED_FUNCTION
typedef enum
{
@@ -1645,7 +1652,8 @@ typedef struct gfc_intrinsic_sym
gfc_intrinsic_arg *formal;
gfc_typespec ts;
unsigned elemental:1, inquiry:1, transformational:1, pure:1,
- generic:1, specific:1, actual_ok:1, noreturn:1, conversion:1;
+ generic:1, specific:1, actual_ok:1, noreturn:1, conversion:1,
+ from_module:1;
int standard;
@@ -2638,6 +2646,7 @@ bool gfc_is_intrinsic (gfc_symbol*, int,
int gfc_intrinsic_actual_ok (const char *, const bool);
gfc_intrinsic_sym *gfc_find_function (const char *);
gfc_intrinsic_sym *gfc_find_subroutine (const char *);
+gfc_intrinsic_sym *gfc_intrinsic_function_by_id (gfc_isym_id);
match gfc_intrinsic_func_interface (gfc_expr *, int);
match gfc_intrinsic_sub_interface (gfc_code *, int);
===================================================================
@@ -39,6 +39,10 @@ along with GCC; see the file COPYING3.
# define NAMED_CHARKNDCST(a,b,c)
#endif
+#ifndef NAMED_FUNCTION
+# define NAMED_FUNCTION(a,b,c,d)
+#endif
+
/* The arguments to NAMED_*CST are:
-- an internal name
-- the symbol name in the module, as seen by Fortran code
@@ -162,6 +166,15 @@ PROCEDURE (ISOCBINDING_LOC, "c_loc")
PROCEDURE (ISOCBINDING_FUNLOC, "c_funloc")
PROCEDURE (ISOCBINDING_F_PROCPOINTER, "c_f_procpointer")
+/* The arguments to NAMED_FUNCTIONS are:
+ -- the ISYM
+ -- the symbol name in the module, as seen by Fortran code
+ -- the Fortran standard */
+
+NAMED_FUNCTION (ISOCBINDING_C_SIZEOF, "c_sizeof", \
+ GFC_ISYM_C_SIZEOF, GFC_STD_F2008)
+
+
#undef NAMED_INTCST
#undef NAMED_REALCST
#undef NAMED_CMPXCST
@@ -170,3 +183,4 @@ PROCEDURE (ISOCBINDING_F_PROCPOINTER, "c
#undef NAMED_CHARKNDCST
#undef DERIVED_TYPE
#undef PROCEDURE
+#undef NAMED_FUNCTION
===================================================================
@@ -5207,6 +5207,39 @@ gfc_dump_module (const char *name, int d
}
+static void
+create_intrinsic_function (const char *name, gfc_isym_id id,
+ const char *modname, intmod_id module)
+{
+ gfc_intrinsic_sym *isym;
+ gfc_symtree *tmp_symtree;
+ gfc_symbol *sym;
+
+ tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
+ if (tmp_symtree != NULL)
+ {
+ if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
+ return;
+ else
+ gfc_error ("Symbol '%s' already declared", name);
+ }
+
+ gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
+ sym = tmp_symtree->n.sym;
+
+ isym = gfc_intrinsic_function_by_id (id);
+ gcc_assert (isym);
+
+ sym->attr.flavor = FL_PROCEDURE;
+ sym->attr.intrinsic = 1;
+
+ sym->module = gfc_get_string (modname);
+ sym->attr.use_assoc = 1;
+ sym->from_intmod = module;
+ sym->intmod_sym_id = id;
+}
+
+
/* 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
@@ -5252,14 +5285,45 @@ import_iso_c_binding_module (void)
{
u->found = 1;
found = true;
- generate_isocbinding_symbol (iso_c_module_name,
- (iso_c_binding_symbol) i,
- u->local_name);
+ switch (i)
+ {
+#define NAMED_FUNCTION(a,b,c,d) \
+ case a: \
+ create_intrinsic_function (u->local_name[0] ? u->local_name \
+ : u->use_name, \
+ (gfc_isym_id) c, \
+ iso_c_module_name, \
+ INTMOD_ISO_C_BINDING); \
+ break;
+#include "iso-c-binding.def"
+#undef NAMED_FUNCTION
+
+ default:
+ generate_isocbinding_symbol (iso_c_module_name,
+ (iso_c_binding_symbol) i,
+ u->local_name[0] ? u->local_name
+ : u->use_name);
+ }
}
if (!found && !only_flag)
- generate_isocbinding_symbol (iso_c_module_name,
- (iso_c_binding_symbol) i, NULL);
+ switch (i)
+ {
+#define NAMED_FUNCTION(a,b,c,d) \
+ case a: \
+ if ((gfc_option.allow_std & d) == 0) \
+ continue; \
+ create_intrinsic_function (b, (gfc_isym_id) c, \
+ iso_c_module_name, \
+ INTMOD_ISO_C_BINDING); \
+ break;
+#include "iso-c-binding.def"
+#undef NAMED_FUNCTION
+
+ default:
+ generate_isocbinding_symbol (iso_c_module_name,
+ (iso_c_binding_symbol) i, NULL);
+ }
}
for (u = gfc_rename_list; u; u = u->next)
@@ -5367,6 +5431,9 @@ use_iso_fortran_env_module (void)
#define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
#include "iso-fortran-env.def"
#undef NAMED_KINDARRAY
+#define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
+#include "iso-fortran-env.def"
+#undef NAMED_FUNCTION
{ ISOFORTRANENV_INVALID, NULL, -1234, 0 } };
i = 0;
@@ -5448,6 +5515,16 @@ use_iso_fortran_env_module (void)
#include "iso-fortran-env.def"
#undef NAMED_KINDARRAY
+#define NAMED_FUNCTION(a,b,c,d) \
+ case a:
+#include "iso-fortran-env.def"
+#undef NAMED_FUNCTION
+ create_intrinsic_function (u->local_name[0] ? u->local_name
+ : u->use_name,
+ (gfc_isym_id) symbol[i].value, mod,
+ INTMOD_ISO_FORTRAN_ENV);
+ break;
+
default:
gcc_unreachable ();
}
@@ -5491,6 +5568,15 @@ use_iso_fortran_env_module (void)
#include "iso-fortran-env.def"
#undef NAMED_KINDARRAY
+#define NAMED_FUNCTION(a,b,c,d) \
+ case a:
+#include "iso-fortran-env.def"
+#undef NAMED_FUNCTION
+ create_intrinsic_function (symbol[i].name,
+ (gfc_isym_id) symbol[i].value, mod,
+ INTMOD_ISO_FORTRAN_ENV);
+ break;
+
default:
gcc_unreachable ();
}
===================================================================
@@ -333,6 +333,11 @@ void init_c_interop_kinds (void)
c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
c_interop_kinds_table[a].value = 0;
#include "iso-c-binding.def"
+#define NAMED_FUNCTION(a,b,c,d) \
+ strncpy (c_interop_kinds_table[a].name, b, strlen(b) + 1); \
+ c_interop_kinds_table[a].f90_type = BT_PROCEDURE; \
+ c_interop_kinds_table[a].value = c;
+#include "iso-c-binding.def"
}
===================================================================
@@ -1407,7 +1407,10 @@ resolve_intrinsic (gfc_symbol *sym, locu
gfc_find_subroutine directly to check whether it is a function or
subroutine. */
- if ((isym = gfc_find_function (sym->name)))
+ if ((sym->intmod_sym_id
+ && (isym
+ = gfc_intrinsic_function_by_id ((gfc_isym_id) sym->intmod_sym_id)))
+ || (isym = gfc_find_function (sym->name)))
{
if (sym->ts.type != BT_UNKNOWN && gfc_option.warn_surprising
&& !sym->attr.implicit_type)
===================================================================
@@ -27,6 +27,7 @@ along with GCC; see the file COPYING3.
#include "intrinsic.h"
#include "target-memory.h"
#include "constructor.h"
+#include "version.h" /* For version_string. */
gfc_expr gfc_bad_expr;
@@ -6733,3 +6734,21 @@ gfc_convert_char_constant (gfc_expr *e,
else
return NULL;
}
+
+
+gfc_expr *
+gfc_simplify_compiler_options (void)
+{
+ /* FIXME: PR40569 - return the proper compiler arguments. */
+ return gfc_get_character_expr (gfc_default_character_kind,
+ &gfc_current_locus, "", 0);
+}
+
+
+gfc_expr *
+gfc_simplify_compiler_version (void)
+{
+ return gfc_get_character_expr (gfc_default_character_kind,
+ &gfc_current_locus, version_string,
+ strlen (version_string));
+}
===================================================================
@@ -4,7 +4,7 @@
!
! Contributed by Janus Weil <janus@gcc.gnu.org>
-use iso_c_binding, only: c_int
+use iso_c_binding, only: c_int, c_sizeof
type, bind(c) :: t
integer(c_int) :: j
===================================================================
@@ -1,7 +1,7 @@
! { dg-do run }
! Support F2008's c_sizeof()
!
-use iso_c_binding, only: c_int, c_char, c_ptr, c_intptr_t, c_null_ptr
+use iso_c_binding, only: c_int, c_char, c_ptr, c_intptr_t, c_null_ptr, c_sizeof
integer(kind=c_int) :: i, j(10)
character(kind=c_char,len=4),parameter :: str(1) = "abcd"
===================================================================
@@ -0,0 +1,18 @@
+! { dg-do link }
+!
+! PR fortran/40568
+!
+! Module checks for C_SIZEOF (part of ISO_C_BINDING)
+!
+subroutine test
+use iso_c_binding, only: foo => c_sizeof, bar=> c_sizeof, c_sizeof, c_int
+integer(c_int) :: i
+print *, c_sizeof(i), bar(i), foo(i)
+end
+
+use iso_c_binding
+implicit none
+integer(c_int) :: i
+print *, c_sizeof(i)
+call test()
+end
===================================================================
@@ -0,0 +1,11 @@
+! { dg-do compile }
+! { dg-options "-std=f2003" }
+!
+! PR fortran/40569
+!
+! Check compiler_version/compiler_options intrinsics
+!
+use iso_fortran_env, only: compiler_options ! { dg-error "is not in the selected standard" }
+use iso_fortran_env, only: compiler_version ! { dg-error "is not in the selected standard" }
+ implicit none
+end
===================================================================
@@ -2,8 +2,8 @@
! { dg-options "-std=f2003 -Wall -Wno-conversion" }
! Support F2008's c_sizeof()
!
-USE ISO_C_BINDING
+USE ISO_C_BINDING, only: C_SIZE_T, c_sizeof ! { dg-error "new in Fortran 2008" }
integer(C_SIZE_T) :: i
-i = c_sizeof(i) ! { dg-warning "Fortran 2008" }
+i = c_sizeof(i)
end
===================================================================
@@ -0,0 +1,18 @@
+! { dg-do link }
+!
+! PR fortran/40569
+!
+! Check compiler_version/compiler_options intrinsics
+!
+subroutine test()
+ use iso_fortran_env, only: compiler_version
+ print '(3a)', '>>',compiler_version(),'<<'
+end
+
+use iso_fortran_env, foo => compiler_version, bar => compiler_version
+ implicit none
+ print *, foo()
+ print *, bar()
+ print '(3a)', '>',compiler_options(),'<'
+ call test()
+end
===================================================================
@@ -0,0 +1,10 @@
+! { dg-do link }
+!
+! PR fortran/40568
+!
+! Module checks for C_SIZEOF (part of ISO_C_BINDING)
+!
+
+implicit none
+intrinsic c_sizeof ! { dg-error "does not exist" }
+end