GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 2, or (at your option) any later
+Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
for more details.
You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
-02110-1301, USA. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
/* The syntax of gfortran modules resembles that of lisp lists, ie a
sequence of atoms, which can be left or right parenthesis, names,
#include "arith.h"
#include "match.h"
#include "parse.h" /* FIXME */
+#include "md5.h"
#define MODULE_EXTENSION ".mod"
}
module_locus;
+/* Structure for list of symbols of intrinsic modules. */
+typedef struct
+{
+ int id;
+ const char *name;
+ int value;
+}
+intmod_sym;
+
typedef enum
{
module_locus where;
fixup_t *stfixup;
gfc_symtree *symtree;
+ char binding_label[GFC_MAX_SYMBOL_LEN + 1];
}
rsym;
/* The FILE for the module we're reading or writing. */
static FILE *module_fp;
+/* MD5 context structure. */
+static struct md5_ctx ctx;
+
/* The name of the module we're reading (USE'ing) or writing. */
static char module_name[GFC_MAX_SYMBOL_LEN + 1];
static pointer_info *pi_root;
static int symbol_number; /* Counter for assigning symbol numbers */
-/* Tells mio_expr_ref not to load unused equivalence members. */
+/* Tells mio_expr_ref to make symbols for unused equivalence members. */
static bool in_load_equiv;
/* Resolve any fixups using a known pointer. */
+
static void
resolve_fixups (fixup_t *f, void *gp)
{
{
char name[GFC_MAX_SYMBOL_LEN + 1], module_nature[GFC_MAX_SYMBOL_LEN + 1];
gfc_use_rename *tail = NULL, *new;
- interface_type type;
+ interface_type type, type2;
gfc_intrinsic_op operator;
match m;
gfc_error ("Missing generic specification in USE statement at %C");
goto cleanup;
+ case INTERFACE_USER_OP:
case INTERFACE_GENERIC:
m = gfc_match (" =>");
+ if (type == INTERFACE_USER_OP && m == MATCH_YES
+ && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Renaming "
+ "operators in USE statements at %C")
+ == FAILURE))
+ goto cleanup;
+
+ if (type == INTERFACE_USER_OP)
+ new->operator = INTRINSIC_USER;
+
if (only_flag)
{
if (m != MATCH_YES)
else
{
strcpy (new->local_name, name);
-
- m = gfc_match_name (new->use_name);
+ m = gfc_match_generic_spec (&type2, new->use_name, &operator);
+ if (type != type2)
+ goto syntax;
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
goto syntax;
strcpy (new->local_name, name);
- m = gfc_match_name (new->use_name);
+ m = gfc_match_generic_spec (&type2, new->use_name, &operator);
+ if (type != type2)
+ goto syntax;
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
goto cleanup;
}
+ if (strcmp (new->use_name, module_name) == 0
+ || strcmp (new->local_name, module_name) == 0)
+ {
+ gfc_error ("The name '%s' at %C has already been used as "
+ "an external module name.", module_name);
+ goto cleanup;
+ }
break;
- case INTERFACE_USER_OP:
- strcpy (new->use_name, name);
- /* Fall through */
-
case INTERFACE_INTRINSIC_OP:
new->operator = operator;
break;
/* Given a name and a number, inst, return the inst name
under which to load this symbol. Returns NULL if this
symbol shouldn't be loaded. If inst is zero, returns
- the number of instances of this name. */
+ the number of instances of this name. If interface is
+ true, a user-defined operator is sought, otherwise only
+ non-operators are sought. */
static const char *
-find_use_name_n (const char *name, int *inst)
+find_use_name_n (const char *name, int *inst, bool interface)
{
gfc_use_rename *u;
int i;
i = 0;
for (u = gfc_rename_list; u; u = u->next)
{
- if (strcmp (u->use_name, name) != 0)
+ if (strcmp (u->use_name, name) != 0
+ || (u->operator == INTRINSIC_USER && !interface)
+ || (u->operator != INTRINSIC_USER && interface))
continue;
if (++i == *inst)
break;
Returns NULL if this symbol shouldn't be loaded. */
static const char *
-find_use_name (const char *name)
+find_use_name (const char *name, bool interface)
{
int i = 1;
- return find_use_name_n (name, &i);
+ return find_use_name_n (name, &i, interface);
}
/* Given a real name, return the number of use names associated with it. */
static int
-number_use_names (const char *name)
+number_use_names (const char *name, bool interface)
{
int i = 0;
const char *c;
- c = find_use_name_n (name, &i);
+ c = find_use_name_n (name, &i, interface);
return i;
}
{
int c;
- c = fgetc (module_fp);
+ c = getc (module_fp);
if (c == EOF)
bad_module ("Unexpected EOF");
len = 0;
- /* See how long the string is */
+ /* See how long the string is. */
for ( ; ; )
{
c = module_char ();
{
c = module_char ();
if (c == '\'')
- module_char (); /* Guaranteed to be another \' */
+ module_char (); /* Guaranteed to be another \'. */
*p++ = c;
}
- module_char (); /* Terminating \' */
+ module_char (); /* Terminating \'. */
*p = '\0'; /* C-style string for debug purposes. */
}
bad_module ("Bad name");
}
- /* Not reached */
+ /* Not reached. */
}
bad_module ("find_enum(): Enum not found");
- /* Not reached */
+ /* Not reached. */
}
static void
write_char (char out)
{
- if (fputc (out, module_fp) == EOF)
+ if (putc (out, module_fp) == EOF)
gfc_fatal_error ("Error writing modules file: %s", strerror (errno));
+ /* Add this to our MD5. */
+ md5_process_bytes (&out, sizeof (out), &ctx);
+
if (out != '\n')
module_column++;
else
}
+ if(p == NULL || *p == '\0')
+ len = 0;
+ else
len = strlen (p);
if (atom != ATOM_RPAREN)
if (atom == ATOM_STRING)
write_char ('\'');
- while (*p)
+ while (p != NULL && *p)
{
if (atom == ATOM_STRING && *p == '\'')
write_char ('\'');
}
-/* Read or write a character pointer that points to a string on the
- heap. */
+/* Read or write a character pointer that points to a string on the heap. */
static const char *
mio_allocated_string (const char *s)
}
-
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_POINTER, 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_PROTECTED
+ AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
+ AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C
}
ab_attribute;
minit ("INTRINSIC", AB_INTRINSIC),
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),
minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
minit ("CRAY_POINTER", AB_CRAY_POINTER),
minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
+ minit ("IS_BIND_C", AB_IS_BIND_C),
+ minit ("IS_C_INTEROP", AB_IS_C_INTEROP),
+ minit ("IS_ISO_C", AB_IS_ISO_C),
+ minit ("VALUE", AB_VALUE),
minit ("ALLOC_COMP", AB_ALLOC_COMP),
+ minit ("POINTER_COMP", AB_POINTER_COMP),
+ minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
minit ("PROTECTED", AB_PROTECTED),
minit (NULL, -1)
};
+
/* Specialization of mio_name. */
DECL_MIO_NAME (ab_attribute)
DECL_MIO_NAME (ar_type)
DECL_MIO_NAME (gfc_access)
DECL_MIO_NAME (gfc_intrinsic_op)
DECL_MIO_NAME (ifsrc)
+DECL_MIO_NAME (save_state)
DECL_MIO_NAME (procedure_type)
DECL_MIO_NAME (ref_type)
DECL_MIO_NAME (sym_flavor)
attr->intent = MIO_NAME (sym_intent) (attr->intent, intents);
attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
+ attr->save = MIO_NAME (save_state) (attr->save, save_status);
if (iomode == IO_OUTPUT)
{
MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
if (attr->protected)
MIO_NAME (ab_attribute) (AB_PROTECTED, 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_CRAY_POINTER, attr_bits);
if (attr->cray_pointee)
MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits);
+ if (attr->is_bind_c)
+ MIO_NAME(ab_attribute) (AB_IS_BIND_C, attr_bits);
+ if (attr->is_c_interop)
+ MIO_NAME(ab_attribute) (AB_IS_C_INTEROP, attr_bits);
+ if (attr->is_iso_c)
+ MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits);
if (attr->alloc_comp)
MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
+ if (attr->pointer_comp)
+ MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits);
+ if (attr->private_comp)
+ MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
mio_rparen ();
case AB_PROTECTED:
attr->protected = 1;
break;
- case AB_SAVE:
- attr->save = 1;
- break;
case AB_VALUE:
attr->value = 1;
break;
case AB_CRAY_POINTEE:
attr->cray_pointee = 1;
break;
+ case AB_IS_BIND_C:
+ attr->is_bind_c = 1;
+ break;
+ case AB_IS_C_INTEROP:
+ attr->is_c_interop = 1;
+ break;
+ case AB_IS_ISO_C:
+ attr->is_iso_c = 1;
+ break;
case AB_ALLOC_COMP:
attr->alloc_comp = 1;
break;
+ case AB_POINTER_COMP:
+ attr->pointer_comp = 1;
+ break;
+ case AB_PRIVATE_COMP:
+ attr->private_comp = 1;
+ break;
}
}
}
minit ("DERIVED", BT_DERIVED),
minit ("PROCEDURE", BT_PROCEDURE),
minit ("UNKNOWN", BT_UNKNOWN),
+ minit ("VOID", BT_VOID),
minit (NULL, -1)
};
}
-/* Return a symtree node with a name that is guaranteed to be unique
- within the namespace and corresponds to an illegal fortran name. */
-
-static gfc_symtree *
-get_unique_symtree (gfc_namespace *ns)
-{
- char name[GFC_MAX_SYMBOL_LEN + 1];
- static int serial = 0;
-
- sprintf (name, "@%d", serial++);
- return gfc_new_symtree (&ns->sym_root, name);
-}
-
-
/* See if a name is a generated name. */
static int
else
mio_symbol_ref (&ts->derived);
- mio_charlen (&ts->cl);
+ /* Add info for C interop and is_iso_c. */
+ mio_integer (&ts->is_c_interop);
+ mio_integer (&ts->is_iso_c);
+
+ /* If the typespec is for an identifier either from iso_c_binding, or
+ a constant that was initialized to an identifier from it, use the
+ f90_type. Otherwise, use the ts->type, since it shouldn't matter. */
+ if (ts->is_iso_c)
+ ts->f90_type = MIO_NAME (bt) (ts->f90_type, bt_types);
+ else
+ ts->f90_type = MIO_NAME (bt) (ts->type, bt_types);
+
+ if (ts->type != BT_CHARACTER)
+ {
+ /* ts->cl is only valid for BT_CHARACTER. */
+ mio_lparen ();
+ mio_rparen ();
+ }
+ else
+ mio_charlen (&ts->cl);
mio_rparen ();
}
mio_integer (&c->dimension);
mio_integer (&c->pointer);
mio_integer (&c->allocatable);
+ c->access = MIO_NAME (gfc_access) (c->access, access_types);
mio_expr (&c->initializer);
mio_rparen ();
{
for (f = sym->formal; f; f = f->next)
mio_symbol_ref (&f->sym);
-
}
else
{
require_atom (ATOM_INTEGER);
p = get_integer (atom_int);
- /* An unused equivalence member; bail out. */
+ /* An unused equivalence member; make a symbol and a symtree
+ for it. */
if (in_load_equiv && p->u.rsym.symtree == NULL)
- return;
+ {
+ /* Since this is not used, it must have a unique name. */
+ p->u.rsym.symtree = gfc_get_unique_symtree (gfc_current_ns);
+
+ /* Make the symbol. */
+ if (p->u.rsym.sym == NULL)
+ {
+ p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name,
+ gfc_current_ns);
+ p->u.rsym.sym->module = gfc_get_string (p->u.rsym.module);
+ }
+
+ p->u.rsym.symtree->n.sym = p->u.rsym.sym;
+ p->u.rsym.symtree->n.sym->refs++;
+ p->u.rsym.referenced = 1;
+ }
if (p->type == P_UNKNOWN)
p->type = P_SYMBOL;
f->next = p->u.rsym.stfixup;
p->u.rsym.stfixup = f;
- f->pointer = (void **)stp;
+ f->pointer = (void **) stp;
}
}
}
minit ("OR", INTRINSIC_OR),
minit ("EQV", INTRINSIC_EQV),
minit ("NEQV", INTRINSIC_NEQV),
- minit ("EQ", INTRINSIC_EQ),
- minit ("NE", INTRINSIC_NE),
- minit ("GT", INTRINSIC_GT),
- minit ("GE", INTRINSIC_GE),
- minit ("LT", INTRINSIC_LT),
- minit ("LE", INTRINSIC_LE),
+ minit ("==", INTRINSIC_EQ),
+ minit ("EQ", INTRINSIC_EQ_OS),
+ minit ("/=", INTRINSIC_NE),
+ minit ("NE", INTRINSIC_NE_OS),
+ minit (">", INTRINSIC_GT),
+ minit ("GT", INTRINSIC_GT_OS),
+ minit (">=", INTRINSIC_GE),
+ minit ("GE", INTRINSIC_GE_OS),
+ minit ("<", INTRINSIC_LT),
+ minit ("LT", INTRINSIC_LT_OS),
+ minit ("<=", INTRINSIC_LE),
+ minit ("LE", INTRINSIC_LE_OS),
minit ("NOT", INTRINSIC_NOT),
minit ("PARENTHESES", INTRINSIC_PARENTHESES),
minit (NULL, -1)
namespace, it has a unique name and we should look in the current
namespace to see if the required, non-contained symbol is available
yet. If so, the latter should be written. */
- if (e->symtree->n.sym && check_unique_name(e->symtree->name))
+ if (e->symtree->n.sym && check_unique_name (e->symtree->name))
ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
e->symtree->n.sym->name);
case INTRINSIC_EQV:
case INTRINSIC_NEQV:
case INTRINSIC_EQ:
+ case INTRINSIC_EQ_OS:
case INTRINSIC_NE:
+ case INTRINSIC_NE_OS:
case INTRINSIC_GT:
+ case INTRINSIC_GT_OS:
case INTRINSIC_GE:
+ case INTRINSIC_GE_OS:
case INTRINSIC_LT:
+ case INTRINSIC_LT_OS:
case INTRINSIC_LE:
+ case INTRINSIC_LE_OS:
mio_expr (&e->value.op.op1);
mio_expr (&e->value.op.op2);
break;
}
-/* Read and write namelists */
+/* Read and write namelists. */
static void
mio_namelist (gfc_symbol *sym)
conditionally? */
if (sym->attr.flavor == FL_NAMELIST)
{
- check_name = find_use_name (sym->name);
+ check_name = find_use_name (sym->name, false);
if (check_name && strcmp (check_name, sym->name) != 0)
gfc_error ("Namelist %s cannot be renamed by USE "
"association to %s", sym->name, check_name);
static void
mio_symbol (gfc_symbol *sym)
{
+ int intmod = INTMOD_NONE;
+
gfc_formal_arglist *formal;
mio_lparen ();
}
}
- /* Save/restore common block links */
+ /* Save/restore common block links. */
mio_symbol_ref (&sym->common_next);
mio_formal_arglist (sym);
= MIO_NAME (gfc_access) (sym->component_access, access_types);
mio_namelist (sym);
+
+ /* Add the fields that say whether this is from an intrinsic module,
+ and if so, what symbol it is within the module. */
+/* mio_integer (&(sym->from_intmod)); */
+ if (iomode == IO_OUTPUT)
+ {
+ intmod = sym->from_intmod;
+ mio_integer (&intmod);
+ }
+ else
+ {
+ mio_integer (&intmod);
+ sym->from_intmod = intmod;
+ }
+
+ mio_integer (&(sym->intmod_sym_id));
+
mio_rparen ();
}
mio_internal_string (module);
/* Decide if we need to load this one or not. */
- p = find_use_name (name);
+ p = find_use_name (name, true);
if (p == NULL)
{
while (parse_atom () != ATOM_RPAREN);
mio_internal_string (name);
mio_internal_string (module);
- n = number_use_names (name);
+ n = number_use_names (name, false);
n = n ? n : 1;
for (i = 1; i <= n; i++)
{
/* Decide if we need to load this one or not. */
- p = find_use_name_n (name, &i);
+ p = find_use_name_n (name, &i, false);
if (p == NULL || gfc_find_symbol (p, NULL, 0, &sym))
{
while (parse_atom () != ATOM_RPAREN);
- continue;
+ continue;
}
if (sym == NULL)
p = p ? p : name;
st = gfc_find_symtree (gfc_current_ns->sym_root, p);
if (!sym->attr.generic
- && sym->module != NULL
- && strcmp(module, sym->module) != 0)
+ && sym->module != NULL
+ && strcmp(module, sym->module) != 0)
st->ambiguous = 1;
}
if (i == 1)
p->threadprivate = 1;
p->use_assoc = 1;
+ /* Get whether this was a bind(c) common or not. */
+ mio_integer (&p->is_bind_c);
+ /* Get the binding label. */
+ mio_internal_string (p->binding_label);
+
mio_rparen ();
}
}
-/* load_equiv()-- Load equivalences. The flag in_load_equiv informs
- mio_expr_ref of this so that unused variables are not loaded and
- so that the expression can be safely freed.*/
+/* Load equivalences. The flag in_load_equiv informs mio_expr_ref of this
+ so that unused variables are not loaded and so that the expression can
+ be safely freed. */
static void
load_equiv (void)
while (end != NULL && end->next != NULL)
end = end->next;
- while (peek_atom() != ATOM_RPAREN) {
+ while (peek_atom () != ATOM_RPAREN) {
mio_lparen ();
head = tail = NULL;
mio_expr (&tail->expr);
}
- /* Unused variables have no symtree. */
- unused = false;
+ /* Unused equivalence members have a unique name. */
+ unused = true;
for (eq = head; eq; eq = eq->eq)
{
- if (!eq->expr->symtree)
+ if (!check_unique_name (eq->expr->symtree->name))
{
- unused = true;
+ unused = false;
break;
}
}
in_load_equiv = false;
}
+
/* Recursive function to traverse the pointer_info tree and load a
needed symbol. We return nonzero if we load a symbol and stop the
traversal, because the act of loading can alter the tree. */
}
-/* Recursive function for cleaning up things after a module has been
- read. */
+/* Recursive function for cleaning up things after a module has been read. */
static void
read_cleanup (pointer_info *p)
{
/* Add hidden symbols to the symtree. */
q = get_integer (p->u.rsym.ns);
- st = get_unique_symtree ((gfc_namespace *) q->u.pointer);
+ st = gfc_get_unique_symtree ((gfc_namespace *) q->u.pointer);
st->n.sym = p->u.rsym.sym;
st->n.sym->refs++;
}
+/* Given a root symtree node and a symbol, try to find a symtree that
+ references the symbol that is not a unique name. */
+
+static gfc_symtree *
+find_symtree_for_symbol (gfc_symtree *st, gfc_symbol *sym)
+{
+ gfc_symtree *s = NULL;
+
+ if (st == NULL)
+ return s;
+
+ s = find_symtree_for_symbol (st->right, sym);
+ if (s != NULL)
+ return s;
+ s = find_symtree_for_symbol (st->left, sym);
+ if (s != NULL)
+ return s;
+
+ if (st->n.sym == sym && !check_unique_name (st->name))
+ return st;
+
+ return s;
+}
+
+
/* Read a module file. */
static void
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_intrinsic_op i;
int ambiguous, j, nuse, symbol;
- pointer_info *info;
+ pointer_info *info, *q;
gfc_use_rename *u;
gfc_symtree *st;
gfc_symbol *sym;
- get_module_locus (&operator_interfaces); /* Skip these for now */
+ get_module_locus (&operator_interfaces); /* Skip these for now. */
skip_list ();
get_module_locus (&user_operators);
mio_internal_string (info->u.rsym.true_name);
mio_internal_string (info->u.rsym.module);
+ mio_internal_string (info->u.rsym.binding_label);
+
require_atom (ATOM_INTEGER);
info->u.rsym.ns = atom_int;
continue;
info->u.rsym.state = USED;
- info->u.rsym.referenced = 1;
info->u.rsym.sym = sym;
+
+ /* Some symbols do not have a namespace (eg. formal arguments),
+ so the automatic "unique symtree" mechanism must be suppressed
+ by marking them as referenced. */
+ q = get_integer (info->u.rsym.ns);
+ if (q->u.pointer == NULL)
+ {
+ info->u.rsym.referenced = 1;
+ continue;
+ }
+
+ /* If possible recycle the symtree that references the symbol.
+ If a symtree is not found and the module does not import one,
+ a unique-name symtree is found by read_cleanup. */
+ st = find_symtree_for_symbol (gfc_current_ns->sym_root, sym);
+ if (st != NULL)
+ {
+ info->u.rsym.symtree = st;
+ info->u.rsym.referenced = 1;
+ }
}
mio_rparen ();
/* See how many use names there are. If none, go through the start
of the loop at least once. */
- nuse = number_use_names (name);
+ nuse = number_use_names (name, false);
if (nuse == 0)
nuse = 1;
for (j = 1; j <= nuse; j++)
{
/* Get the jth local name for this symbol. */
- p = find_use_name_n (name, &j);
+ p = find_use_name_n (name, &j, false);
+
+ if (p == NULL && strcmp (name, module_name) == 0)
+ p = name;
/* Skip symtree nodes not in an ONLY clause, unless there
- is an existing symtree loaded from another USE
- statement. */
+ is an existing symtree loaded from another USE statement. */
if (p == NULL)
{
st = gfc_find_symtree (gfc_current_ns->sym_root, name);
/* Create a symtree node in the current namespace for this
symbol. */
st = check_unique_name (p)
- ? get_unique_symtree (gfc_current_ns)
+ ? gfc_get_unique_symtree (gfc_current_ns)
: gfc_new_symtree (&gfc_current_ns->sym_root, p);
st->ambiguous = ambiguous;
gfc_current_ns);
sym = info->u.rsym.sym;
sym->module = gfc_get_string (info->u.rsym.module);
+
+ /* TODO: hmm, can we test this? Do we know it will be
+ initialized to zeros? */
+ if (info->u.rsym.binding_label[0] != '\0')
+ strcpy (sym->binding_label, info->u.rsym.binding_label);
}
st->n.sym = sym;
if (specific_access == ACCESS_PRIVATE)
return FALSE;
- return default_access != ACCESS_PRIVATE;
+ if (gfc_option.flag_module_private)
+ return default_access == ACCESS_PUBLIC;
+ else
+ return default_access != ACCESS_PRIVATE;
}
-/* Write a common block to the module */
+/* Write a common block to the module. */
static void
write_common (gfc_symtree *st)
gfc_common_head *p;
const char * name;
int flags;
-
+ const char *label;
+
if (st == NULL)
return;
if (p->threadprivate) flags |= 2;
mio_integer (&flags);
+ /* Write out whether the common block is bind(c) or not. */
+ mio_integer (&(p->is_bind_c));
+
+ /* Write out the binding label, or the com name if no label given. */
+ if (p->is_bind_c)
+ {
+ label = p->binding_label;
+ mio_pool_string (&label);
+ }
+ else
+ {
+ label = p->name;
+ mio_pool_string (&label);
+ }
+
mio_rparen ();
}
-/* Write the blank common block to the module */
+
+/* Write the blank common block to the module. */
static void
write_blank_common (void)
{
const char * name = BLANK_COMMON_NAME;
int saved;
+ /* TODO: Blank commons are not bind(c). The F2003 standard probably says
+ this, but it hasn't been checked. Just making it so for now. */
+ int is_bind_c = 0;
if (gfc_current_ns->blank_common.head == NULL)
return;
saved = gfc_current_ns->blank_common.saved;
mio_integer (&saved);
+ /* Write out whether the common block is bind(c) or not. */
+ mio_integer (&is_bind_c);
+
+ /* Write out the binding label, which is BLANK_COMMON_NAME, though
+ it doesn't matter because the label isn't used. */
+ mio_pool_string (&name);
+
mio_rparen ();
}
static void
write_symbol (int n, gfc_symbol *sym)
{
+ const char *label;
if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
mio_pool_string (&sym->name);
mio_pool_string (&sym->module);
+ if (sym->attr.is_bind_c || sym->attr.is_iso_c)
+ {
+ label = sym->binding_label;
+ mio_pool_string (&label);
+ }
+ else
+ mio_pool_string (&sym->name);
+
mio_pointer_ref (&sym->ns);
mio_symbol (sym);
write_symbol (p->integer, sym);
p->u.wsym.state = WRITTEN;
-
- return;
}
static int
write_symbol1 (pointer_info *p)
{
+
if (p == NULL)
return 0;
static void
write_generic (gfc_symbol *sym)
{
+ const char *p;
+ int nuse, j;
+
if (sym->generic == NULL
|| !gfc_check_access (sym->attr.access, sym->ns->default_access))
return;
if (sym->module == NULL)
sym->module = gfc_get_string (module_name);
- mio_symbol_interface (&sym->name, &sym->module, &sym->generic);
+ /* See how many use names there are. If none, use the symbol name. */
+ nuse = number_use_names (sym->name, false);
+ if (nuse == 0)
+ {
+ mio_symbol_interface (&sym->name, &sym->module, &sym->generic);
+ return;
+ }
+
+ for (j = 1; j <= nuse; j++)
+ {
+ /* Get the jth local name for this symbol. */
+ p = find_use_name_n (sym->name, &j, false);
+
+ mio_symbol_interface (&p, &sym->module, &sym->generic);
+ }
}
}
+/* Read a MD5 sum from the header of a module file. If the file cannot
+ be opened, or we have any other error, we return -1. */
+
+static int
+read_md5_from_module_file (const char * filename, unsigned char md5[16])
+{
+ FILE *file;
+ char buf[1024];
+ int n;
+
+ /* Open the file. */
+ if ((file = fopen (filename, "r")) == NULL)
+ return -1;
+
+ /* Read two lines. */
+ if (fgets (buf, sizeof (buf) - 1, file) == NULL
+ || fgets (buf, sizeof (buf) - 1, file) == NULL)
+ {
+ fclose (file);
+ return -1;
+ }
+
+ /* Close the file. */
+ fclose (file);
+
+ /* If the header is not what we expect, or is too short, bail out. */
+ if (strncmp (buf, "MD5:", 4) != 0 || strlen (buf) < 4 + 16)
+ return -1;
+
+ /* Now, we have a real MD5, read it into the array. */
+ for (n = 0; n < 16; n++)
+ {
+ unsigned int x;
+
+ if (sscanf (&(buf[4+2*n]), "%02x", &x) != 1)
+ return -1;
+
+ md5[n] = x;
+ }
+
+ return 0;
+}
+
+
/* Given module, dump it to disk. If there was an error while
processing the module, dump_flag will be set to zero and we delete
the module file, even if it was already there. */
gfc_dump_module (const char *name, int dump_flag)
{
int n;
- char *filename, *p;
+ char *filename, *filename_tmp, *p;
time_t now;
+ fpos_t md5_pos;
+ unsigned char md5_new[16], md5_old[16];
n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
if (gfc_option.module_dir != NULL)
{
- filename = (char *) alloca (n + strlen (gfc_option.module_dir));
+ n += strlen (gfc_option.module_dir);
+ filename = (char *) alloca (n);
strcpy (filename, gfc_option.module_dir);
strcat (filename, name);
}
}
strcat (filename, MODULE_EXTENSION);
+ /* Name of the temporary file used to write the module. */
+ filename_tmp = (char *) alloca (n + 1);
+ strcpy (filename_tmp, filename);
+ strcat (filename_tmp, "0");
+
+ /* There was an error while processing the module. We delete the
+ module file, even if it was already there. */
if (!dump_flag)
{
unlink (filename);
return;
}
- module_fp = fopen (filename, "w");
+ /* Write the module to the temporary file. */
+ module_fp = fopen (filename_tmp, "w");
if (module_fp == NULL)
gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
- filename, strerror (errno));
+ filename_tmp, strerror (errno));
+ /* Write the header, including space reserved for the MD5 sum. */
now = time (NULL);
p = ctime (&now);
*strchr (p, '\n') = '\0';
- fprintf (module_fp, "GFORTRAN module created from %s on %s\n",
+ fprintf (module_fp, "GFORTRAN module created from %s on %s\nMD5:",
gfc_source_file, p);
- fputs ("If you edit this, you'll get what you deserve.\n\n", module_fp);
+ fgetpos (module_fp, &md5_pos);
+ fputs ("00000000000000000000000000000000 -- "
+ "If you edit this, you'll get what you deserve.\n\n", module_fp);
+
+ /* Initialize the MD5 context that will be used for output. */
+ md5_init_ctx (&ctx);
+ /* Write the module itself. */
iomode = IO_OUTPUT;
strcpy (module_name, name);
write_char ('\n');
+ /* Write the MD5 sum to the header of the module file. */
+ md5_finish_ctx (&ctx, md5_new);
+ fsetpos (module_fp, &md5_pos);
+ for (n = 0; n < 16; n++)
+ fprintf (module_fp, "%02x", md5_new[n]);
+
if (fclose (module_fp))
gfc_fatal_error ("Error writing module file '%s' for writing: %s",
- filename, strerror (errno));
+ filename_tmp, strerror (errno));
+
+ /* Read the MD5 from the header of the old module file and compare. */
+ if (read_md5_from_module_file (filename, md5_old) != 0
+ || memcmp (md5_old, md5_new, sizeof (md5_old)) != 0)
+ {
+ /* Module file have changed, replace the old one. */
+ unlink (filename);
+ rename (filename_tmp, filename);
+ }
+ else
+ unlink (filename_tmp);
+}
+
+
+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
+ list was provided. */
+
+static void
+import_iso_c_binding_module (void)
+{
+ gfc_symbol *mod_sym = NULL;
+ gfc_symtree *mod_symtree = NULL;
+ 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);
+
+ if (mod_symtree == NULL)
+ {
+ /* symtree doesn't already exist in current namespace. */
+ gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree);
+
+ if (mod_symtree != NULL)
+ mod_sym = mod_symtree->n.sym;
+ else
+ gfc_internal_error ("import_iso_c_binding_module(): Unable to "
+ "create symbol for %s", iso_c_module_name);
+
+ mod_sym->attr.flavor = FL_MODULE;
+ mod_sym->attr.intrinsic = 1;
+ mod_sym->module = gfc_get_string (iso_c_module_name);
+ mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
+ }
+
+ /* Generate the symbols for the named constants representing
+ the kinds for intrinsic data types. */
+ if (only_flag)
+ {
+ /* Sort the rename list because there are dependencies between types
+ and procedures (e.g., c_loc needs c_ptr). */
+ sort_iso_c_rename_list ();
+
+ for (u = gfc_rename_list; u; u = u->next)
+ {
+ i = get_c_kind (u->use_name, c_interop_kinds_table);
+
+ 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, 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, i, local_name);
+ }
+
+ 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);
+ }
+ }
}
/* Add an integer named constant from a given module. */
+
static void
-create_int_parameter (const char *name, int value, const char *modname)
+create_int_parameter (const char *name, int value, const char *modname,
+ intmod_id module, int id)
{
gfc_symtree *tmp_symtree;
gfc_symbol *sym;
sym->ts.kind = gfc_default_integer_kind;
sym->value = gfc_int_expr (value);
sym->attr.use_assoc = 1;
+ sym->from_intmod = module;
+ sym->intmod_sym_id = id;
}
gfc_symtree *mod_symtree;
int i;
- mstring symbol[] = {
-#define NAMED_INTCST(a,b,c) minit(b,0),
+ intmod_sym symbol[] = {
+#define NAMED_INTCST(a,b,c) { a, b, 0 },
#include "iso-fortran-env.def"
#undef NAMED_INTCST
- minit (NULL, -1234) };
+ { ISOFORTRANENV_INVALID, NULL, -1234 } };
i = 0;
-#define NAMED_INTCST(a,b,c) symbol[i++].tag = c;
+#define NAMED_INTCST(a,b,c) symbol[i++].value = c;
#include "iso-fortran-env.def"
#undef NAMED_INTCST
mod_sym->attr.flavor = FL_MODULE;
mod_sym->attr.intrinsic = 1;
mod_sym->module = gfc_get_string (mod);
+ mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
}
else
if (!mod_symtree->n.sym->attr.intrinsic)
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)
+ for (i = 0; symbol[i].name; i++)
+ if (strcmp (symbol[i].name, u->use_name) == 0)
break;
- if (symbol[i].string == NULL)
+ if (symbol[i].name == NULL)
{
gfc_error ("Symbol '%s' referenced at %L does not exist in "
"intrinsic module ISO_FORTRAN_ENV", u->use_name,
}
if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
- && strcmp (symbol[i].string, "numeric_storage_size") == 0)
+ && 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,
? "-fdefault-integer-8" : "-fdefault-real-8");
create_int_parameter (u->local_name[0] ? u->local_name
- : symbol[i].string,
- symbol[i].tag, mod);
+ : symbol[i].name,
+ symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
+ symbol[i].id);
}
else
{
- for (i = 0; symbol[i].string; i++)
+ for (i = 0; symbol[i].name; i++)
{
local_name = NULL;
for (u = gfc_rename_list; u; u = u->next)
{
- if (strcmp (symbol[i].string, u->use_name) == 0)
+ if (strcmp (symbol[i].name, u->use_name) == 0)
{
local_name = u->local_name;
u->found = 1;
}
if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
- && strcmp (symbol[i].string, "numeric_storage_size") == 0)
+ && 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 (local_name ? local_name : symbol[i].string,
- symbol[i].tag, mod);
+ create_int_parameter (local_name ? local_name : symbol[i].name,
+ symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
+ symbol[i].id);
}
for (u = gfc_rename_list; u; u = u->next)
return;
}
+ if (strcmp (module_name, "iso_c_binding") == 0
+ && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
+ "ISO_C_BINDING module at %C") != FAILURE)
+ {
+ import_iso_c_binding_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);
+ gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
+ module_name);
}
if (module_fp == NULL)
OSDN Git Service
