/* The name of the module we're reading (USE'ing) or writing. */
static char module_name[GFC_MAX_SYMBOL_LEN + 1];
+/* The way the module we're reading was specified. */
+static bool specified_nonint, specified_int;
+
static int module_line, module_column, only_flag;
static enum
{ IO_INPUT, IO_OUTPUT }
match
gfc_match_use (void)
{
- char name[GFC_MAX_SYMBOL_LEN + 1];
+ char name[GFC_MAX_SYMBOL_LEN + 1], module_nature[GFC_MAX_SYMBOL_LEN + 1];
gfc_use_rename *tail = NULL, *new;
interface_type type;
gfc_intrinsic_op operator;
match m;
+ specified_int = false;
+ specified_nonint = false;
+
+ if (gfc_match (" , ") == MATCH_YES)
+ {
+ if ((m = gfc_match (" %n ::", module_nature)) == MATCH_YES)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: module "
+ "nature in USE statement at %C") == FAILURE)
+ return MATCH_ERROR;
+
+ if (strcmp (module_nature, "intrinsic") == 0)
+ specified_int = true;
+ else
+ {
+ if (strcmp (module_nature, "non_intrinsic") == 0)
+ specified_nonint = true;
+ else
+ {
+ gfc_error ("Module nature in USE statement at %C shall "
+ "be either INTRINSIC or NON_INTRINSIC");
+ return MATCH_ERROR;
+ }
+ }
+ }
+ else
+ {
+ /* Help output a better error message than "Unclassifiable
+ statement". */
+ 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 "
+ "but was not found");
+ return m;
+ }
+ }
+ else
+ {
+ m = gfc_match (" ::");
+ if (m == MATCH_YES &&
+ gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
+ "\"USE :: module\" at %C") == FAILURE)
+ return MATCH_ERROR;
+
+ if (m != MATCH_YES)
+ {
+ m = gfc_match ("% ");
+ if (m != MATCH_YES)
+ return m;
+ }
+ }
+
m = gfc_match_name (module_name);
if (m != MATCH_YES)
return m;
typedef enum
{ AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
- AB_POINTER, AB_SAVE, AB_TARGET, AB_DUMMY, AB_RESULT,
- AB_DATA, AB_IN_NAMELIST, AB_IN_COMMON,
- AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE, AB_ELEMENTAL, AB_PURE,
- AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT, AB_CRAY_POINTER,
- AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP, AB_VOLATILE
+ AB_POINTER, AB_SAVE, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA,
+ AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE,
+ AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
+ AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
+ AB_VALUE, AB_VOLATILE
}
ab_attribute;
minit ("OPTIONAL", AB_OPTIONAL),
minit ("POINTER", AB_POINTER),
minit ("SAVE", AB_SAVE),
+ minit ("VALUE", AB_VALUE),
minit ("VOLATILE", AB_VOLATILE),
minit ("TARGET", AB_TARGET),
minit ("THREADPRIVATE", AB_THREADPRIVATE),
MIO_NAME(ab_attribute) (AB_POINTER, attr_bits);
if (attr->save)
MIO_NAME(ab_attribute) (AB_SAVE, attr_bits);
+ if (attr->value)
+ MIO_NAME(ab_attribute) (AB_VALUE, attr_bits);
if (attr->volatile_)
MIO_NAME(ab_attribute) (AB_VOLATILE, attr_bits);
if (attr->target)
case AB_SAVE:
attr->save = 1;
break;
+ case AB_VALUE:
+ attr->value = 1;
+ break;
case AB_VOLATILE:
attr->volatile_ = 1;
break;
}
+/* Add an integer named constant from a given module. */
+static void
+create_int_parameter (const char *name, int value, const char *modname)
+{
+ 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);
+ sym = tmp_symtree->n.sym;
+
+ sym->module = gfc_get_string (modname);
+ sym->attr.flavor = FL_PARAMETER;
+ sym->ts.type = BT_INTEGER;
+ sym->ts.kind = gfc_default_integer_kind;
+ sym->value = gfc_int_expr (value);
+ sym->attr.use_assoc = 1;
+}
+
+/* USE the ISO_FORTRAN_ENV intrinsic module. */
+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;
+ int i;
+
+ mstring symbol[] = {
+#define NAMED_INTCST(a,b,c) minit(b,0),
+#include "iso-fortran-env.def"
+#undef NAMED_INTCST
+ minit (NULL, -1234) };
+
+ i = 0;
+#define NAMED_INTCST(a,b,c) symbol[i++].tag = c;
+#include "iso-fortran-env.def"
+#undef NAMED_INTCST
+
+ /* Generate the symbol for the module itself. */
+ mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
+ if (mod_symtree == NULL)
+ {
+ gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree);
+ gcc_assert (mod_symtree);
+ mod_sym = mod_symtree->n.sym;
+
+ mod_sym->attr.flavor = FL_MODULE;
+ mod_sym->attr.intrinsic = 1;
+ mod_sym->module = gfc_get_string (mod);
+ }
+ else
+ if (!mod_symtree->n.sym->attr.intrinsic)
+ gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
+ "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].string; i++)
+ if (strcmp (symbol[i].string, u->use_name) == 0)
+ break;
+
+ if (symbol[i].string == 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)
+ && strcmp (symbol[i].string, "numeric_storage_size") == 0)
+ 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");
+
+ create_int_parameter (u->local_name[0] ? u->local_name
+ : symbol[i].string,
+ symbol[i].tag, mod);
+ }
+ else
+ {
+ for (i = 0; symbol[i].string; i++)
+ {
+ local_name = NULL;
+ for (u = gfc_rename_list; u; u = u->next)
+ {
+ if (strcmp (symbol[i].string, u->use_name) == 0)
+ {
+ local_name = u->local_name;
+ u->found = 1;
+ break;
+ }
+ }
+
+ if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
+ && strcmp (symbol[i].string, "numeric_storage_size") == 0)
+ 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 (local_name ? local_name : symbol[i].string,
+ symbol[i].tag, mod);
+ }
+
+ 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_FORTRAN_ENV", u->use_name, &u->where);
+ }
+ }
+}
+
/* Process a USE directive. */
void
char *filename;
gfc_state_data *p;
int c, line, start;
+ gfc_symtree *mod_symtree;
filename = (char *) alloca(strlen(module_name) + strlen(MODULE_EXTENSION)
+ 1);
strcpy (filename, module_name);
strcat (filename, MODULE_EXTENSION);
- module_fp = gfc_open_included_file (filename, true);
+ /* First, try to find an non-intrinsic module, unless the USE statement
+ specified that the module is intrinsic. */
+ module_fp = NULL;
+ if (!specified_int)
+ module_fp = gfc_open_included_file (filename, true, true);
+
+ /* Then, see if it's an intrinsic one, unless the USE statement
+ specified that the module is non-intrinsic. */
+ if (module_fp == NULL && !specified_nonint)
+ {
+ if (strcmp (module_name, "iso_fortran_env") == 0
+ && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
+ "ISO_FORTRAN_ENV intrinsic module at %C") != FAILURE)
+ {
+ use_iso_fortran_env_module ();
+ return;
+ }
+
+ module_fp = gfc_open_intrinsic_module (filename);
+
+ if (module_fp == NULL && specified_int)
+ gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
+ module_name);
+ }
+
if (module_fp == NULL)
gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
filename, strerror (errno));
+ /* Check that we haven't already USEd an intrinsic module with the
+ same name. */
+
+ mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name);
+ if (mod_symtree && mod_symtree->n.sym->attr.intrinsic)
+ gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
+ "intrinsic module name used previously", module_name);
+
iomode = IO_INPUT;
module_line = 1;
module_column = 1;
OSDN Git Service
