diff options
Diffstat (limited to 'gcc/fortran/module.cc')
| -rw-r--r-- | gcc/fortran/module.cc | 7581 |
1 files changed, 7581 insertions, 0 deletions
diff --git a/gcc/fortran/module.cc b/gcc/fortran/module.cc new file mode 100644 index 0000000..352e613 --- /dev/null +++ b/gcc/fortran/module.cc @@ -0,0 +1,7581 @@ +/* Handle modules, which amounts to loading and saving symbols and + their attendant structures. + Copyright (C) 2000-2022 Free Software Foundation, Inc. + Contributed by Andy Vaught + +This file is part of GCC. + +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 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +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, i.e. a + sequence of atoms, which can be left or right parenthesis, names, + integers or strings. Parenthesis are always matched which allows + us to skip over sections at high speed without having to know + anything about the internal structure of the lists. A "name" is + usually a fortran 95 identifier, but can also start with '@' in + order to reference a hidden symbol. + + The first line of a module is an informational message about what + created the module, the file it came from and when it was created. + The second line is a warning for people not to edit the module. + The rest of the module looks like: + + ( ( <Interface info for UPLUS> ) + ( <Interface info for UMINUS> ) + ... + ) + ( ( <name of operator interface> <module of op interface> <i/f1> ... ) + ... + ) + ( ( <name of generic interface> <module of generic interface> <i/f1> ... ) + ... + ) + ( ( <common name> <symbol> <saved flag>) + ... + ) + + ( equivalence list ) + + ( <Symbol Number (in no particular order)> + <True name of symbol> + <Module name of symbol> + ( <symbol information> ) + ... + ) + ( <Symtree name> + <Ambiguous flag> + <Symbol number> + ... + ) + + In general, symbols refer to other symbols by their symbol number, + which are zero based. Symbols are written to the module in no + particular order. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "options.h" +#include "tree.h" +#include "gfortran.h" +#include "stringpool.h" +#include "arith.h" +#include "match.h" +#include "parse.h" /* FIXME */ +#include "constructor.h" +#include "cpp.h" +#include "scanner.h" +#include <zlib.h> + +#define MODULE_EXTENSION ".mod" +#define SUBMODULE_EXTENSION ".smod" + +/* Don't put any single quote (') in MOD_VERSION, if you want it to be + recognized. */ +#define MOD_VERSION "15" + + +/* Structure that describes a position within a module file. */ + +typedef struct +{ + int column, line; + long pos; +} +module_locus; + +/* Structure for list of symbols of intrinsic modules. */ +typedef struct +{ + int id; + const char *name; + int value; + int standard; +} +intmod_sym; + + +typedef enum +{ + P_UNKNOWN = 0, P_OTHER, P_NAMESPACE, P_COMPONENT, P_SYMBOL +} +pointer_t; + +/* The fixup structure lists pointers to pointers that have to + be updated when a pointer value becomes known. */ + +typedef struct fixup_t +{ + void **pointer; + struct fixup_t *next; +} +fixup_t; + + +/* Structure for holding extra info needed for pointers being read. */ + +enum gfc_rsym_state +{ + UNUSED, + NEEDED, + USED +}; + +enum gfc_wsym_state +{ + UNREFERENCED = 0, + NEEDS_WRITE, + WRITTEN +}; + +typedef struct pointer_info +{ + BBT_HEADER (pointer_info); + HOST_WIDE_INT integer; + pointer_t type; + + /* The first component of each member of the union is the pointer + being stored. */ + + fixup_t *fixup; + + union + { + void *pointer; /* Member for doing pointer searches. */ + + struct + { + gfc_symbol *sym; + char *true_name, *module, *binding_label; + fixup_t *stfixup; + gfc_symtree *symtree; + enum gfc_rsym_state state; + int ns, referenced, renamed; + module_locus where; + } + rsym; + + struct + { + gfc_symbol *sym; + enum gfc_wsym_state state; + } + wsym; + } + u; + +} +pointer_info; + +#define gfc_get_pointer_info() XCNEW (pointer_info) + + +/* Local variables */ + +/* The gzFile for the module we're reading or writing. */ +static gzFile module_fp; + +/* Fully qualified module path */ +static char *module_fullpath = NULL; + +/* The name of the module we're reading (USE'ing) or writing. */ +static const char *module_name; +/* The name of the .smod file that the submodule will write to. */ +static const char *submodule_name; + +static gfc_use_list *module_list; + +/* If we're reading an intrinsic module, this is its ID. */ +static intmod_id current_intmod; + +/* Content of module. */ +static char* module_content; + +static long module_pos; +static int module_line, module_column, only_flag; +static int prev_module_line, prev_module_column; + +static enum +{ IO_INPUT, IO_OUTPUT } +iomode; + +static gfc_use_rename *gfc_rename_list; +static pointer_info *pi_root; +static int symbol_number; /* Counter for assigning symbol numbers */ + +/* Tells mio_expr_ref to make symbols for unused equivalence members. */ +static bool in_load_equiv; + + + +/*****************************************************************/ + +/* Pointer/integer conversion. Pointers between structures are stored + as integers in the module file. The next couple of subroutines + handle this translation for reading and writing. */ + +/* Recursively free the tree of pointer structures. */ + +static void +free_pi_tree (pointer_info *p) +{ + if (p == NULL) + return; + + if (p->fixup != NULL) + gfc_internal_error ("free_pi_tree(): Unresolved fixup"); + + free_pi_tree (p->left); + free_pi_tree (p->right); + + if (iomode == IO_INPUT) + { + XDELETEVEC (p->u.rsym.true_name); + XDELETEVEC (p->u.rsym.module); + XDELETEVEC (p->u.rsym.binding_label); + } + + free (p); +} + + +/* Compare pointers when searching by pointer. Used when writing a + module. */ + +static int +compare_pointers (void *_sn1, void *_sn2) +{ + pointer_info *sn1, *sn2; + + sn1 = (pointer_info *) _sn1; + sn2 = (pointer_info *) _sn2; + + if (sn1->u.pointer < sn2->u.pointer) + return -1; + if (sn1->u.pointer > sn2->u.pointer) + return 1; + + return 0; +} + + +/* Compare integers when searching by integer. Used when reading a + module. */ + +static int +compare_integers (void *_sn1, void *_sn2) +{ + pointer_info *sn1, *sn2; + + sn1 = (pointer_info *) _sn1; + sn2 = (pointer_info *) _sn2; + + if (sn1->integer < sn2->integer) + return -1; + if (sn1->integer > sn2->integer) + return 1; + + return 0; +} + + +/* Initialize the pointer_info tree. */ + +static void +init_pi_tree (void) +{ + compare_fn compare; + pointer_info *p; + + pi_root = NULL; + compare = (iomode == IO_INPUT) ? compare_integers : compare_pointers; + + /* Pointer 0 is the NULL pointer. */ + p = gfc_get_pointer_info (); + p->u.pointer = NULL; + p->integer = 0; + p->type = P_OTHER; + + gfc_insert_bbt (&pi_root, p, compare); + + /* Pointer 1 is the current namespace. */ + p = gfc_get_pointer_info (); + p->u.pointer = gfc_current_ns; + p->integer = 1; + p->type = P_NAMESPACE; + + gfc_insert_bbt (&pi_root, p, compare); + + symbol_number = 2; +} + + +/* During module writing, call here with a pointer to something, + returning the pointer_info node. */ + +static pointer_info * +find_pointer (void *gp) +{ + pointer_info *p; + + p = pi_root; + while (p != NULL) + { + if (p->u.pointer == gp) + break; + p = (gp < p->u.pointer) ? p->left : p->right; + } + + return p; +} + + +/* Given a pointer while writing, returns the pointer_info tree node, + creating it if it doesn't exist. */ + +static pointer_info * +get_pointer (void *gp) +{ + pointer_info *p; + + p = find_pointer (gp); + if (p != NULL) + return p; + + /* Pointer doesn't have an integer. Give it one. */ + p = gfc_get_pointer_info (); + + p->u.pointer = gp; + p->integer = symbol_number++; + + gfc_insert_bbt (&pi_root, p, compare_pointers); + + return p; +} + + +/* Given an integer during reading, find it in the pointer_info tree, + creating the node if not found. */ + +static pointer_info * +get_integer (HOST_WIDE_INT integer) +{ + pointer_info *p, t; + int c; + + t.integer = integer; + + p = pi_root; + while (p != NULL) + { + c = compare_integers (&t, p); + if (c == 0) + break; + + p = (c < 0) ? p->left : p->right; + } + + if (p != NULL) + return p; + + p = gfc_get_pointer_info (); + p->integer = integer; + p->u.pointer = NULL; + + gfc_insert_bbt (&pi_root, p, compare_integers); + + return p; +} + + +/* Resolve any fixups using a known pointer. */ + +static void +resolve_fixups (fixup_t *f, void *gp) +{ + fixup_t *next; + + for (; f; f = next) + { + next = f->next; + *(f->pointer) = gp; + free (f); + } +} + + +/* Convert a string such that it starts with a lower-case character. Used + to convert the symtree name of a derived-type to the symbol name or to + the name of the associated generic function. */ + +const char * +gfc_dt_lower_string (const char *name) +{ + if (name[0] != (char) TOLOWER ((unsigned char) name[0])) + return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name[0]), + &name[1]); + return gfc_get_string ("%s", name); +} + + +/* Convert a string such that it starts with an upper-case character. Used to + return the symtree-name for a derived type; the symbol name itself and the + symtree/symbol name of the associated generic function start with a lower- + case character. */ + +const char * +gfc_dt_upper_string (const char *name) +{ + if (name[0] != (char) TOUPPER ((unsigned char) name[0])) + return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name[0]), + &name[1]); + return gfc_get_string ("%s", name); +} + +/* Call here during module reading when we know what pointer to + associate with an integer. Any fixups that exist are resolved at + this time. */ + +static void +associate_integer_pointer (pointer_info *p, void *gp) +{ + if (p->u.pointer != NULL) + gfc_internal_error ("associate_integer_pointer(): Already associated"); + + p->u.pointer = gp; + + resolve_fixups (p->fixup, gp); + + p->fixup = NULL; +} + + +/* During module reading, given an integer and a pointer to a pointer, + either store the pointer from an already-known value or create a + fixup structure in order to store things later. Returns zero if + the reference has been actually stored, or nonzero if the reference + must be fixed later (i.e., associate_integer_pointer must be called + sometime later. Returns the pointer_info structure. */ + +static pointer_info * +add_fixup (HOST_WIDE_INT integer, void *gp) +{ + pointer_info *p; + fixup_t *f; + char **cp; + + p = get_integer (integer); + + if (p->integer == 0 || p->u.pointer != NULL) + { + cp = (char **) gp; + *cp = (char *) p->u.pointer; + } + else + { + f = XCNEW (fixup_t); + + f->next = p->fixup; + p->fixup = f; + + f->pointer = (void **) gp; + } + + return p; +} + + +/*****************************************************************/ + +/* Parser related subroutines */ + +/* Free the rename list left behind by a USE statement. */ + +static void +free_rename (gfc_use_rename *list) +{ + gfc_use_rename *next; + + for (; list; list = next) + { + next = list->next; + free (list); + } +} + + +/* Match a USE statement. */ + +match +gfc_match_use (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1], module_nature[GFC_MAX_SYMBOL_LEN + 1]; + gfc_use_rename *tail = NULL, *new_use; + interface_type type, type2; + gfc_intrinsic_op op; + match m; + gfc_use_list *use_list; + gfc_symtree *st; + locus loc; + + use_list = gfc_get_use_list (); + + if (gfc_match (" , ") == MATCH_YES) + { + if ((m = gfc_match (" %n ::", module_nature)) == MATCH_YES) + { + if (!gfc_notify_std (GFC_STD_F2003, "module " + "nature in USE statement at %C")) + goto cleanup; + + if (strcmp (module_nature, "intrinsic") == 0) + use_list->intrinsic = true; + else + { + if (strcmp (module_nature, "non_intrinsic") == 0) + use_list->non_intrinsic = true; + else + { + gfc_error ("Module nature in USE statement at %C shall " + "be either INTRINSIC or NON_INTRINSIC"); + goto cleanup; + } + } + } + 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"); + free (use_list); + return m; + } + } + else + { + m = gfc_match (" ::"); + if (m == MATCH_YES && + !gfc_notify_std(GFC_STD_F2003, "\"USE :: module\" at %C")) + goto cleanup; + + if (m != MATCH_YES) + { + m = gfc_match ("% "); + if (m != MATCH_YES) + { + free (use_list); + return m; + } + } + } + + use_list->where = gfc_current_locus; + + m = gfc_match_name (name); + if (m != MATCH_YES) + { + free (use_list); + return m; + } + + use_list->module_name = gfc_get_string ("%s", name); + + if (gfc_match_eos () == MATCH_YES) + goto done; + + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + + if (gfc_match (" only :") == MATCH_YES) + use_list->only_flag = true; + + if (gfc_match_eos () == MATCH_YES) + goto done; + + for (;;) + { + /* Get a new rename struct and add it to the rename list. */ + new_use = gfc_get_use_rename (); + new_use->where = gfc_current_locus; + new_use->found = 0; + + if (use_list->rename == NULL) + use_list->rename = new_use; + else + tail->next = new_use; + tail = new_use; + + /* See what kind of interface we're dealing with. Assume it is + not an operator. */ + new_use->op = INTRINSIC_NONE; + if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR) + goto cleanup; + + switch (type) + { + case INTERFACE_NAMELESS: + gfc_error ("Missing generic specification in USE statement at %C"); + goto cleanup; + + case INTERFACE_USER_OP: + case INTERFACE_GENERIC: + case INTERFACE_DTIO: + loc = gfc_current_locus; + + m = gfc_match (" =>"); + + if (type == INTERFACE_USER_OP && m == MATCH_YES + && (!gfc_notify_std(GFC_STD_F2003, "Renaming " + "operators in USE statements at %C"))) + goto cleanup; + + if (type == INTERFACE_USER_OP) + new_use->op = INTRINSIC_USER; + + if (use_list->only_flag) + { + if (m != MATCH_YES) + strcpy (new_use->use_name, name); + else + { + strcpy (new_use->local_name, name); + m = gfc_match_generic_spec (&type2, new_use->use_name, &op); + if (type != type2) + goto syntax; + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + } + } + else + { + if (m != MATCH_YES) + goto syntax; + strcpy (new_use->local_name, name); + + m = gfc_match_generic_spec (&type2, new_use->use_name, &op); + if (type != type2) + goto syntax; + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + } + + st = gfc_find_symtree (gfc_current_ns->sym_root, name); + if (st && type != INTERFACE_USER_OP + && (st->n.sym->module != use_list->module_name + || strcmp (st->n.sym->name, new_use->use_name) != 0)) + { + if (m == MATCH_YES) + gfc_error ("Symbol %qs at %L conflicts with the rename symbol " + "at %L", name, &st->n.sym->declared_at, &loc); + else + gfc_error ("Symbol %qs at %L conflicts with the symbol " + "at %L", name, &st->n.sym->declared_at, &loc); + goto cleanup; + } + + if (strcmp (new_use->use_name, use_list->module_name) == 0 + || strcmp (new_use->local_name, use_list->module_name) == 0) + { + gfc_error ("The name %qs at %C has already been used as " + "an external module name", use_list->module_name); + goto cleanup; + } + break; + + case INTERFACE_INTRINSIC_OP: + new_use->op = op; + break; + + default: + gcc_unreachable (); + } + + if (gfc_match_eos () == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + 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; + +syntax: + gfc_syntax_error (ST_USE); + +cleanup: + free_rename (use_list->rename); + free (use_list); + return MATCH_ERROR; +} + + +/* Match a SUBMODULE statement. + + According to F2008:11.2.3.2, "The submodule identifier is the + ordered pair whose first element is the ancestor module name and + whose second element is the submodule name. 'Submodule_name' is + used for the submodule filename and uses '@' as a separator, whilst + the name of the symbol for the module uses '.' as a separator. + The reasons for these choices are: + (i) To follow another leading brand in the submodule filenames; + (ii) Since '.' is not particularly visible in the filenames; and + (iii) The linker does not permit '@' in mnemonics. */ + +match +gfc_match_submodule (void) +{ + match m; + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_use_list *use_list; + bool seen_colon = false; + + if (!gfc_notify_std (GFC_STD_F2008, "SUBMODULE declaration at %C")) + return MATCH_ERROR; + + if (gfc_current_state () != COMP_NONE) + { + gfc_error ("SUBMODULE declaration at %C cannot appear within " + "another scoping unit"); + return MATCH_ERROR; + } + + gfc_new_block = NULL; + gcc_assert (module_list == NULL); + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + while (1) + { + m = gfc_match (" %n", name); + if (m != MATCH_YES) + goto syntax; + + use_list = gfc_get_use_list (); + use_list->where = gfc_current_locus; + + if (module_list) + { + gfc_use_list *last = module_list; + while (last->next) + last = last->next; + last->next = use_list; + use_list->module_name + = gfc_get_string ("%s.%s", module_list->module_name, name); + use_list->submodule_name + = gfc_get_string ("%s@%s", module_list->module_name, name); + } + else + { + module_list = use_list; + use_list->module_name = gfc_get_string ("%s", name); + use_list->submodule_name = use_list->module_name; + } + + if (gfc_match_char (')') == MATCH_YES) + break; + + if (gfc_match_char (':') != MATCH_YES + || seen_colon) + goto syntax; + + seen_colon = true; + } + + m = gfc_match (" %s%t", &gfc_new_block); + if (m != MATCH_YES) + goto syntax; + + submodule_name = gfc_get_string ("%s@%s", module_list->module_name, + gfc_new_block->name); + + gfc_new_block->name = gfc_get_string ("%s.%s", + module_list->module_name, + gfc_new_block->name); + + if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE, + gfc_new_block->name, NULL)) + return MATCH_ERROR; + + /* Just retain the ultimate .(s)mod file for reading, since it + contains all the information in its ancestors. */ + use_list = module_list; + for (; module_list->next; use_list = module_list) + { + module_list = use_list->next; + free (use_list); + } + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in SUBMODULE statement at %C"); + return MATCH_ERROR; +} + + +/* 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. 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, bool interface) +{ + gfc_use_rename *u; + const char *low_name = NULL; + int i; + + /* For derived types. */ + if (name[0] != (char) TOLOWER ((unsigned char) name[0])) + low_name = gfc_dt_lower_string (name); + + i = 0; + for (u = gfc_rename_list; u; u = u->next) + { + if ((!low_name && strcmp (u->use_name, name) != 0) + || (low_name && strcmp (u->use_name, low_name) != 0) + || (u->op == INTRINSIC_USER && !interface) + || (u->op != INTRINSIC_USER && interface)) + continue; + if (++i == *inst) + break; + } + + if (!*inst) + { + *inst = i; + return NULL; + } + + if (u == NULL) + return only_flag ? NULL : name; + + u->found = 1; + + if (low_name) + { + if (u->local_name[0] == '\0') + return name; + return gfc_dt_upper_string (u->local_name); + } + + return (u->local_name[0] != '\0') ? u->local_name : name; +} + + +/* Given a name, return the name under which to load this symbol. + Returns NULL if this symbol shouldn't be loaded. */ + +static const char * +find_use_name (const char *name, bool interface) +{ + int i = 1; + 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, bool interface) +{ + int i = 0; + find_use_name_n (name, &i, interface); + return i; +} + + +/* Try to find the operator in the current list. */ + +static gfc_use_rename * +find_use_operator (gfc_intrinsic_op op) +{ + gfc_use_rename *u; + + for (u = gfc_rename_list; u; u = u->next) + if (u->op == op) + return u; + + return NULL; +} + + +/*****************************************************************/ + +/* The next couple of subroutines maintain a tree used to avoid a + brute-force search for a combination of true name and module name. + While symtree names, the name that a particular symbol is known by + can changed with USE statements, we still have to keep track of the + true names to generate the correct reference, and also avoid + loading the same real symbol twice in a program unit. + + When we start reading, the true name tree is built and maintained + as symbols are read. The tree is searched as we load new symbols + to see if it already exists someplace in the namespace. */ + +typedef struct true_name +{ + BBT_HEADER (true_name); + const char *name; + gfc_symbol *sym; +} +true_name; + +static true_name *true_name_root; + + +/* Compare two true_name structures. */ + +static int +compare_true_names (void *_t1, void *_t2) +{ + true_name *t1, *t2; + int c; + + t1 = (true_name *) _t1; + t2 = (true_name *) _t2; + + c = ((t1->sym->module > t2->sym->module) + - (t1->sym->module < t2->sym->module)); + if (c != 0) + return c; + + return strcmp (t1->name, t2->name); +} + + +/* Given a true name, search the true name tree to see if it exists + within the main namespace. */ + +static gfc_symbol * +find_true_name (const char *name, const char *module) +{ + true_name t, *p; + gfc_symbol sym; + int c; + + t.name = gfc_get_string ("%s", name); + if (module != NULL) + sym.module = gfc_get_string ("%s", module); + else + sym.module = NULL; + t.sym = &sym; + + p = true_name_root; + while (p != NULL) + { + c = compare_true_names ((void *) (&t), (void *) p); + if (c == 0) + return p->sym; + + p = (c < 0) ? p->left : p->right; + } + + return NULL; +} + + +/* Given a gfc_symbol pointer that is not in the true name tree, add it. */ + +static void +add_true_name (gfc_symbol *sym) +{ + true_name *t; + + t = XCNEW (true_name); + t->sym = sym; + if (gfc_fl_struct (sym->attr.flavor)) + t->name = gfc_dt_upper_string (sym->name); + else + t->name = sym->name; + + gfc_insert_bbt (&true_name_root, t, compare_true_names); +} + + +/* Recursive function to build the initial true name tree by + recursively traversing the current namespace. */ + +static void +build_tnt (gfc_symtree *st) +{ + const char *name; + if (st == NULL) + return; + + build_tnt (st->left); + build_tnt (st->right); + + if (gfc_fl_struct (st->n.sym->attr.flavor)) + name = gfc_dt_upper_string (st->n.sym->name); + else + name = st->n.sym->name; + + if (find_true_name (name, st->n.sym->module) != NULL) + return; + + add_true_name (st->n.sym); +} + + +/* Initialize the true name tree with the current namespace. */ + +static void +init_true_name_tree (void) +{ + true_name_root = NULL; + build_tnt (gfc_current_ns->sym_root); +} + + +/* Recursively free a true name tree node. */ + +static void +free_true_name (true_name *t) +{ + if (t == NULL) + return; + free_true_name (t->left); + free_true_name (t->right); + + free (t); +} + + +/*****************************************************************/ + +/* Module reading and writing. */ + +/* The following are versions similar to the ones in scanner.c, but + for dealing with compressed module files. */ + +static gzFile +gzopen_included_file_1 (const char *name, gfc_directorylist *list, + bool module, bool system) +{ + char *fullname; + gfc_directorylist *p; + gzFile f; + + for (p = list; p; p = p->next) + { + if (module && !p->use_for_modules) + continue; + + fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1); + strcpy (fullname, p->path); + strcat (fullname, name); + + f = gzopen (fullname, "r"); + if (f != NULL) + { + if (gfc_cpp_makedep ()) + gfc_cpp_add_dep (fullname, system); + + free (module_fullpath); + module_fullpath = xstrdup (fullname); + return f; + } + } + + return NULL; +} + +static gzFile +gzopen_included_file (const char *name, bool include_cwd, bool module) +{ + gzFile f = NULL; + + if (IS_ABSOLUTE_PATH (name) || include_cwd) + { + f = gzopen (name, "r"); + if (f) + { + if (gfc_cpp_makedep ()) + gfc_cpp_add_dep (name, false); + + free (module_fullpath); + module_fullpath = xstrdup (name); + } + } + + if (!f) + f = gzopen_included_file_1 (name, include_dirs, module, false); + + return f; +} + +static gzFile +gzopen_intrinsic_module (const char* name) +{ + gzFile f = NULL; + + if (IS_ABSOLUTE_PATH (name)) + { + f = gzopen (name, "r"); + if (f) + { + if (gfc_cpp_makedep ()) + gfc_cpp_add_dep (name, true); + + free (module_fullpath); + module_fullpath = xstrdup (name); + } + } + + if (!f) + f = gzopen_included_file_1 (name, intrinsic_modules_dirs, true, true); + + return f; +} + + +enum atom_type +{ + ATOM_NAME, ATOM_LPAREN, ATOM_RPAREN, ATOM_INTEGER, ATOM_STRING +}; + +static atom_type last_atom; + + +/* The name buffer must be at least as long as a symbol name. Right + now it's not clear how we're going to store numeric constants-- + probably as a hexadecimal string, since this will allow the exact + number to be preserved (this can't be done by a decimal + representation). Worry about that later. TODO! */ + +#define MAX_ATOM_SIZE 100 + +static HOST_WIDE_INT atom_int; +static char *atom_string, atom_name[MAX_ATOM_SIZE]; + + +/* Report problems with a module. Error reporting is not very + elaborate, since this sorts of errors shouldn't really happen. + This subroutine never returns. */ + +static void bad_module (const char *) ATTRIBUTE_NORETURN; + +static void +bad_module (const char *msgid) +{ + XDELETEVEC (module_content); + module_content = NULL; + + switch (iomode) + { + case IO_INPUT: + gfc_fatal_error ("Reading module %qs at line %d column %d: %s", + module_fullpath, module_line, module_column, msgid); + break; + case IO_OUTPUT: + gfc_fatal_error ("Writing module %qs at line %d column %d: %s", + module_name, module_line, module_column, msgid); + break; + default: + gfc_fatal_error ("Module %qs at line %d column %d: %s", + module_name, module_line, module_column, msgid); + break; + } +} + + +/* Set the module's input pointer. */ + +static void +set_module_locus (module_locus *m) +{ + module_column = m->column; + module_line = m->line; + module_pos = m->pos; +} + + +/* Get the module's input pointer so that we can restore it later. */ + +static void +get_module_locus (module_locus *m) +{ + m->column = module_column; + m->line = module_line; + m->pos = module_pos; +} + +/* Peek at the next character in the module. */ + +static int +module_peek_char (void) +{ + return module_content[module_pos]; +} + +/* Get the next character in the module, updating our reckoning of + where we are. */ + +static int +module_char (void) +{ + const char c = module_content[module_pos++]; + if (c == '\0') + bad_module ("Unexpected EOF"); + + prev_module_line = module_line; + prev_module_column = module_column; + + if (c == '\n') + { + module_line++; + module_column = 0; + } + + module_column++; + return c; +} + +/* Unget a character while remembering the line and column. Works for + a single character only. */ + +static void +module_unget_char (void) +{ + module_line = prev_module_line; + module_column = prev_module_column; + module_pos--; +} + +/* Parse a string constant. The delimiter is guaranteed to be a + single quote. */ + +static void +parse_string (void) +{ + int c; + size_t cursz = 30; + size_t len = 0; + + atom_string = XNEWVEC (char, cursz); + + for ( ; ; ) + { + c = module_char (); + + if (c == '\'') + { + int c2 = module_char (); + if (c2 != '\'') + { + module_unget_char (); + break; + } + } + + if (len >= cursz) + { + cursz *= 2; + atom_string = XRESIZEVEC (char, atom_string, cursz); + } + atom_string[len] = c; + len++; + } + + atom_string = XRESIZEVEC (char, atom_string, len + 1); + atom_string[len] = '\0'; /* C-style string for debug purposes. */ +} + + +/* Parse an integer. Should fit in a HOST_WIDE_INT. */ + +static void +parse_integer (int c) +{ + int sign = 1; + + atom_int = 0; + switch (c) + { + case ('-'): + sign = -1; + case ('+'): + break; + default: + atom_int = c - '0'; + break; + } + + for (;;) + { + c = module_char (); + if (!ISDIGIT (c)) + { + module_unget_char (); + break; + } + + atom_int = 10 * atom_int + c - '0'; + } + + atom_int *= sign; +} + + +/* Parse a name. */ + +static void +parse_name (int c) +{ + char *p; + int len; + + p = atom_name; + + *p++ = c; + len = 1; + + for (;;) + { + c = module_char (); + if (!ISALNUM (c) && c != '_' && c != '-') + { + module_unget_char (); + break; + } + + *p++ = c; + if (++len > GFC_MAX_SYMBOL_LEN) + bad_module ("Name too long"); + } + + *p = '\0'; + +} + + +/* Read the next atom in the module's input stream. */ + +static atom_type +parse_atom (void) +{ + int c; + + do + { + c = module_char (); + } + while (c == ' ' || c == '\r' || c == '\n'); + + switch (c) + { + case '(': + return ATOM_LPAREN; + + case ')': + return ATOM_RPAREN; + + case '\'': + parse_string (); + return ATOM_STRING; + + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + parse_integer (c); + return ATOM_INTEGER; + + case '+': + case '-': + if (ISDIGIT (module_peek_char ())) + { + parse_integer (c); + return ATOM_INTEGER; + } + else + bad_module ("Bad name"); + + case 'a': + case 'b': + case 'c': + case 'd': + case 'e': + case 'f': + case 'g': + case 'h': + case 'i': + case 'j': + case 'k': + case 'l': + case 'm': + case 'n': + case 'o': + case 'p': + case 'q': + case 'r': + case 's': + case 't': + case 'u': + case 'v': + case 'w': + case 'x': + case 'y': + case 'z': + case 'A': + case 'B': + case 'C': + case 'D': + case 'E': + case 'F': + case 'G': + case 'H': + case 'I': + case 'J': + case 'K': + case 'L': + case 'M': + case 'N': + case 'O': + case 'P': + case 'Q': + case 'R': + case 'S': + case 'T': + case 'U': + case 'V': + case 'W': + case 'X': + case 'Y': + case 'Z': + parse_name (c); + return ATOM_NAME; + + default: + bad_module ("Bad name"); + } + + /* Not reached. */ +} + + +/* Peek at the next atom on the input. */ + +static atom_type +peek_atom (void) +{ + int c; + + do + { + c = module_char (); + } + while (c == ' ' || c == '\r' || c == '\n'); + + switch (c) + { + case '(': + module_unget_char (); + return ATOM_LPAREN; + + case ')': + module_unget_char (); + return ATOM_RPAREN; + + case '\'': + module_unget_char (); + return ATOM_STRING; + + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + module_unget_char (); + return ATOM_INTEGER; + + case '+': + case '-': + if (ISDIGIT (module_peek_char ())) + { + module_unget_char (); + return ATOM_INTEGER; + } + else + bad_module ("Bad name"); + + case 'a': + case 'b': + case 'c': + case 'd': + case 'e': + case 'f': + case 'g': + case 'h': + case 'i': + case 'j': + case 'k': + case 'l': + case 'm': + case 'n': + case 'o': + case 'p': + case 'q': + case 'r': + case 's': + case 't': + case 'u': + case 'v': + case 'w': + case 'x': + case 'y': + case 'z': + case 'A': + case 'B': + case 'C': + case 'D': + case 'E': + case 'F': + case 'G': + case 'H': + case 'I': + case 'J': + case 'K': + case 'L': + case 'M': + case 'N': + case 'O': + case 'P': + case 'Q': + case 'R': + case 'S': + case 'T': + case 'U': + case 'V': + case 'W': + case 'X': + case 'Y': + case 'Z': + module_unget_char (); + return ATOM_NAME; + + default: + bad_module ("Bad name"); + } +} + + +/* Read the next atom from the input, requiring that it be a + particular kind. */ + +static void +require_atom (atom_type type) +{ + atom_type t; + const char *p; + int column, line; + + column = module_column; + line = module_line; + + t = parse_atom (); + if (t != type) + { + switch (type) + { + case ATOM_NAME: + p = _("Expected name"); + break; + case ATOM_LPAREN: + p = _("Expected left parenthesis"); + break; + case ATOM_RPAREN: + p = _("Expected right parenthesis"); + break; + case ATOM_INTEGER: + p = _("Expected integer"); + break; + case ATOM_STRING: + p = _("Expected string"); + break; + default: + gfc_internal_error ("require_atom(): bad atom type required"); + } + + module_column = column; + module_line = line; + bad_module (p); + } +} + + +/* Given a pointer to an mstring array, require that the current input + be one of the strings in the array. We return the enum value. */ + +static int +find_enum (const mstring *m) +{ + int i; + + i = gfc_string2code (m, atom_name); + if (i >= 0) + return i; + + bad_module ("find_enum(): Enum not found"); + + /* Not reached. */ +} + + +/* Read a string. The caller is responsible for freeing. */ + +static char* +read_string (void) +{ + char* p; + require_atom (ATOM_STRING); + p = atom_string; + atom_string = NULL; + return p; +} + + +/**************** Module output subroutines ***************************/ + +/* Output a character to a module file. */ + +static void +write_char (char out) +{ + if (gzputc (module_fp, out) == EOF) + gfc_fatal_error ("Error writing modules file: %s", xstrerror (errno)); + + if (out != '\n') + module_column++; + else + { + module_column = 1; + module_line++; + } +} + + +/* Write an atom to a module. The line wrapping isn't perfect, but it + should work most of the time. This isn't that big of a deal, since + the file really isn't meant to be read by people anyway. */ + +static void +write_atom (atom_type atom, const void *v) +{ + char buffer[32]; + + /* Workaround -Wmaybe-uninitialized false positive during + profiledbootstrap by initializing them. */ + int len; + HOST_WIDE_INT i = 0; + const char *p; + + switch (atom) + { + case ATOM_STRING: + case ATOM_NAME: + p = (const char *) v; + break; + + case ATOM_LPAREN: + p = "("; + break; + + case ATOM_RPAREN: + p = ")"; + break; + + case ATOM_INTEGER: + i = *((const HOST_WIDE_INT *) v); + + snprintf (buffer, sizeof (buffer), HOST_WIDE_INT_PRINT_DEC, i); + p = buffer; + break; + + default: + gfc_internal_error ("write_atom(): Trying to write dab atom"); + + } + + if(p == NULL || *p == '\0') + len = 0; + else + len = strlen (p); + + if (atom != ATOM_RPAREN) + { + if (module_column + len > 72) + write_char ('\n'); + else + { + + if (last_atom != ATOM_LPAREN && module_column != 1) + write_char (' '); + } + } + + if (atom == ATOM_STRING) + write_char ('\''); + + while (p != NULL && *p) + { + if (atom == ATOM_STRING && *p == '\'') + write_char ('\''); + write_char (*p++); + } + + if (atom == ATOM_STRING) + write_char ('\''); + + last_atom = atom; +} + + + +/***************** Mid-level I/O subroutines *****************/ + +/* These subroutines let their caller read or write atoms without + caring about which of the two is actually happening. This lets a + subroutine concentrate on the actual format of the data being + written. */ + +static void mio_expr (gfc_expr **); +pointer_info *mio_symbol_ref (gfc_symbol **); +pointer_info *mio_interface_rest (gfc_interface **); +static void mio_symtree_ref (gfc_symtree **); + +/* Read or write an enumerated value. On writing, we return the input + value for the convenience of callers. We avoid using an integer + pointer because enums are sometimes inside bitfields. */ + +static int +mio_name (int t, const mstring *m) +{ + if (iomode == IO_OUTPUT) + write_atom (ATOM_NAME, gfc_code2string (m, t)); + else + { + require_atom (ATOM_NAME); + t = find_enum (m); + } + + return t; +} + +/* Specialization of mio_name. */ + +#define DECL_MIO_NAME(TYPE) \ + static inline TYPE \ + MIO_NAME(TYPE) (TYPE t, const mstring *m) \ + { \ + return (TYPE) mio_name ((int) t, m); \ + } +#define MIO_NAME(TYPE) mio_name_##TYPE + +static void +mio_lparen (void) +{ + if (iomode == IO_OUTPUT) + write_atom (ATOM_LPAREN, NULL); + else + require_atom (ATOM_LPAREN); +} + + +static void +mio_rparen (void) +{ + if (iomode == IO_OUTPUT) + write_atom (ATOM_RPAREN, NULL); + else + require_atom (ATOM_RPAREN); +} + + +static void +mio_integer (int *ip) +{ + if (iomode == IO_OUTPUT) + { + HOST_WIDE_INT hwi = *ip; + write_atom (ATOM_INTEGER, &hwi); + } + else + { + require_atom (ATOM_INTEGER); + *ip = atom_int; + } +} + +static void +mio_hwi (HOST_WIDE_INT *hwi) +{ + if (iomode == IO_OUTPUT) + write_atom (ATOM_INTEGER, hwi); + else + { + require_atom (ATOM_INTEGER); + *hwi = atom_int; + } +} + + +/* Read or write a gfc_intrinsic_op value. */ + +static void +mio_intrinsic_op (gfc_intrinsic_op* op) +{ + /* FIXME: Would be nicer to do this via the operators symbolic name. */ + if (iomode == IO_OUTPUT) + { + HOST_WIDE_INT converted = (HOST_WIDE_INT) *op; + write_atom (ATOM_INTEGER, &converted); + } + else + { + require_atom (ATOM_INTEGER); + *op = (gfc_intrinsic_op) atom_int; + } +} + + +/* Read or write a character pointer that points to a string on the heap. */ + +static const char * +mio_allocated_string (const char *s) +{ + if (iomode == IO_OUTPUT) + { + write_atom (ATOM_STRING, s); + return s; + } + else + { + require_atom (ATOM_STRING); + return atom_string; + } +} + + +/* Functions for quoting and unquoting strings. */ + +static char * +quote_string (const gfc_char_t *s, const size_t slength) +{ + const gfc_char_t *p; + char *res, *q; + size_t len = 0, i; + + /* Calculate the length we'll need: a backslash takes two ("\\"), + non-printable characters take 10 ("\Uxxxxxxxx") and others take 1. */ + for (p = s, i = 0; i < slength; p++, i++) + { + if (*p == '\\') + len += 2; + else if (!gfc_wide_is_printable (*p)) + len += 10; + else + len++; + } + + q = res = XCNEWVEC (char, len + 1); + for (p = s, i = 0; i < slength; p++, i++) + { + if (*p == '\\') + *q++ = '\\', *q++ = '\\'; + else if (!gfc_wide_is_printable (*p)) + { + sprintf (q, "\\U%08" HOST_WIDE_INT_PRINT "x", + (unsigned HOST_WIDE_INT) *p); + q += 10; + } + else + *q++ = (unsigned char) *p; + } + + res[len] = '\0'; + return res; +} + +static gfc_char_t * +unquote_string (const char *s) +{ + size_t len, i; + const char *p; + gfc_char_t *res; + + for (p = s, len = 0; *p; p++, len++) + { + if (*p != '\\') + continue; + + if (p[1] == '\\') + p++; + else if (p[1] == 'U') + p += 9; /* That is a "\U????????". */ + else + gfc_internal_error ("unquote_string(): got bad string"); + } + + res = gfc_get_wide_string (len + 1); + for (i = 0, p = s; i < len; i++, p++) + { + gcc_assert (*p); + + if (*p != '\\') + res[i] = (unsigned char) *p; + else if (p[1] == '\\') + { + res[i] = (unsigned char) '\\'; + p++; + } + else + { + /* We read the 8-digits hexadecimal constant that follows. */ + int j; + unsigned n; + gfc_char_t c = 0; + + gcc_assert (p[1] == 'U'); + for (j = 0; j < 8; j++) + { + c = c << 4; + gcc_assert (sscanf (&p[j+2], "%01x", &n) == 1); + c += n; + } + + res[i] = c; + p += 9; + } + } + + res[len] = '\0'; + return res; +} + + +/* Read or write a character pointer that points to a wide string on the + heap, performing quoting/unquoting of nonprintable characters using the + form \U???????? (where each ? is a hexadecimal digit). + Length is the length of the string, only known and used in output mode. */ + +static const gfc_char_t * +mio_allocated_wide_string (const gfc_char_t *s, const size_t length) +{ + if (iomode == IO_OUTPUT) + { + char *quoted = quote_string (s, length); + write_atom (ATOM_STRING, quoted); + free (quoted); + return s; + } + else + { + gfc_char_t *unquoted; + + require_atom (ATOM_STRING); + unquoted = unquote_string (atom_string); + free (atom_string); + return unquoted; + } +} + + +/* Read or write a string that is in static memory. */ + +static void +mio_pool_string (const char **stringp) +{ + /* TODO: one could write the string only once, and refer to it via a + fixup pointer. */ + + /* As a special case we have to deal with a NULL string. This + happens for the 'module' member of 'gfc_symbol's that are not in a + module. We read / write these as the empty string. */ + if (iomode == IO_OUTPUT) + { + const char *p = *stringp == NULL ? "" : *stringp; + write_atom (ATOM_STRING, p); + } + else + { + require_atom (ATOM_STRING); + *stringp = (atom_string[0] == '\0' + ? NULL : gfc_get_string ("%s", atom_string)); + free (atom_string); + } +} + + +/* Read or write a string that is inside of some already-allocated + structure. */ + +static void +mio_internal_string (char *string) +{ + if (iomode == IO_OUTPUT) + write_atom (ATOM_STRING, string); + else + { + require_atom (ATOM_STRING); + strcpy (string, atom_string); + free (atom_string); + } +} + + +enum ab_attribute +{ AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL, + 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_POINTER_COMP, AB_PROC_POINTER_COMP, AB_PRIVATE_COMP, + AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP, AB_EVENT_COMP, + AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP, + AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION, + AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER, + AB_IMPLICIT_PURE, AB_ARTIFICIAL, AB_UNLIMITED_POLY, AB_OMP_DECLARE_TARGET, + AB_ARRAY_OUTER_DEPENDENCY, AB_MODULE_PROCEDURE, AB_OACC_DECLARE_CREATE, + AB_OACC_DECLARE_COPYIN, AB_OACC_DECLARE_DEVICEPTR, + AB_OACC_DECLARE_DEVICE_RESIDENT, AB_OACC_DECLARE_LINK, + AB_OMP_DECLARE_TARGET_LINK, AB_PDT_KIND, AB_PDT_LEN, AB_PDT_TYPE, + AB_PDT_TEMPLATE, AB_PDT_ARRAY, AB_PDT_STRING, + AB_OACC_ROUTINE_LOP_GANG, AB_OACC_ROUTINE_LOP_WORKER, + AB_OACC_ROUTINE_LOP_VECTOR, AB_OACC_ROUTINE_LOP_SEQ, + AB_OACC_ROUTINE_NOHOST, + AB_OMP_REQ_REVERSE_OFFLOAD, AB_OMP_REQ_UNIFIED_ADDRESS, + AB_OMP_REQ_UNIFIED_SHARED_MEMORY, AB_OMP_REQ_DYNAMIC_ALLOCATORS, + AB_OMP_REQ_MEM_ORDER_SEQ_CST, AB_OMP_REQ_MEM_ORDER_ACQ_REL, + AB_OMP_REQ_MEM_ORDER_RELAXED, AB_OMP_DEVICE_TYPE_NOHOST, + AB_OMP_DEVICE_TYPE_HOST, AB_OMP_DEVICE_TYPE_ANY +}; + +static const mstring attr_bits[] = +{ + minit ("ALLOCATABLE", AB_ALLOCATABLE), + minit ("ARTIFICIAL", AB_ARTIFICIAL), + minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS), + minit ("DIMENSION", AB_DIMENSION), + minit ("CODIMENSION", AB_CODIMENSION), + minit ("CONTIGUOUS", AB_CONTIGUOUS), + minit ("EXTERNAL", AB_EXTERNAL), + minit ("INTRINSIC", AB_INTRINSIC), + minit ("OPTIONAL", AB_OPTIONAL), + minit ("POINTER", AB_POINTER), + minit ("VOLATILE", AB_VOLATILE), + minit ("TARGET", AB_TARGET), + minit ("THREADPRIVATE", AB_THREADPRIVATE), + minit ("DUMMY", AB_DUMMY), + minit ("RESULT", AB_RESULT), + minit ("DATA", AB_DATA), + minit ("IN_NAMELIST", AB_IN_NAMELIST), + minit ("IN_COMMON", AB_IN_COMMON), + minit ("FUNCTION", AB_FUNCTION), + minit ("SUBROUTINE", AB_SUBROUTINE), + minit ("SEQUENCE", AB_SEQUENCE), + minit ("ELEMENTAL", AB_ELEMENTAL), + minit ("PURE", AB_PURE), + minit ("RECURSIVE", AB_RECURSIVE), + minit ("GENERIC", AB_GENERIC), + 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 ("COARRAY_COMP", AB_COARRAY_COMP), + minit ("LOCK_COMP", AB_LOCK_COMP), + minit ("EVENT_COMP", AB_EVENT_COMP), + minit ("POINTER_COMP", AB_POINTER_COMP), + minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP), + minit ("PRIVATE_COMP", AB_PRIVATE_COMP), + minit ("ZERO_COMP", AB_ZERO_COMP), + minit ("PROTECTED", AB_PROTECTED), + minit ("ABSTRACT", AB_ABSTRACT), + minit ("IS_CLASS", AB_IS_CLASS), + minit ("PROCEDURE", AB_PROCEDURE), + minit ("PROC_POINTER", AB_PROC_POINTER), + minit ("VTYPE", AB_VTYPE), + minit ("VTAB", AB_VTAB), + minit ("CLASS_POINTER", AB_CLASS_POINTER), + minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE), + minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY), + minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET), + minit ("ARRAY_OUTER_DEPENDENCY", AB_ARRAY_OUTER_DEPENDENCY), + minit ("MODULE_PROCEDURE", AB_MODULE_PROCEDURE), + minit ("OACC_DECLARE_CREATE", AB_OACC_DECLARE_CREATE), + minit ("OACC_DECLARE_COPYIN", AB_OACC_DECLARE_COPYIN), + minit ("OACC_DECLARE_DEVICEPTR", AB_OACC_DECLARE_DEVICEPTR), + minit ("OACC_DECLARE_DEVICE_RESIDENT", AB_OACC_DECLARE_DEVICE_RESIDENT), + minit ("OACC_DECLARE_LINK", AB_OACC_DECLARE_LINK), + minit ("OMP_DECLARE_TARGET_LINK", AB_OMP_DECLARE_TARGET_LINK), + minit ("PDT_KIND", AB_PDT_KIND), + minit ("PDT_LEN", AB_PDT_LEN), + minit ("PDT_TYPE", AB_PDT_TYPE), + minit ("PDT_TEMPLATE", AB_PDT_TEMPLATE), + minit ("PDT_ARRAY", AB_PDT_ARRAY), + minit ("PDT_STRING", AB_PDT_STRING), + minit ("OACC_ROUTINE_LOP_GANG", AB_OACC_ROUTINE_LOP_GANG), + minit ("OACC_ROUTINE_LOP_WORKER", AB_OACC_ROUTINE_LOP_WORKER), + minit ("OACC_ROUTINE_LOP_VECTOR", AB_OACC_ROUTINE_LOP_VECTOR), + minit ("OACC_ROUTINE_LOP_SEQ", AB_OACC_ROUTINE_LOP_SEQ), + minit ("OACC_ROUTINE_NOHOST", AB_OACC_ROUTINE_NOHOST), + minit ("OMP_REQ_REVERSE_OFFLOAD", AB_OMP_REQ_REVERSE_OFFLOAD), + minit ("OMP_REQ_UNIFIED_ADDRESS", AB_OMP_REQ_UNIFIED_ADDRESS), + minit ("OMP_REQ_UNIFIED_SHARED_MEMORY", AB_OMP_REQ_UNIFIED_SHARED_MEMORY), + minit ("OMP_REQ_DYNAMIC_ALLOCATORS", AB_OMP_REQ_DYNAMIC_ALLOCATORS), + minit ("OMP_REQ_MEM_ORDER_SEQ_CST", AB_OMP_REQ_MEM_ORDER_SEQ_CST), + minit ("OMP_REQ_MEM_ORDER_ACQ_REL", AB_OMP_REQ_MEM_ORDER_ACQ_REL), + minit ("OMP_REQ_MEM_ORDER_RELAXED", AB_OMP_REQ_MEM_ORDER_RELAXED), + minit ("OMP_DEVICE_TYPE_HOST", AB_OMP_DEVICE_TYPE_HOST), + minit ("OMP_DEVICE_TYPE_NOHOST", AB_OMP_DEVICE_TYPE_NOHOST), + minit ("OMP_DEVICE_TYPE_ANYHOST", AB_OMP_DEVICE_TYPE_ANY), + minit (NULL, -1) +}; + +/* For binding attributes. */ +static const mstring binding_passing[] = +{ + minit ("PASS", 0), + minit ("NOPASS", 1), + minit (NULL, -1) +}; +static const mstring binding_overriding[] = +{ + minit ("OVERRIDABLE", 0), + minit ("NON_OVERRIDABLE", 1), + minit ("DEFERRED", 2), + minit (NULL, -1) +}; +static const mstring binding_generic[] = +{ + minit ("SPECIFIC", 0), + minit ("GENERIC", 1), + minit (NULL, -1) +}; +static const mstring binding_ppc[] = +{ + minit ("NO_PPC", 0), + minit ("PPC", 1), + minit (NULL, -1) +}; + +/* Specialization of mio_name. */ +DECL_MIO_NAME (ab_attribute) +DECL_MIO_NAME (ar_type) +DECL_MIO_NAME (array_type) +DECL_MIO_NAME (bt) +DECL_MIO_NAME (expr_t) +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) +DECL_MIO_NAME (sym_intent) +DECL_MIO_NAME (inquiry_type) +#undef DECL_MIO_NAME + +/* Verify OACC_ROUTINE_LOP_NONE. */ + +static void +verify_OACC_ROUTINE_LOP_NONE (enum oacc_routine_lop lop) +{ + if (lop != OACC_ROUTINE_LOP_NONE) + bad_module ("Unsupported: multiple OpenACC 'routine' levels of parallelism"); +} + +/* Symbol attributes are stored in list with the first three elements + being the enumerated fields, while the remaining elements (if any) + indicate the individual attribute bits. The access field is not + saved-- it controls what symbols are exported when a module is + written. */ + +static void +mio_symbol_attribute (symbol_attribute *attr) +{ + atom_type t; + unsigned ext_attr,extension_level; + + mio_lparen (); + + attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors); + 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); + + ext_attr = attr->ext_attr; + mio_integer ((int *) &ext_attr); + attr->ext_attr = ext_attr; + + extension_level = attr->extension; + mio_integer ((int *) &extension_level); + attr->extension = extension_level; + + if (iomode == IO_OUTPUT) + { + if (attr->allocatable) + MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits); + if (attr->artificial) + MIO_NAME (ab_attribute) (AB_ARTIFICIAL, attr_bits); + if (attr->asynchronous) + MIO_NAME (ab_attribute) (AB_ASYNCHRONOUS, attr_bits); + if (attr->dimension) + MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits); + if (attr->codimension) + MIO_NAME (ab_attribute) (AB_CODIMENSION, attr_bits); + if (attr->contiguous) + MIO_NAME (ab_attribute) (AB_CONTIGUOUS, attr_bits); + if (attr->external) + MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits); + if (attr->intrinsic) + MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits); + if (attr->optional) + MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits); + if (attr->pointer) + MIO_NAME (ab_attribute) (AB_POINTER, attr_bits); + if (attr->class_pointer) + MIO_NAME (ab_attribute) (AB_CLASS_POINTER, attr_bits); + if (attr->is_protected) + MIO_NAME (ab_attribute) (AB_PROTECTED, 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) + MIO_NAME (ab_attribute) (AB_TARGET, attr_bits); + if (attr->threadprivate) + MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits); + if (attr->dummy) + MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits); + if (attr->result) + MIO_NAME (ab_attribute) (AB_RESULT, attr_bits); + /* We deliberately don't preserve the "entry" flag. */ + + if (attr->data) + MIO_NAME (ab_attribute) (AB_DATA, attr_bits); + if (attr->in_namelist) + MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits); + if (attr->in_common) + MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits); + + if (attr->function) + MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits); + if (attr->subroutine) + MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits); + if (attr->generic) + MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits); + if (attr->abstract) + MIO_NAME (ab_attribute) (AB_ABSTRACT, attr_bits); + + if (attr->sequence) + MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits); + if (attr->elemental) + MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits); + if (attr->pure) + MIO_NAME (ab_attribute) (AB_PURE, attr_bits); + if (attr->implicit_pure) + MIO_NAME (ab_attribute) (AB_IMPLICIT_PURE, attr_bits); + if (attr->unlimited_polymorphic) + MIO_NAME (ab_attribute) (AB_UNLIMITED_POLY, attr_bits); + if (attr->recursive) + MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits); + if (attr->always_explicit) + MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits); + if (attr->cray_pointer) + 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->proc_pointer_comp) + MIO_NAME (ab_attribute) (AB_PROC_POINTER_COMP, attr_bits); + if (attr->private_comp) + MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits); + if (attr->coarray_comp) + MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits); + if (attr->lock_comp) + MIO_NAME (ab_attribute) (AB_LOCK_COMP, attr_bits); + if (attr->event_comp) + MIO_NAME (ab_attribute) (AB_EVENT_COMP, attr_bits); + if (attr->zero_comp) + MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits); + if (attr->is_class) + MIO_NAME (ab_attribute) (AB_IS_CLASS, attr_bits); + if (attr->procedure) + MIO_NAME (ab_attribute) (AB_PROCEDURE, attr_bits); + if (attr->proc_pointer) + MIO_NAME (ab_attribute) (AB_PROC_POINTER, attr_bits); + if (attr->vtype) + MIO_NAME (ab_attribute) (AB_VTYPE, attr_bits); + if (attr->vtab) + MIO_NAME (ab_attribute) (AB_VTAB, attr_bits); + if (attr->omp_declare_target) + MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET, attr_bits); + if (attr->array_outer_dependency) + MIO_NAME (ab_attribute) (AB_ARRAY_OUTER_DEPENDENCY, attr_bits); + if (attr->module_procedure) + MIO_NAME (ab_attribute) (AB_MODULE_PROCEDURE, attr_bits); + if (attr->oacc_declare_create) + MIO_NAME (ab_attribute) (AB_OACC_DECLARE_CREATE, attr_bits); + if (attr->oacc_declare_copyin) + MIO_NAME (ab_attribute) (AB_OACC_DECLARE_COPYIN, attr_bits); + if (attr->oacc_declare_deviceptr) + MIO_NAME (ab_attribute) (AB_OACC_DECLARE_DEVICEPTR, attr_bits); + if (attr->oacc_declare_device_resident) + MIO_NAME (ab_attribute) (AB_OACC_DECLARE_DEVICE_RESIDENT, attr_bits); + if (attr->oacc_declare_link) + MIO_NAME (ab_attribute) (AB_OACC_DECLARE_LINK, attr_bits); + if (attr->omp_declare_target_link) + MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET_LINK, attr_bits); + if (attr->pdt_kind) + MIO_NAME (ab_attribute) (AB_PDT_KIND, attr_bits); + if (attr->pdt_len) + MIO_NAME (ab_attribute) (AB_PDT_LEN, attr_bits); + if (attr->pdt_type) + MIO_NAME (ab_attribute) (AB_PDT_TYPE, attr_bits); + if (attr->pdt_template) + MIO_NAME (ab_attribute) (AB_PDT_TEMPLATE, attr_bits); + if (attr->pdt_array) + MIO_NAME (ab_attribute) (AB_PDT_ARRAY, attr_bits); + if (attr->pdt_string) + MIO_NAME (ab_attribute) (AB_PDT_STRING, attr_bits); + switch (attr->oacc_routine_lop) + { + case OACC_ROUTINE_LOP_NONE: + /* This is the default anyway, and for maintaining compatibility with + the current MOD_VERSION, we're not emitting anything in that + case. */ + break; + case OACC_ROUTINE_LOP_GANG: + MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_GANG, attr_bits); + break; + case OACC_ROUTINE_LOP_WORKER: + MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_WORKER, attr_bits); + break; + case OACC_ROUTINE_LOP_VECTOR: + MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_VECTOR, attr_bits); + break; + case OACC_ROUTINE_LOP_SEQ: + MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_SEQ, attr_bits); + break; + case OACC_ROUTINE_LOP_ERROR: + /* ... intentionally omitted here; it's only unsed internally. */ + default: + gcc_unreachable (); + } + if (attr->oacc_routine_nohost) + MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_NOHOST, attr_bits); + + if (attr->flavor == FL_MODULE && gfc_current_ns->omp_requires) + { + if (gfc_current_ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD) + MIO_NAME (ab_attribute) (AB_OMP_REQ_REVERSE_OFFLOAD, attr_bits); + if (gfc_current_ns->omp_requires & OMP_REQ_UNIFIED_ADDRESS) + MIO_NAME (ab_attribute) (AB_OMP_REQ_UNIFIED_ADDRESS, attr_bits); + if (gfc_current_ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY) + MIO_NAME (ab_attribute) (AB_OMP_REQ_UNIFIED_SHARED_MEMORY, attr_bits); + if (gfc_current_ns->omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS) + MIO_NAME (ab_attribute) (AB_OMP_REQ_DYNAMIC_ALLOCATORS, attr_bits); + if ((gfc_current_ns->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK) + == OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST) + MIO_NAME (ab_attribute) (AB_OMP_REQ_MEM_ORDER_SEQ_CST, attr_bits); + if ((gfc_current_ns->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK) + == OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL) + MIO_NAME (ab_attribute) (AB_OMP_REQ_MEM_ORDER_ACQ_REL, attr_bits); + if ((gfc_current_ns->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK) + == OMP_REQ_ATOMIC_MEM_ORDER_RELAXED) + MIO_NAME (ab_attribute) (AB_OMP_REQ_MEM_ORDER_RELAXED, attr_bits); + } + switch (attr->omp_device_type) + { + case OMP_DEVICE_TYPE_UNSET: + break; + case OMP_DEVICE_TYPE_HOST: + MIO_NAME (ab_attribute) (AB_OMP_DEVICE_TYPE_HOST, attr_bits); + break; + case OMP_DEVICE_TYPE_NOHOST: + MIO_NAME (ab_attribute) (AB_OMP_DEVICE_TYPE_NOHOST, attr_bits); + break; + case OMP_DEVICE_TYPE_ANY: + MIO_NAME (ab_attribute) (AB_OMP_DEVICE_TYPE_ANY, attr_bits); + break; + default: + gcc_unreachable (); + } + mio_rparen (); + } + else + { + for (;;) + { + t = parse_atom (); + if (t == ATOM_RPAREN) + break; + if (t != ATOM_NAME) + bad_module ("Expected attribute bit name"); + + switch ((ab_attribute) find_enum (attr_bits)) + { + case AB_ALLOCATABLE: + attr->allocatable = 1; + break; + case AB_ARTIFICIAL: + attr->artificial = 1; + break; + case AB_ASYNCHRONOUS: + attr->asynchronous = 1; + break; + case AB_DIMENSION: + attr->dimension = 1; + break; + case AB_CODIMENSION: + attr->codimension = 1; + break; + case AB_CONTIGUOUS: + attr->contiguous = 1; + break; + case AB_EXTERNAL: + attr->external = 1; + break; + case AB_INTRINSIC: + attr->intrinsic = 1; + break; + case AB_OPTIONAL: + attr->optional = 1; + break; + case AB_POINTER: + attr->pointer = 1; + break; + case AB_CLASS_POINTER: + attr->class_pointer = 1; + break; + case AB_PROTECTED: + attr->is_protected = 1; + break; + case AB_VALUE: + attr->value = 1; + break; + case AB_VOLATILE: + attr->volatile_ = 1; + break; + case AB_TARGET: + attr->target = 1; + break; + case AB_THREADPRIVATE: + attr->threadprivate = 1; + break; + case AB_DUMMY: + attr->dummy = 1; + break; + case AB_RESULT: + attr->result = 1; + break; + case AB_DATA: + attr->data = 1; + break; + case AB_IN_NAMELIST: + attr->in_namelist = 1; + break; + case AB_IN_COMMON: + attr->in_common = 1; + break; + case AB_FUNCTION: + attr->function = 1; + break; + case AB_SUBROUTINE: + attr->subroutine = 1; + break; + case AB_GENERIC: + attr->generic = 1; + break; + case AB_ABSTRACT: + attr->abstract = 1; + break; + case AB_SEQUENCE: + attr->sequence = 1; + break; + case AB_ELEMENTAL: + attr->elemental = 1; + break; + case AB_PURE: + attr->pure = 1; + break; + case AB_IMPLICIT_PURE: + attr->implicit_pure = 1; + break; + case AB_UNLIMITED_POLY: + attr->unlimited_polymorphic = 1; + break; + case AB_RECURSIVE: + attr->recursive = 1; + break; + case AB_ALWAYS_EXPLICIT: + attr->always_explicit = 1; + break; + case AB_CRAY_POINTER: + attr->cray_pointer = 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_COARRAY_COMP: + attr->coarray_comp = 1; + break; + case AB_LOCK_COMP: + attr->lock_comp = 1; + break; + case AB_EVENT_COMP: + attr->event_comp = 1; + break; + case AB_POINTER_COMP: + attr->pointer_comp = 1; + break; + case AB_PROC_POINTER_COMP: + attr->proc_pointer_comp = 1; + break; + case AB_PRIVATE_COMP: + attr->private_comp = 1; + break; + case AB_ZERO_COMP: + attr->zero_comp = 1; + break; + case AB_IS_CLASS: + attr->is_class = 1; + break; + case AB_PROCEDURE: + attr->procedure = 1; + break; + case AB_PROC_POINTER: + attr->proc_pointer = 1; + break; + case AB_VTYPE: + attr->vtype = 1; + break; + case AB_VTAB: + attr->vtab = 1; + break; + case AB_OMP_DECLARE_TARGET: + attr->omp_declare_target = 1; + break; + case AB_OMP_DECLARE_TARGET_LINK: + attr->omp_declare_target_link = 1; + break; + case AB_ARRAY_OUTER_DEPENDENCY: + attr->array_outer_dependency =1; + break; + case AB_MODULE_PROCEDURE: + attr->module_procedure =1; + break; + case AB_OACC_DECLARE_CREATE: + attr->oacc_declare_create = 1; + break; + case AB_OACC_DECLARE_COPYIN: + attr->oacc_declare_copyin = 1; + break; + case AB_OACC_DECLARE_DEVICEPTR: + attr->oacc_declare_deviceptr = 1; + break; + case AB_OACC_DECLARE_DEVICE_RESIDENT: + attr->oacc_declare_device_resident = 1; + break; + case AB_OACC_DECLARE_LINK: + attr->oacc_declare_link = 1; + break; + case AB_PDT_KIND: + attr->pdt_kind = 1; + break; + case AB_PDT_LEN: + attr->pdt_len = 1; + break; + case AB_PDT_TYPE: + attr->pdt_type = 1; + break; + case AB_PDT_TEMPLATE: + attr->pdt_template = 1; + break; + case AB_PDT_ARRAY: + attr->pdt_array = 1; + break; + case AB_PDT_STRING: + attr->pdt_string = 1; + break; + case AB_OACC_ROUTINE_LOP_GANG: + verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop); + attr->oacc_routine_lop = OACC_ROUTINE_LOP_GANG; + break; + case AB_OACC_ROUTINE_LOP_WORKER: + verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop); + attr->oacc_routine_lop = OACC_ROUTINE_LOP_WORKER; + break; + case AB_OACC_ROUTINE_LOP_VECTOR: + verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop); + attr->oacc_routine_lop = OACC_ROUTINE_LOP_VECTOR; + break; + case AB_OACC_ROUTINE_LOP_SEQ: + verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop); + attr->oacc_routine_lop = OACC_ROUTINE_LOP_SEQ; + break; + case AB_OACC_ROUTINE_NOHOST: + attr->oacc_routine_nohost = 1; + break; + case AB_OMP_REQ_REVERSE_OFFLOAD: + gfc_omp_requires_add_clause (OMP_REQ_REVERSE_OFFLOAD, + "reverse_offload", + &gfc_current_locus, + module_name); + break; + case AB_OMP_REQ_UNIFIED_ADDRESS: + gfc_omp_requires_add_clause (OMP_REQ_UNIFIED_ADDRESS, + "unified_address", + &gfc_current_locus, + module_name); + break; + case AB_OMP_REQ_UNIFIED_SHARED_MEMORY: + gfc_omp_requires_add_clause (OMP_REQ_UNIFIED_SHARED_MEMORY, + "unified_shared_memory", + &gfc_current_locus, + module_name); + break; + case AB_OMP_REQ_DYNAMIC_ALLOCATORS: + gfc_omp_requires_add_clause (OMP_REQ_DYNAMIC_ALLOCATORS, + "dynamic_allocators", + &gfc_current_locus, + module_name); + break; + case AB_OMP_REQ_MEM_ORDER_SEQ_CST: + gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST, + "seq_cst", &gfc_current_locus, + module_name); + break; + case AB_OMP_REQ_MEM_ORDER_ACQ_REL: + gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL, + "acq_rel", &gfc_current_locus, + module_name); + break; + case AB_OMP_REQ_MEM_ORDER_RELAXED: + gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_RELAXED, + "relaxed", &gfc_current_locus, + module_name); + break; + case AB_OMP_DEVICE_TYPE_HOST: + attr->omp_device_type = OMP_DEVICE_TYPE_HOST; + break; + case AB_OMP_DEVICE_TYPE_NOHOST: + attr->omp_device_type = OMP_DEVICE_TYPE_NOHOST; + break; + case AB_OMP_DEVICE_TYPE_ANY: + attr->omp_device_type = OMP_DEVICE_TYPE_ANY; + break; + } + } + } +} + + +static const mstring bt_types[] = { + minit ("INTEGER", BT_INTEGER), + minit ("REAL", BT_REAL), + minit ("COMPLEX", BT_COMPLEX), + minit ("LOGICAL", BT_LOGICAL), + minit ("CHARACTER", BT_CHARACTER), + minit ("UNION", BT_UNION), + minit ("DERIVED", BT_DERIVED), + minit ("CLASS", BT_CLASS), + minit ("PROCEDURE", BT_PROCEDURE), + minit ("UNKNOWN", BT_UNKNOWN), + minit ("VOID", BT_VOID), + minit ("ASSUMED", BT_ASSUMED), + minit (NULL, -1) +}; + + +static void +mio_charlen (gfc_charlen **clp) +{ + gfc_charlen *cl; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + cl = *clp; + if (cl != NULL) + mio_expr (&cl->length); + } + else + { + if (peek_atom () != ATOM_RPAREN) + { + cl = gfc_new_charlen (gfc_current_ns, NULL); + mio_expr (&cl->length); + *clp = cl; + } + } + + mio_rparen (); +} + + +/* See if a name is a generated name. */ + +static int +check_unique_name (const char *name) +{ + return *name == '@'; +} + + +static void +mio_typespec (gfc_typespec *ts) +{ + mio_lparen (); + + ts->type = MIO_NAME (bt) (ts->type, bt_types); + + if (!gfc_bt_struct (ts->type) && ts->type != BT_CLASS) + mio_integer (&ts->kind); + else + mio_symbol_ref (&ts->u.derived); + + mio_symbol_ref (&ts->interface); + + /* 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->u.cl is only valid for BT_CHARACTER. */ + mio_lparen (); + mio_rparen (); + } + else + mio_charlen (&ts->u.cl); + + /* So as not to disturb the existing API, use an ATOM_NAME to + transmit deferred characteristic for characters (F2003). */ + if (iomode == IO_OUTPUT) + { + if (ts->type == BT_CHARACTER && ts->deferred) + write_atom (ATOM_NAME, "DEFERRED_CL"); + } + else if (peek_atom () != ATOM_RPAREN) + { + if (parse_atom () != ATOM_NAME) + bad_module ("Expected string"); + ts->deferred = 1; + } + + mio_rparen (); +} + + +static const mstring array_spec_types[] = { + minit ("EXPLICIT", AS_EXPLICIT), + minit ("ASSUMED_RANK", AS_ASSUMED_RANK), + minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE), + minit ("DEFERRED", AS_DEFERRED), + minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE), + minit (NULL, -1) +}; + + +static void +mio_array_spec (gfc_array_spec **asp) +{ + gfc_array_spec *as; + int i; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + int rank; + + if (*asp == NULL) + goto done; + as = *asp; + + /* mio_integer expects nonnegative values. */ + rank = as->rank > 0 ? as->rank : 0; + mio_integer (&rank); + } + else + { + if (peek_atom () == ATOM_RPAREN) + { + *asp = NULL; + goto done; + } + + *asp = as = gfc_get_array_spec (); + mio_integer (&as->rank); + } + + mio_integer (&as->corank); + as->type = MIO_NAME (array_type) (as->type, array_spec_types); + + if (iomode == IO_INPUT && as->type == AS_ASSUMED_RANK) + as->rank = -1; + if (iomode == IO_INPUT && as->corank) + as->cotype = (as->type == AS_DEFERRED) ? AS_DEFERRED : AS_EXPLICIT; + + if (as->rank + as->corank > 0) + for (i = 0; i < as->rank + as->corank; i++) + { + mio_expr (&as->lower[i]); + mio_expr (&as->upper[i]); + } + +done: + mio_rparen (); +} + + +/* Given a pointer to an array reference structure (which lives in a + gfc_ref structure), find the corresponding array specification + structure. Storing the pointer in the ref structure doesn't quite + work when loading from a module. Generating code for an array + reference also needs more information than just the array spec. */ + +static const mstring array_ref_types[] = { + minit ("FULL", AR_FULL), + minit ("ELEMENT", AR_ELEMENT), + minit ("SECTION", AR_SECTION), + minit (NULL, -1) +}; + + +static void +mio_array_ref (gfc_array_ref *ar) +{ + int i; + + mio_lparen (); + ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types); + mio_integer (&ar->dimen); + + switch (ar->type) + { + case AR_FULL: + break; + + case AR_ELEMENT: + for (i = 0; i < ar->dimen; i++) + mio_expr (&ar->start[i]); + + break; + + case AR_SECTION: + for (i = 0; i < ar->dimen; i++) + { + mio_expr (&ar->start[i]); + mio_expr (&ar->end[i]); + mio_expr (&ar->stride[i]); + } + + break; + + case AR_UNKNOWN: + gfc_internal_error ("mio_array_ref(): Unknown array ref"); + } + + /* Unfortunately, ar->dimen_type is an anonymous enumerated type so + we can't call mio_integer directly. Instead loop over each element + and cast it to/from an integer. */ + if (iomode == IO_OUTPUT) + { + for (i = 0; i < ar->dimen; i++) + { + HOST_WIDE_INT tmp = (HOST_WIDE_INT)ar->dimen_type[i]; + write_atom (ATOM_INTEGER, &tmp); + } + } + else + { + for (i = 0; i < ar->dimen; i++) + { + require_atom (ATOM_INTEGER); + ar->dimen_type[i] = (enum gfc_array_ref_dimen_type) atom_int; + } + } + + if (iomode == IO_INPUT) + { + ar->where = gfc_current_locus; + + for (i = 0; i < ar->dimen; i++) + ar->c_where[i] = gfc_current_locus; + } + + mio_rparen (); +} + + +/* Saves or restores a pointer. The pointer is converted back and + forth from an integer. We return the pointer_info pointer so that + the caller can take additional action based on the pointer type. */ + +static pointer_info * +mio_pointer_ref (void *gp) +{ + pointer_info *p; + + if (iomode == IO_OUTPUT) + { + p = get_pointer (*((char **) gp)); + HOST_WIDE_INT hwi = p->integer; + write_atom (ATOM_INTEGER, &hwi); + } + else + { + require_atom (ATOM_INTEGER); + p = add_fixup (atom_int, gp); + } + + return p; +} + + +/* Save and load references to components that occur within + expressions. We have to describe these references by a number and + by name. The number is necessary for forward references during + reading, and the name is necessary if the symbol already exists in + the namespace and is not loaded again. */ + +static void +mio_component_ref (gfc_component **cp) +{ + pointer_info *p; + + p = mio_pointer_ref (cp); + if (p->type == P_UNKNOWN) + p->type = P_COMPONENT; +} + + +static void mio_namespace_ref (gfc_namespace **nsp); +static void mio_formal_arglist (gfc_formal_arglist **formal); +static void mio_typebound_proc (gfc_typebound_proc** proc); +static void mio_actual_arglist (gfc_actual_arglist **ap, bool pdt); + +static void +mio_component (gfc_component *c, int vtype) +{ + pointer_info *p; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + p = get_pointer (c); + mio_hwi (&p->integer); + } + else + { + HOST_WIDE_INT n; + mio_hwi (&n); + p = get_integer (n); + associate_integer_pointer (p, c); + } + + if (p->type == P_UNKNOWN) + p->type = P_COMPONENT; + + mio_pool_string (&c->name); + mio_typespec (&c->ts); + mio_array_spec (&c->as); + + /* PDT templates store the expression for the kind of a component here. */ + mio_expr (&c->kind_expr); + + /* PDT types store the component specification list here. */ + mio_actual_arglist (&c->param_list, true); + + mio_symbol_attribute (&c->attr); + if (c->ts.type == BT_CLASS) + c->attr.class_ok = 1; + c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types); + + if (!vtype || strcmp (c->name, "_final") == 0 + || strcmp (c->name, "_hash") == 0) + mio_expr (&c->initializer); + + if (c->attr.proc_pointer) + mio_typebound_proc (&c->tb); + + c->loc = gfc_current_locus; + + mio_rparen (); +} + + +static void +mio_component_list (gfc_component **cp, int vtype) +{ + gfc_component *c, *tail; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + for (c = *cp; c; c = c->next) + mio_component (c, vtype); + } + else + { + *cp = NULL; + tail = NULL; + + for (;;) + { + if (peek_atom () == ATOM_RPAREN) + break; + + c = gfc_get_component (); + mio_component (c, vtype); + + if (tail == NULL) + *cp = c; + else + tail->next = c; + + tail = c; + } + } + + mio_rparen (); +} + + +static void +mio_actual_arg (gfc_actual_arglist *a, bool pdt) +{ + mio_lparen (); + mio_pool_string (&a->name); + mio_expr (&a->expr); + if (pdt) + mio_integer ((int *)&a->spec_type); + mio_rparen (); +} + + +static void +mio_actual_arglist (gfc_actual_arglist **ap, bool pdt) +{ + gfc_actual_arglist *a, *tail; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + for (a = *ap; a; a = a->next) + mio_actual_arg (a, pdt); + + } + else + { + tail = NULL; + + for (;;) + { + if (peek_atom () != ATOM_LPAREN) + break; + + a = gfc_get_actual_arglist (); + + if (tail == NULL) + *ap = a; + else + tail->next = a; + + tail = a; + mio_actual_arg (a, pdt); + } + } + + mio_rparen (); +} + + +/* Read and write formal argument lists. */ + +static void +mio_formal_arglist (gfc_formal_arglist **formal) +{ + gfc_formal_arglist *f, *tail; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + for (f = *formal; f; f = f->next) + mio_symbol_ref (&f->sym); + } + else + { + *formal = tail = NULL; + + while (peek_atom () != ATOM_RPAREN) + { + f = gfc_get_formal_arglist (); + mio_symbol_ref (&f->sym); + + if (*formal == NULL) + *formal = f; + else + tail->next = f; + + tail = f; + } + } + + mio_rparen (); +} + + +/* Save or restore a reference to a symbol node. */ + +pointer_info * +mio_symbol_ref (gfc_symbol **symp) +{ + pointer_info *p; + + p = mio_pointer_ref (symp); + if (p->type == P_UNKNOWN) + p->type = P_SYMBOL; + + if (iomode == IO_OUTPUT) + { + if (p->u.wsym.state == UNREFERENCED) + p->u.wsym.state = NEEDS_WRITE; + } + else + { + if (p->u.rsym.state == UNUSED) + p->u.rsym.state = NEEDED; + } + return p; +} + + +/* Save or restore a reference to a symtree node. */ + +static void +mio_symtree_ref (gfc_symtree **stp) +{ + pointer_info *p; + fixup_t *f; + + if (iomode == IO_OUTPUT) + mio_symbol_ref (&(*stp)->n.sym); + else + { + require_atom (ATOM_INTEGER); + p = get_integer (atom_int); + + /* An unused equivalence member; make a symbol and a symtree + for it. */ + if (in_load_equiv && p->u.rsym.symtree == NULL) + { + /* 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 ("%s", 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 the symbol is PRIVATE and in COMMON, load_commons will + generate a fixup symbol, which must be associated. */ + if (p->fixup) + resolve_fixups (p->fixup, p->u.rsym.sym); + p->fixup = NULL; + } + + if (p->type == P_UNKNOWN) + p->type = P_SYMBOL; + + if (p->u.rsym.state == UNUSED) + p->u.rsym.state = NEEDED; + + if (p->u.rsym.symtree != NULL) + { + *stp = p->u.rsym.symtree; + } + else + { + f = XCNEW (fixup_t); + + f->next = p->u.rsym.stfixup; + p->u.rsym.stfixup = f; + + f->pointer = (void **) stp; + } + } +} + + +static void +mio_iterator (gfc_iterator **ip) +{ + gfc_iterator *iter; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + if (*ip == NULL) + goto done; + } + else + { + if (peek_atom () == ATOM_RPAREN) + { + *ip = NULL; + goto done; + } + + *ip = gfc_get_iterator (); + } + + iter = *ip; + + mio_expr (&iter->var); + mio_expr (&iter->start); + mio_expr (&iter->end); + mio_expr (&iter->step); + +done: + mio_rparen (); +} + + +static void +mio_constructor (gfc_constructor_base *cp) +{ + gfc_constructor *c; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + for (c = gfc_constructor_first (*cp); c; c = gfc_constructor_next (c)) + { + mio_lparen (); + mio_expr (&c->expr); + mio_iterator (&c->iterator); + mio_rparen (); + } + } + else + { + while (peek_atom () != ATOM_RPAREN) + { + c = gfc_constructor_append_expr (cp, NULL, NULL); + + mio_lparen (); + mio_expr (&c->expr); + mio_iterator (&c->iterator); + mio_rparen (); + } + } + + mio_rparen (); +} + + +static const mstring ref_types[] = { + minit ("ARRAY", REF_ARRAY), + minit ("COMPONENT", REF_COMPONENT), + minit ("SUBSTRING", REF_SUBSTRING), + minit ("INQUIRY", REF_INQUIRY), + minit (NULL, -1) +}; + +static const mstring inquiry_types[] = { + minit ("RE", INQUIRY_RE), + minit ("IM", INQUIRY_IM), + minit ("KIND", INQUIRY_KIND), + minit ("LEN", INQUIRY_LEN), + minit (NULL, -1) +}; + + +static void +mio_ref (gfc_ref **rp) +{ + gfc_ref *r; + + mio_lparen (); + + r = *rp; + r->type = MIO_NAME (ref_type) (r->type, ref_types); + + switch (r->type) + { + case REF_ARRAY: + mio_array_ref (&r->u.ar); + break; + + case REF_COMPONENT: + mio_symbol_ref (&r->u.c.sym); + mio_component_ref (&r->u.c.component); + break; + + case REF_SUBSTRING: + mio_expr (&r->u.ss.start); + mio_expr (&r->u.ss.end); + mio_charlen (&r->u.ss.length); + break; + + case REF_INQUIRY: + r->u.i = MIO_NAME (inquiry_type) (r->u.i, inquiry_types); + break; + } + + mio_rparen (); +} + + +static void +mio_ref_list (gfc_ref **rp) +{ + gfc_ref *ref, *head, *tail; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + for (ref = *rp; ref; ref = ref->next) + mio_ref (&ref); + } + else + { + head = tail = NULL; + + while (peek_atom () != ATOM_RPAREN) + { + if (head == NULL) + head = tail = gfc_get_ref (); + else + { + tail->next = gfc_get_ref (); + tail = tail->next; + } + + mio_ref (&tail); + } + + *rp = head; + } + + mio_rparen (); +} + + +/* Read and write an integer value. */ + +static void +mio_gmp_integer (mpz_t *integer) +{ + char *p; + + if (iomode == IO_INPUT) + { + if (parse_atom () != ATOM_STRING) + bad_module ("Expected integer string"); + + mpz_init (*integer); + if (mpz_set_str (*integer, atom_string, 10)) + bad_module ("Error converting integer"); + + free (atom_string); + } + else + { + p = mpz_get_str (NULL, 10, *integer); + write_atom (ATOM_STRING, p); + free (p); + } +} + + +static void +mio_gmp_real (mpfr_t *real) +{ + mpfr_exp_t exponent; + char *p; + + if (iomode == IO_INPUT) + { + if (parse_atom () != ATOM_STRING) + bad_module ("Expected real string"); + + mpfr_init (*real); + mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE); + free (atom_string); + } + else + { + p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE); + + if (mpfr_nan_p (*real) || mpfr_inf_p (*real)) + { + write_atom (ATOM_STRING, p); + free (p); + return; + } + + atom_string = XCNEWVEC (char, strlen (p) + 20); + + sprintf (atom_string, "0.%s@%ld", p, exponent); + + /* Fix negative numbers. */ + if (atom_string[2] == '-') + { + atom_string[0] = '-'; + atom_string[1] = '0'; + atom_string[2] = '.'; + } + + write_atom (ATOM_STRING, atom_string); + + free (atom_string); + free (p); + } +} + + +/* Save and restore the shape of an array constructor. */ + +static void +mio_shape (mpz_t **pshape, int rank) +{ + mpz_t *shape; + atom_type t; + int n; + + /* A NULL shape is represented by (). */ + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + shape = *pshape; + if (!shape) + { + mio_rparen (); + return; + } + } + else + { + t = peek_atom (); + if (t == ATOM_RPAREN) + { + *pshape = NULL; + mio_rparen (); + return; + } + + shape = gfc_get_shape (rank); + *pshape = shape; + } + + for (n = 0; n < rank; n++) + mio_gmp_integer (&shape[n]); + + mio_rparen (); +} + + +static const mstring expr_types[] = { + minit ("OP", EXPR_OP), + minit ("FUNCTION", EXPR_FUNCTION), + minit ("CONSTANT", EXPR_CONSTANT), + minit ("VARIABLE", EXPR_VARIABLE), + minit ("SUBSTRING", EXPR_SUBSTRING), + minit ("STRUCTURE", EXPR_STRUCTURE), + minit ("ARRAY", EXPR_ARRAY), + minit ("NULL", EXPR_NULL), + minit ("COMPCALL", EXPR_COMPCALL), + minit (NULL, -1) +}; + +/* INTRINSIC_ASSIGN is missing because it is used as an index for + generic operators, not in expressions. INTRINSIC_USER is also + replaced by the correct function name by the time we see it. */ + +static const mstring intrinsics[] = +{ + minit ("UPLUS", INTRINSIC_UPLUS), + minit ("UMINUS", INTRINSIC_UMINUS), + minit ("PLUS", INTRINSIC_PLUS), + minit ("MINUS", INTRINSIC_MINUS), + minit ("TIMES", INTRINSIC_TIMES), + minit ("DIVIDE", INTRINSIC_DIVIDE), + minit ("POWER", INTRINSIC_POWER), + minit ("CONCAT", INTRINSIC_CONCAT), + minit ("AND", INTRINSIC_AND), + minit ("OR", INTRINSIC_OR), + minit ("EQV", INTRINSIC_EQV), + minit ("NEQV", INTRINSIC_NEQV), + minit ("EQ_SIGN", INTRINSIC_EQ), + minit ("EQ", INTRINSIC_EQ_OS), + minit ("NE_SIGN", INTRINSIC_NE), + minit ("NE", INTRINSIC_NE_OS), + minit ("GT_SIGN", INTRINSIC_GT), + minit ("GT", INTRINSIC_GT_OS), + minit ("GE_SIGN", INTRINSIC_GE), + minit ("GE", INTRINSIC_GE_OS), + minit ("LT_SIGN", INTRINSIC_LT), + minit ("LT", INTRINSIC_LT_OS), + minit ("LE_SIGN", INTRINSIC_LE), + minit ("LE", INTRINSIC_LE_OS), + minit ("NOT", INTRINSIC_NOT), + minit ("PARENTHESES", INTRINSIC_PARENTHESES), + minit ("USER", INTRINSIC_USER), + minit (NULL, -1) +}; + + +/* Remedy a couple of situations where the gfc_expr's can be defective. */ + +static void +fix_mio_expr (gfc_expr *e) +{ + gfc_symtree *ns_st = NULL; + const char *fname; + + if (iomode != IO_OUTPUT) + return; + + if (e->symtree) + { + /* If this is a symtree for a symbol that came from a contained module + 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)) + { + const char *name = e->symtree->n.sym->name; + if (gfc_fl_struct (e->symtree->n.sym->attr.flavor)) + name = gfc_dt_upper_string (name); + ns_st = gfc_find_symtree (gfc_current_ns->sym_root, name); + } + + /* On the other hand, if the existing symbol is the module name or the + new symbol is a dummy argument, do not do the promotion. */ + if (ns_st && ns_st->n.sym + && ns_st->n.sym->attr.flavor != FL_MODULE + && !e->symtree->n.sym->attr.dummy) + e->symtree = ns_st; + } + else if (e->expr_type == EXPR_FUNCTION + && (e->value.function.name || e->value.function.isym)) + { + gfc_symbol *sym; + + /* In some circumstances, a function used in an initialization + expression, in one use associated module, can fail to be + coupled to its symtree when used in a specification + expression in another module. */ + fname = e->value.function.esym ? e->value.function.esym->name + : e->value.function.isym->name; + e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname); + + if (e->symtree) + return; + + /* This is probably a reference to a private procedure from another + module. To prevent a segfault, make a generic with no specific + instances. If this module is used, without the required + specific coming from somewhere, the appropriate error message + is issued. */ + gfc_get_symbol (fname, gfc_current_ns, &sym); + sym->attr.flavor = FL_PROCEDURE; + sym->attr.generic = 1; + e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname); + gfc_commit_symbol (sym); + } +} + + +/* Read and write expressions. The form "()" is allowed to indicate a + NULL expression. */ + +static void +mio_expr (gfc_expr **ep) +{ + HOST_WIDE_INT hwi; + gfc_expr *e; + atom_type t; + int flag; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + if (*ep == NULL) + { + mio_rparen (); + return; + } + + e = *ep; + MIO_NAME (expr_t) (e->expr_type, expr_types); + } + else + { + t = parse_atom (); + if (t == ATOM_RPAREN) + { + *ep = NULL; + return; + } + + if (t != ATOM_NAME) + bad_module ("Expected expression type"); + + e = *ep = gfc_get_expr (); + e->where = gfc_current_locus; + e->expr_type = (expr_t) find_enum (expr_types); + } + + mio_typespec (&e->ts); + mio_integer (&e->rank); + + fix_mio_expr (e); + + switch (e->expr_type) + { + case EXPR_OP: + e->value.op.op + = MIO_NAME (gfc_intrinsic_op) (e->value.op.op, intrinsics); + + switch (e->value.op.op) + { + case INTRINSIC_UPLUS: + case INTRINSIC_UMINUS: + case INTRINSIC_NOT: + case INTRINSIC_PARENTHESES: + mio_expr (&e->value.op.op1); + break; + + case INTRINSIC_PLUS: + case INTRINSIC_MINUS: + case INTRINSIC_TIMES: + case INTRINSIC_DIVIDE: + case INTRINSIC_POWER: + case INTRINSIC_CONCAT: + case INTRINSIC_AND: + case INTRINSIC_OR: + 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; + + case INTRINSIC_USER: + /* INTRINSIC_USER should not appear in resolved expressions, + though for UDRs we need to stream unresolved ones. */ + if (iomode == IO_OUTPUT) + write_atom (ATOM_STRING, e->value.op.uop->name); + else + { + char *name = read_string (); + const char *uop_name = find_use_name (name, true); + if (uop_name == NULL) + { + size_t len = strlen (name); + char *name2 = XCNEWVEC (char, len + 2); + memcpy (name2, name, len); + name2[len] = ' '; + name2[len + 1] = '\0'; + free (name); + uop_name = name = name2; + } + e->value.op.uop = gfc_get_uop (uop_name); + free (name); + } + mio_expr (&e->value.op.op1); + mio_expr (&e->value.op.op2); + break; + + default: + bad_module ("Bad operator"); + } + + break; + + case EXPR_FUNCTION: + mio_symtree_ref (&e->symtree); + mio_actual_arglist (&e->value.function.actual, false); + + if (iomode == IO_OUTPUT) + { + e->value.function.name + = mio_allocated_string (e->value.function.name); + if (e->value.function.esym) + flag = 1; + else if (e->ref) + flag = 2; + else if (e->value.function.isym == NULL) + flag = 3; + else + flag = 0; + mio_integer (&flag); + switch (flag) + { + case 1: + mio_symbol_ref (&e->value.function.esym); + break; + case 2: + mio_ref_list (&e->ref); + break; + case 3: + break; + default: + write_atom (ATOM_STRING, e->value.function.isym->name); + } + } + else + { + require_atom (ATOM_STRING); + if (atom_string[0] == '\0') + e->value.function.name = NULL; + else + e->value.function.name = gfc_get_string ("%s", atom_string); + free (atom_string); + + mio_integer (&flag); + switch (flag) + { + case 1: + mio_symbol_ref (&e->value.function.esym); + break; + case 2: + mio_ref_list (&e->ref); + break; + case 3: + break; + default: + require_atom (ATOM_STRING); + e->value.function.isym = gfc_find_function (atom_string); + free (atom_string); + } + } + + break; + + case EXPR_VARIABLE: + mio_symtree_ref (&e->symtree); + mio_ref_list (&e->ref); + break; + + case EXPR_SUBSTRING: + e->value.character.string + = CONST_CAST (gfc_char_t *, + mio_allocated_wide_string (e->value.character.string, + e->value.character.length)); + mio_ref_list (&e->ref); + break; + + case EXPR_STRUCTURE: + case EXPR_ARRAY: + mio_constructor (&e->value.constructor); + mio_shape (&e->shape, e->rank); + break; + + case EXPR_CONSTANT: + switch (e->ts.type) + { + case BT_INTEGER: + mio_gmp_integer (&e->value.integer); + break; + + case BT_REAL: + gfc_set_model_kind (e->ts.kind); + mio_gmp_real (&e->value.real); + break; + + case BT_COMPLEX: + gfc_set_model_kind (e->ts.kind); + mio_gmp_real (&mpc_realref (e->value.complex)); + mio_gmp_real (&mpc_imagref (e->value.complex)); + break; + + case BT_LOGICAL: + mio_integer (&e->value.logical); + break; + + case BT_CHARACTER: + hwi = e->value.character.length; + mio_hwi (&hwi); + e->value.character.length = hwi; + e->value.character.string + = CONST_CAST (gfc_char_t *, + mio_allocated_wide_string (e->value.character.string, + e->value.character.length)); + break; + + default: + bad_module ("Bad type in constant expression"); + } + + break; + + case EXPR_NULL: + break; + + case EXPR_COMPCALL: + case EXPR_PPC: + case EXPR_UNKNOWN: + gcc_unreachable (); + break; + } + + /* PDT types store the expression specification list here. */ + mio_actual_arglist (&e->param_list, true); + + mio_rparen (); +} + + +/* Read and write namelists. */ + +static void +mio_namelist (gfc_symbol *sym) +{ + gfc_namelist *n, *m; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + for (n = sym->namelist; n; n = n->next) + mio_symbol_ref (&n->sym); + } + else + { + m = NULL; + while (peek_atom () != ATOM_RPAREN) + { + n = gfc_get_namelist (); + mio_symbol_ref (&n->sym); + + if (sym->namelist == NULL) + sym->namelist = n; + else + m->next = n; + + m = n; + } + sym->namelist_tail = m; + } + + mio_rparen (); +} + + +/* Save/restore lists of gfc_interface structures. When loading an + interface, we are really appending to the existing list of + interfaces. Checking for duplicate and ambiguous interfaces has to + be done later when all symbols have been loaded. */ + +pointer_info * +mio_interface_rest (gfc_interface **ip) +{ + gfc_interface *tail, *p; + pointer_info *pi = NULL; + + if (iomode == IO_OUTPUT) + { + if (ip != NULL) + for (p = *ip; p; p = p->next) + mio_symbol_ref (&p->sym); + } + else + { + if (*ip == NULL) + tail = NULL; + else + { + tail = *ip; + while (tail->next) + tail = tail->next; + } + + for (;;) + { + if (peek_atom () == ATOM_RPAREN) + break; + + p = gfc_get_interface (); + p->where = gfc_current_locus; + pi = mio_symbol_ref (&p->sym); + + if (tail == NULL) + *ip = p; + else + tail->next = p; + + tail = p; + } + } + + mio_rparen (); + return pi; +} + + +/* Save/restore a nameless operator interface. */ + +static void +mio_interface (gfc_interface **ip) +{ + mio_lparen (); + mio_interface_rest (ip); +} + + +/* Save/restore a named operator interface. */ + +static void +mio_symbol_interface (const char **name, const char **module, + gfc_interface **ip) +{ + mio_lparen (); + mio_pool_string (name); + mio_pool_string (module); + mio_interface_rest (ip); +} + + +static void +mio_namespace_ref (gfc_namespace **nsp) +{ + gfc_namespace *ns; + pointer_info *p; + + p = mio_pointer_ref (nsp); + + if (p->type == P_UNKNOWN) + p->type = P_NAMESPACE; + + if (iomode == IO_INPUT && p->integer != 0) + { + ns = (gfc_namespace *) p->u.pointer; + if (ns == NULL) + { + ns = gfc_get_namespace (NULL, 0); + associate_integer_pointer (p, ns); + } + else + ns->refs++; + } +} + + +/* Save/restore the f2k_derived namespace of a derived-type symbol. */ + +static gfc_namespace* current_f2k_derived; + +static void +mio_typebound_proc (gfc_typebound_proc** proc) +{ + int flag; + int overriding_flag; + + if (iomode == IO_INPUT) + { + *proc = gfc_get_typebound_proc (NULL); + (*proc)->where = gfc_current_locus; + } + gcc_assert (*proc); + + mio_lparen (); + + (*proc)->access = MIO_NAME (gfc_access) ((*proc)->access, access_types); + + /* IO the NON_OVERRIDABLE/DEFERRED combination. */ + gcc_assert (!((*proc)->deferred && (*proc)->non_overridable)); + overriding_flag = ((*proc)->deferred << 1) | (*proc)->non_overridable; + overriding_flag = mio_name (overriding_flag, binding_overriding); + (*proc)->deferred = ((overriding_flag & 2) != 0); + (*proc)->non_overridable = ((overriding_flag & 1) != 0); + gcc_assert (!((*proc)->deferred && (*proc)->non_overridable)); + + (*proc)->nopass = mio_name ((*proc)->nopass, binding_passing); + (*proc)->is_generic = mio_name ((*proc)->is_generic, binding_generic); + (*proc)->ppc = mio_name((*proc)->ppc, binding_ppc); + + mio_pool_string (&((*proc)->pass_arg)); + + flag = (int) (*proc)->pass_arg_num; + mio_integer (&flag); + (*proc)->pass_arg_num = (unsigned) flag; + + if ((*proc)->is_generic) + { + gfc_tbp_generic* g; + int iop; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + for (g = (*proc)->u.generic; g; g = g->next) + { + iop = (int) g->is_operator; + mio_integer (&iop); + mio_allocated_string (g->specific_st->name); + } + else + { + (*proc)->u.generic = NULL; + while (peek_atom () != ATOM_RPAREN) + { + gfc_symtree** sym_root; + + g = gfc_get_tbp_generic (); + g->specific = NULL; + + mio_integer (&iop); + g->is_operator = (bool) iop; + + require_atom (ATOM_STRING); + sym_root = ¤t_f2k_derived->tb_sym_root; + g->specific_st = gfc_get_tbp_symtree (sym_root, atom_string); + free (atom_string); + + g->next = (*proc)->u.generic; + (*proc)->u.generic = g; + } + } + + mio_rparen (); + } + else if (!(*proc)->ppc) + mio_symtree_ref (&(*proc)->u.specific); + + mio_rparen (); +} + +/* Walker-callback function for this purpose. */ +static void +mio_typebound_symtree (gfc_symtree* st) +{ + if (iomode == IO_OUTPUT && !st->n.tb) + return; + + if (iomode == IO_OUTPUT) + { + mio_lparen (); + mio_allocated_string (st->name); + } + /* For IO_INPUT, the above is done in mio_f2k_derived. */ + + mio_typebound_proc (&st->n.tb); + mio_rparen (); +} + +/* IO a full symtree (in all depth). */ +static void +mio_full_typebound_tree (gfc_symtree** root) +{ + mio_lparen (); + + if (iomode == IO_OUTPUT) + gfc_traverse_symtree (*root, &mio_typebound_symtree); + else + { + while (peek_atom () == ATOM_LPAREN) + { + gfc_symtree* st; + + mio_lparen (); + + require_atom (ATOM_STRING); + st = gfc_get_tbp_symtree (root, atom_string); + free (atom_string); + + mio_typebound_symtree (st); + } + } + + mio_rparen (); +} + +static void +mio_finalizer (gfc_finalizer **f) +{ + if (iomode == IO_OUTPUT) + { + gcc_assert (*f); + gcc_assert ((*f)->proc_tree); /* Should already be resolved. */ + mio_symtree_ref (&(*f)->proc_tree); + } + else + { + *f = gfc_get_finalizer (); + (*f)->where = gfc_current_locus; /* Value should not matter. */ + (*f)->next = NULL; + + mio_symtree_ref (&(*f)->proc_tree); + (*f)->proc_sym = NULL; + } +} + +static void +mio_f2k_derived (gfc_namespace *f2k) +{ + current_f2k_derived = f2k; + + /* Handle the list of finalizer procedures. */ + mio_lparen (); + if (iomode == IO_OUTPUT) + { + gfc_finalizer *f; + for (f = f2k->finalizers; f; f = f->next) + mio_finalizer (&f); + } + else + { + f2k->finalizers = NULL; + while (peek_atom () != ATOM_RPAREN) + { + gfc_finalizer *cur = NULL; + mio_finalizer (&cur); + cur->next = f2k->finalizers; + f2k->finalizers = cur; + } + } + mio_rparen (); + + /* Handle type-bound procedures. */ + mio_full_typebound_tree (&f2k->tb_sym_root); + + /* Type-bound user operators. */ + mio_full_typebound_tree (&f2k->tb_uop_root); + + /* Type-bound intrinsic operators. */ + mio_lparen (); + if (iomode == IO_OUTPUT) + { + int op; + for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op) + { + gfc_intrinsic_op realop; + + if (op == INTRINSIC_USER || !f2k->tb_op[op]) + continue; + + mio_lparen (); + realop = (gfc_intrinsic_op) op; + mio_intrinsic_op (&realop); + mio_typebound_proc (&f2k->tb_op[op]); + mio_rparen (); + } + } + else + while (peek_atom () != ATOM_RPAREN) + { + gfc_intrinsic_op op = GFC_INTRINSIC_BEGIN; /* Silence GCC. */ + + mio_lparen (); + mio_intrinsic_op (&op); + mio_typebound_proc (&f2k->tb_op[op]); + mio_rparen (); + } + mio_rparen (); +} + +static void +mio_full_f2k_derived (gfc_symbol *sym) +{ + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + if (sym->f2k_derived) + mio_f2k_derived (sym->f2k_derived); + } + else + { + if (peek_atom () != ATOM_RPAREN) + { + gfc_namespace *ns; + + sym->f2k_derived = gfc_get_namespace (NULL, 0); + + /* PDT templates make use of the mechanisms for formal args + and so the parameter symbols are stored in the formal + namespace. Transfer the sym_root to f2k_derived and then + free the formal namespace since it is uneeded. */ + if (sym->attr.pdt_template && sym->formal && sym->formal->sym) + { + ns = sym->formal->sym->ns; + sym->f2k_derived->sym_root = ns->sym_root; + ns->sym_root = NULL; + ns->refs++; + gfc_free_namespace (ns); + ns = NULL; + } + + mio_f2k_derived (sym->f2k_derived); + } + else + gcc_assert (!sym->f2k_derived); + } + + mio_rparen (); +} + +static const mstring omp_declare_simd_clauses[] = +{ + minit ("INBRANCH", 0), + minit ("NOTINBRANCH", 1), + minit ("SIMDLEN", 2), + minit ("UNIFORM", 3), + minit ("LINEAR", 4), + minit ("ALIGNED", 5), + minit ("LINEAR_REF", 33), + minit ("LINEAR_VAL", 34), + minit ("LINEAR_UVAL", 35), + minit (NULL, -1) +}; + +/* Handle !$omp declare simd. */ + +static void +mio_omp_declare_simd (gfc_namespace *ns, gfc_omp_declare_simd **odsp) +{ + if (iomode == IO_OUTPUT) + { + if (*odsp == NULL) + return; + } + else if (peek_atom () != ATOM_LPAREN) + return; + + gfc_omp_declare_simd *ods = *odsp; + + mio_lparen (); + if (iomode == IO_OUTPUT) + { + write_atom (ATOM_NAME, "OMP_DECLARE_SIMD"); + if (ods->clauses) + { + gfc_omp_namelist *n; + + if (ods->clauses->inbranch) + mio_name (0, omp_declare_simd_clauses); + if (ods->clauses->notinbranch) + mio_name (1, omp_declare_simd_clauses); + if (ods->clauses->simdlen_expr) + { + mio_name (2, omp_declare_simd_clauses); + mio_expr (&ods->clauses->simdlen_expr); + } + for (n = ods->clauses->lists[OMP_LIST_UNIFORM]; n; n = n->next) + { + mio_name (3, omp_declare_simd_clauses); + mio_symbol_ref (&n->sym); + } + for (n = ods->clauses->lists[OMP_LIST_LINEAR]; n; n = n->next) + { + if (n->u.linear_op == OMP_LINEAR_DEFAULT) + mio_name (4, omp_declare_simd_clauses); + else + mio_name (32 + n->u.linear_op, omp_declare_simd_clauses); + mio_symbol_ref (&n->sym); + mio_expr (&n->expr); + } + for (n = ods->clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next) + { + mio_name (5, omp_declare_simd_clauses); + mio_symbol_ref (&n->sym); + mio_expr (&n->expr); + } + } + } + else + { + gfc_omp_namelist **ptrs[3] = { NULL, NULL, NULL }; + + require_atom (ATOM_NAME); + *odsp = ods = gfc_get_omp_declare_simd (); + ods->where = gfc_current_locus; + ods->proc_name = ns->proc_name; + if (peek_atom () == ATOM_NAME) + { + ods->clauses = gfc_get_omp_clauses (); + ptrs[0] = &ods->clauses->lists[OMP_LIST_UNIFORM]; + ptrs[1] = &ods->clauses->lists[OMP_LIST_LINEAR]; + ptrs[2] = &ods->clauses->lists[OMP_LIST_ALIGNED]; + } + while (peek_atom () == ATOM_NAME) + { + gfc_omp_namelist *n; + int t = mio_name (0, omp_declare_simd_clauses); + + switch (t) + { + case 0: ods->clauses->inbranch = true; break; + case 1: ods->clauses->notinbranch = true; break; + case 2: mio_expr (&ods->clauses->simdlen_expr); break; + case 3: + case 4: + case 5: + *ptrs[t - 3] = n = gfc_get_omp_namelist (); + finish_namelist: + n->where = gfc_current_locus; + ptrs[t - 3] = &n->next; + mio_symbol_ref (&n->sym); + if (t != 3) + mio_expr (&n->expr); + break; + case 33: + case 34: + case 35: + *ptrs[1] = n = gfc_get_omp_namelist (); + n->u.linear_op = (enum gfc_omp_linear_op) (t - 32); + t = 4; + goto finish_namelist; + } + } + } + + mio_omp_declare_simd (ns, &ods->next); + + mio_rparen (); +} + + +static const mstring omp_declare_reduction_stmt[] = +{ + minit ("ASSIGN", 0), + minit ("CALL", 1), + minit (NULL, -1) +}; + + +static void +mio_omp_udr_expr (gfc_omp_udr *udr, gfc_symbol **sym1, gfc_symbol **sym2, + gfc_namespace *ns, bool is_initializer) +{ + if (iomode == IO_OUTPUT) + { + if ((*sym1)->module == NULL) + { + (*sym1)->module = module_name; + (*sym2)->module = module_name; + } + mio_symbol_ref (sym1); + mio_symbol_ref (sym2); + if (ns->code->op == EXEC_ASSIGN) + { + mio_name (0, omp_declare_reduction_stmt); + mio_expr (&ns->code->expr1); + mio_expr (&ns->code->expr2); + } + else + { + int flag; + mio_name (1, omp_declare_reduction_stmt); + mio_symtree_ref (&ns->code->symtree); + mio_actual_arglist (&ns->code->ext.actual, false); + + flag = ns->code->resolved_isym != NULL; + mio_integer (&flag); + if (flag) + write_atom (ATOM_STRING, ns->code->resolved_isym->name); + else + mio_symbol_ref (&ns->code->resolved_sym); + } + } + else + { + pointer_info *p1 = mio_symbol_ref (sym1); + pointer_info *p2 = mio_symbol_ref (sym2); + gfc_symbol *sym; + gcc_assert (p1->u.rsym.ns == p2->u.rsym.ns); + gcc_assert (p1->u.rsym.sym == NULL); + /* Add hidden symbols to the symtree. */ + pointer_info *q = get_integer (p1->u.rsym.ns); + q->u.pointer = (void *) ns; + sym = gfc_new_symbol (is_initializer ? "omp_priv" : "omp_out", ns); + sym->ts = udr->ts; + sym->module = gfc_get_string ("%s", p1->u.rsym.module); + associate_integer_pointer (p1, sym); + sym->attr.omp_udr_artificial_var = 1; + gcc_assert (p2->u.rsym.sym == NULL); + sym = gfc_new_symbol (is_initializer ? "omp_orig" : "omp_in", ns); + sym->ts = udr->ts; + sym->module = gfc_get_string ("%s", p2->u.rsym.module); + associate_integer_pointer (p2, sym); + sym->attr.omp_udr_artificial_var = 1; + if (mio_name (0, omp_declare_reduction_stmt) == 0) + { + ns->code = gfc_get_code (EXEC_ASSIGN); + mio_expr (&ns->code->expr1); + mio_expr (&ns->code->expr2); + } + else + { + int flag; + ns->code = gfc_get_code (EXEC_CALL); + mio_symtree_ref (&ns->code->symtree); + mio_actual_arglist (&ns->code->ext.actual, false); + + mio_integer (&flag); + if (flag) + { + require_atom (ATOM_STRING); + ns->code->resolved_isym = gfc_find_subroutine (atom_string); + free (atom_string); + } + else + mio_symbol_ref (&ns->code->resolved_sym); + } + ns->code->loc = gfc_current_locus; + ns->omp_udr_ns = 1; + } +} + + +/* Unlike most other routines, the address of the symbol node is already + fixed on input and the name/module has already been filled in. + If you update the symbol format here, don't forget to update read_module + as well (look for "seek to the symbol's component list"). */ + +static void +mio_symbol (gfc_symbol *sym) +{ + int intmod = INTMOD_NONE; + + mio_lparen (); + + mio_symbol_attribute (&sym->attr); + + if (sym->attr.pdt_type) + sym->name = gfc_dt_upper_string (sym->name); + + /* Note that components are always saved, even if they are supposed + to be private. Component access is checked during searching. */ + mio_component_list (&sym->components, sym->attr.vtype); + if (sym->components != NULL) + sym->component_access + = MIO_NAME (gfc_access) (sym->component_access, access_types); + + mio_typespec (&sym->ts); + if (sym->ts.type == BT_CLASS) + sym->attr.class_ok = 1; + + if (iomode == IO_OUTPUT) + mio_namespace_ref (&sym->formal_ns); + else + { + mio_namespace_ref (&sym->formal_ns); + if (sym->formal_ns) + sym->formal_ns->proc_name = sym; + } + + /* Save/restore common block links. */ + mio_symbol_ref (&sym->common_next); + + mio_formal_arglist (&sym->formal); + + if (sym->attr.flavor == FL_PARAMETER) + mio_expr (&sym->value); + + mio_array_spec (&sym->as); + + mio_symbol_ref (&sym->result); + + if (sym->attr.cray_pointee) + mio_symbol_ref (&sym->cp_pointer); + + /* Load/save the f2k_derived namespace of a derived-type symbol. */ + mio_full_f2k_derived (sym); + + /* PDT types store the symbol specification list here. */ + mio_actual_arglist (&sym->param_list, true); + + 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); + if (current_intmod) + sym->from_intmod = current_intmod; + else + sym->from_intmod = (intmod_id) intmod; + } + + mio_integer (&(sym->intmod_sym_id)); + + if (gfc_fl_struct (sym->attr.flavor)) + mio_integer (&(sym->hash_value)); + + if (sym->formal_ns + && sym->formal_ns->proc_name == sym + && sym->formal_ns->entries == NULL) + mio_omp_declare_simd (sym->formal_ns, &sym->formal_ns->omp_declare_simd); + + mio_rparen (); +} + + +/************************* Top level subroutines *************************/ + +/* A recursive function to look for a specific symbol by name and by + module. Whilst several symtrees might point to one symbol, its + is sufficient for the purposes here than one exist. Note that + generic interfaces are distinguished as are symbols that have been + renamed in another module. */ +static gfc_symtree * +find_symbol (gfc_symtree *st, const char *name, + const char *module, int generic) +{ + int c; + gfc_symtree *retval, *s; + + if (st == NULL || st->n.sym == NULL) + return NULL; + + c = strcmp (name, st->n.sym->name); + if (c == 0 && st->n.sym->module + && strcmp (module, st->n.sym->module) == 0 + && !check_unique_name (st->name)) + { + s = gfc_find_symtree (gfc_current_ns->sym_root, name); + + /* Detect symbols that are renamed by use association in another + module by the absence of a symtree and null attr.use_rename, + since the latter is not transmitted in the module file. */ + if (((!generic && !st->n.sym->attr.generic) + || (generic && st->n.sym->attr.generic)) + && !(s == NULL && !st->n.sym->attr.use_rename)) + return st; + } + + retval = find_symbol (st->left, name, module, generic); + + if (retval == NULL) + retval = find_symbol (st->right, name, module, generic); + + return retval; +} + + +/* Skip a list between balanced left and right parens. + By setting NEST_LEVEL one assumes that a number of NEST_LEVEL opening parens + have been already parsed by hand, and the remaining of the content is to be + skipped here. The default value is 0 (balanced parens). */ + +static void +skip_list (int nest_level = 0) +{ + int level; + + level = nest_level; + do + { + switch (parse_atom ()) + { + case ATOM_LPAREN: + level++; + break; + + case ATOM_RPAREN: + level--; + break; + + case ATOM_STRING: + free (atom_string); + break; + + case ATOM_NAME: + case ATOM_INTEGER: + break; + } + } + while (level > 0); +} + + +/* Load operator interfaces from the module. Interfaces are unusual + in that they attach themselves to existing symbols. */ + +static void +load_operator_interfaces (void) +{ + const char *p; + /* "module" must be large enough for the case of submodules in which the name + has the form module.submodule */ + char name[GFC_MAX_SYMBOL_LEN + 1], module[2 * GFC_MAX_SYMBOL_LEN + 2]; + gfc_user_op *uop; + pointer_info *pi = NULL; + int n, i; + + mio_lparen (); + + while (peek_atom () != ATOM_RPAREN) + { + mio_lparen (); + + mio_internal_string (name); + mio_internal_string (module); + + n = number_use_names (name, true); + 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, true); + + if (p == NULL) + { + while (parse_atom () != ATOM_RPAREN); + continue; + } + + if (i == 1) + { + uop = gfc_get_uop (p); + pi = mio_interface_rest (&uop->op); + } + else + { + if (gfc_find_uop (p, NULL)) + continue; + uop = gfc_get_uop (p); + uop->op = gfc_get_interface (); + uop->op->where = gfc_current_locus; + add_fixup (pi->integer, &uop->op->sym); + } + } + } + + mio_rparen (); +} + + +/* Load interfaces from the module. Interfaces are unusual in that + they attach themselves to existing symbols. */ + +static void +load_generic_interfaces (void) +{ + const char *p; + /* "module" must be large enough for the case of submodules in which the name + has the form module.submodule */ + char name[GFC_MAX_SYMBOL_LEN + 1], module[2 * GFC_MAX_SYMBOL_LEN + 2]; + gfc_symbol *sym; + gfc_interface *generic = NULL, *gen = NULL; + int n, i, renamed; + bool ambiguous_set = false; + + mio_lparen (); + + while (peek_atom () != ATOM_RPAREN) + { + mio_lparen (); + + mio_internal_string (name); + mio_internal_string (module); + + n = number_use_names (name, false); + renamed = n ? 1 : 0; + n = n ? n : 1; + + for (i = 1; i <= n; i++) + { + gfc_symtree *st; + /* Decide if we need to load this one or not. */ + p = find_use_name_n (name, &i, false); + + if (!p || gfc_find_symbol (p, NULL, 0, &sym)) + { + /* Skip the specific names for these cases. */ + while (i == 1 && parse_atom () != ATOM_RPAREN); + + continue; + } + + st = find_symbol (gfc_current_ns->sym_root, + name, module_name, 1); + + /* If the symbol exists already and is being USEd without being + in an ONLY clause, do not load a new symtree(11.3.2). */ + if (!only_flag && st) + sym = st->n.sym; + + if (!sym) + { + if (st) + { + sym = st->n.sym; + if (strcmp (st->name, p) != 0) + { + st = gfc_new_symtree (&gfc_current_ns->sym_root, p); + st->n.sym = sym; + sym->refs++; + } + } + + /* Since we haven't found a valid generic interface, we had + better make one. */ + if (!sym) + { + gfc_get_symbol (p, NULL, &sym); + sym->name = gfc_get_string ("%s", name); + sym->module = module_name; + sym->attr.flavor = FL_PROCEDURE; + sym->attr.generic = 1; + sym->attr.use_assoc = 1; + } + } + else + { + /* Unless sym is a generic interface, this reference + is ambiguous. */ + if (st == NULL) + st = gfc_find_symtree (gfc_current_ns->sym_root, p); + + sym = st->n.sym; + + if (st && !sym->attr.generic + && !st->ambiguous + && sym->module + && strcmp (module, sym->module)) + { + ambiguous_set = true; + st->ambiguous = 1; + } + } + + sym->attr.use_only = only_flag; + sym->attr.use_rename = renamed; + + if (i == 1) + { + mio_interface_rest (&sym->generic); + generic = sym->generic; + } + else if (!sym->generic) + { + sym->generic = generic; + sym->attr.generic_copy = 1; + } + + /* If a procedure that is not generic has generic interfaces + that include itself, it is generic! We need to take care + to retain symbols ambiguous that were already so. */ + if (sym->attr.use_assoc + && !sym->attr.generic + && sym->attr.flavor == FL_PROCEDURE) + { + for (gen = generic; gen; gen = gen->next) + { + if (gen->sym == sym) + { + sym->attr.generic = 1; + if (ambiguous_set) + st->ambiguous = 0; + break; + } + } + } + + } + } + + mio_rparen (); +} + + +/* Load common blocks. */ + +static void +load_commons (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_common_head *p; + + mio_lparen (); + + while (peek_atom () != ATOM_RPAREN) + { + int flags = 0; + char* label; + mio_lparen (); + mio_internal_string (name); + + p = gfc_get_common (name, 1); + + mio_symbol_ref (&p->head); + mio_integer (&flags); + if (flags & 1) + p->saved = 1; + if (flags & 2) + p->threadprivate = 1; + p->omp_device_type = (gfc_omp_device_type) ((flags >> 2) & 3); + p->use_assoc = 1; + + /* Get whether this was a bind(c) common or not. */ + mio_integer (&p->is_bind_c); + /* Get the binding label. */ + label = read_string (); + if (strlen (label)) + p->binding_label = IDENTIFIER_POINTER (get_identifier (label)); + XDELETEVEC (label); + + mio_rparen (); + } + + mio_rparen (); +} + + +/* 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) +{ + gfc_equiv *head, *tail, *end, *eq, *equiv; + bool duplicate; + + mio_lparen (); + in_load_equiv = true; + + end = gfc_current_ns->equiv; + while (end != NULL && end->next != NULL) + end = end->next; + + while (peek_atom () != ATOM_RPAREN) { + mio_lparen (); + head = tail = NULL; + + while(peek_atom () != ATOM_RPAREN) + { + if (head == NULL) + head = tail = gfc_get_equiv (); + else + { + tail->eq = gfc_get_equiv (); + tail = tail->eq; + } + + mio_pool_string (&tail->module); + mio_expr (&tail->expr); + } + + /* Check for duplicate equivalences being loaded from different modules */ + duplicate = false; + for (equiv = gfc_current_ns->equiv; equiv; equiv = equiv->next) + { + if (equiv->module && head->module + && strcmp (equiv->module, head->module) == 0) + { + duplicate = true; + break; + } + } + + if (duplicate) + { + for (eq = head; eq; eq = head) + { + head = eq->eq; + gfc_free_expr (eq->expr); + free (eq); + } + } + + if (end == NULL) + gfc_current_ns->equiv = head; + else + end->next = head; + + if (head != NULL) + end = head; + + mio_rparen (); + } + + mio_rparen (); + in_load_equiv = false; +} + + +/* This function loads OpenMP user defined reductions. */ +static void +load_omp_udrs (void) +{ + mio_lparen (); + while (peek_atom () != ATOM_RPAREN) + { + const char *name = NULL, *newname; + char *altname; + gfc_typespec ts; + gfc_symtree *st; + gfc_omp_reduction_op rop = OMP_REDUCTION_USER; + + mio_lparen (); + mio_pool_string (&name); + gfc_clear_ts (&ts); + mio_typespec (&ts); + if (startswith (name, "operator ")) + { + const char *p = name + sizeof ("operator ") - 1; + if (strcmp (p, "+") == 0) + rop = OMP_REDUCTION_PLUS; + else if (strcmp (p, "*") == 0) + rop = OMP_REDUCTION_TIMES; + else if (strcmp (p, "-") == 0) + rop = OMP_REDUCTION_MINUS; + else if (strcmp (p, ".and.") == 0) + rop = OMP_REDUCTION_AND; + else if (strcmp (p, ".or.") == 0) + rop = OMP_REDUCTION_OR; + else if (strcmp (p, ".eqv.") == 0) + rop = OMP_REDUCTION_EQV; + else if (strcmp (p, ".neqv.") == 0) + rop = OMP_REDUCTION_NEQV; + } + altname = NULL; + if (rop == OMP_REDUCTION_USER && name[0] == '.') + { + size_t len = strlen (name + 1); + altname = XALLOCAVEC (char, len); + gcc_assert (name[len] == '.'); + memcpy (altname, name + 1, len - 1); + altname[len - 1] = '\0'; + } + newname = name; + if (rop == OMP_REDUCTION_USER) + newname = find_use_name (altname ? altname : name, !!altname); + else if (only_flag && find_use_operator ((gfc_intrinsic_op) rop) == NULL) + newname = NULL; + if (newname == NULL) + { + skip_list (1); + continue; + } + if (altname && newname != altname) + { + size_t len = strlen (newname); + altname = XALLOCAVEC (char, len + 3); + altname[0] = '.'; + memcpy (altname + 1, newname, len); + altname[len + 1] = '.'; + altname[len + 2] = '\0'; + name = gfc_get_string ("%s", altname); + } + st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name); + gfc_omp_udr *udr = gfc_omp_udr_find (st, &ts); + if (udr) + { + require_atom (ATOM_INTEGER); + pointer_info *p = get_integer (atom_int); + if (strcmp (p->u.rsym.module, udr->omp_out->module)) + { + gfc_error ("Ambiguous !$OMP DECLARE REDUCTION from " + "module %s at %L", + p->u.rsym.module, &gfc_current_locus); + gfc_error ("Previous !$OMP DECLARE REDUCTION from module " + "%s at %L", + udr->omp_out->module, &udr->where); + } + skip_list (1); + continue; + } + udr = gfc_get_omp_udr (); + udr->name = name; + udr->rop = rop; + udr->ts = ts; + udr->where = gfc_current_locus; + udr->combiner_ns = gfc_get_namespace (gfc_current_ns, 1); + udr->combiner_ns->proc_name = gfc_current_ns->proc_name; + mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns, + false); + if (peek_atom () != ATOM_RPAREN) + { + udr->initializer_ns = gfc_get_namespace (gfc_current_ns, 1); + udr->initializer_ns->proc_name = gfc_current_ns->proc_name; + mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig, + udr->initializer_ns, true); + } + if (st) + { + udr->next = st->n.omp_udr; + st->n.omp_udr = udr; + } + else + { + st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name); + st->n.omp_udr = udr; + } + mio_rparen (); + } + mio_rparen (); +} + + +/* 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. */ + +static int +load_needed (pointer_info *p) +{ + gfc_namespace *ns; + pointer_info *q; + gfc_symbol *sym; + int rv; + + rv = 0; + if (p == NULL) + return rv; + + rv |= load_needed (p->left); + rv |= load_needed (p->right); + + if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED) + return rv; + + p->u.rsym.state = USED; + + set_module_locus (&p->u.rsym.where); + + sym = p->u.rsym.sym; + if (sym == NULL) + { + q = get_integer (p->u.rsym.ns); + + ns = (gfc_namespace *) q->u.pointer; + if (ns == NULL) + { + /* Create an interface namespace if necessary. These are + the namespaces that hold the formal parameters of module + procedures. */ + + ns = gfc_get_namespace (NULL, 0); + associate_integer_pointer (q, ns); + } + + /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl + doesn't go pear-shaped if the symbol is used. */ + if (!ns->proc_name) + gfc_find_symbol (p->u.rsym.module, gfc_current_ns, + 1, &ns->proc_name); + + sym = gfc_new_symbol (p->u.rsym.true_name, ns); + sym->name = gfc_dt_lower_string (p->u.rsym.true_name); + sym->module = gfc_get_string ("%s", p->u.rsym.module); + if (p->u.rsym.binding_label) + sym->binding_label = IDENTIFIER_POINTER (get_identifier + (p->u.rsym.binding_label)); + + associate_integer_pointer (p, sym); + } + + mio_symbol (sym); + sym->attr.use_assoc = 1; + + /* Unliked derived types, a STRUCTURE may share names with other symbols. + We greedily converted the symbol name to lowercase before we knew its + type, so now we must fix it. */ + if (sym->attr.flavor == FL_STRUCT) + sym->name = gfc_dt_upper_string (sym->name); + + /* Mark as only or rename for later diagnosis for explicitly imported + but not used warnings; don't mark internal symbols such as __vtab, + __def_init etc. Only mark them if they have been explicitly loaded. */ + + if (only_flag && sym->name[0] != '_' && sym->name[1] != '_') + { + gfc_use_rename *u; + + /* Search the use/rename list for the variable; if the variable is + found, mark it. */ + for (u = gfc_rename_list; u; u = u->next) + { + if (strcmp (u->use_name, sym->name) == 0) + { + sym->attr.use_only = 1; + break; + } + } + } + + if (p->u.rsym.renamed) + sym->attr.use_rename = 1; + + return 1; +} + + +/* Recursive function for cleaning up things after a module has been read. */ + +static void +read_cleanup (pointer_info *p) +{ + gfc_symtree *st; + pointer_info *q; + + if (p == NULL) + return; + + read_cleanup (p->left); + read_cleanup (p->right); + + if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced) + { + gfc_namespace *ns; + /* Add hidden symbols to the symtree. */ + q = get_integer (p->u.rsym.ns); + ns = (gfc_namespace *) q->u.pointer; + + if (!p->u.rsym.sym->attr.vtype + && !p->u.rsym.sym->attr.vtab) + st = gfc_get_unique_symtree (ns); + else + { + /* There is no reason to use 'unique_symtrees' for vtabs or + vtypes - their name is fine for a symtree and reduces the + namespace pollution. */ + st = gfc_find_symtree (ns->sym_root, p->u.rsym.sym->name); + if (!st) + st = gfc_new_symtree (&ns->sym_root, p->u.rsym.sym->name); + } + + st->n.sym = p->u.rsym.sym; + st->n.sym->refs++; + + /* Fixup any symtree references. */ + p->u.rsym.symtree = st; + resolve_fixups (p->u.rsym.stfixup, st); + p->u.rsym.stfixup = NULL; + } + + /* Free unused symbols. */ + if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED) + gfc_free_symbol (p->u.rsym.sym); +} + + +/* It is not quite enough to check for ambiguity in the symbols by + the loaded symbol and the new symbol not being identical. */ +static bool +check_for_ambiguous (gfc_symtree *st, pointer_info *info) +{ + gfc_symbol *rsym; + module_locus locus; + symbol_attribute attr; + gfc_symbol *st_sym; + + if (gfc_current_ns->proc_name && st->name == gfc_current_ns->proc_name->name) + { + gfc_error ("%qs of module %qs, imported at %C, is also the name of the " + "current program unit", st->name, module_name); + return true; + } + + st_sym = st->n.sym; + rsym = info->u.rsym.sym; + if (st_sym == rsym) + return false; + + if (st_sym->attr.vtab || st_sym->attr.vtype) + return false; + + /* If the existing symbol is generic from a different module and + the new symbol is generic there can be no ambiguity. */ + if (st_sym->attr.generic + && st_sym->module + && st_sym->module != module_name) + { + /* The new symbol's attributes have not yet been read. Since + we need attr.generic, read it directly. */ + get_module_locus (&locus); + set_module_locus (&info->u.rsym.where); + mio_lparen (); + attr.generic = 0; + mio_symbol_attribute (&attr); + set_module_locus (&locus); + if (attr.generic) + return false; + } + + return true; +} + + +/* Read a module file. */ + +static void +read_module (void) +{ + module_locus operator_interfaces, user_operators, omp_udrs; + const char *p; + char name[GFC_MAX_SYMBOL_LEN + 1]; + int i; + /* Workaround -Wmaybe-uninitialized false positive during + profiledbootstrap by initializing them. */ + int ambiguous = 0, j, nuse, symbol = 0; + pointer_info *info, *q; + gfc_use_rename *u = NULL; + gfc_symtree *st; + gfc_symbol *sym; + + get_module_locus (&operator_interfaces); /* Skip these for now. */ + skip_list (); + + get_module_locus (&user_operators); + skip_list (); + skip_list (); + + /* Skip commons and equivalences for now. */ + skip_list (); + skip_list (); + + /* Skip OpenMP UDRs. */ + get_module_locus (&omp_udrs); + skip_list (); + + mio_lparen (); + + /* Create the fixup nodes for all the symbols. */ + + while (peek_atom () != ATOM_RPAREN) + { + char* bind_label; + require_atom (ATOM_INTEGER); + info = get_integer (atom_int); + + info->type = P_SYMBOL; + info->u.rsym.state = UNUSED; + + info->u.rsym.true_name = read_string (); + info->u.rsym.module = read_string (); + bind_label = read_string (); + if (strlen (bind_label)) + info->u.rsym.binding_label = bind_label; + else + XDELETEVEC (bind_label); + + require_atom (ATOM_INTEGER); + info->u.rsym.ns = atom_int; + + get_module_locus (&info->u.rsym.where); + + /* See if the symbol has already been loaded by a previous module. + If so, we reference the existing symbol and prevent it from + being loaded again. This should not happen if the symbol being + read is an index for an assumed shape dummy array (ns != 1). */ + + sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module); + + if (sym == NULL + || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1)) + { + skip_list (); + continue; + } + + info->u.rsym.state = USED; + info->u.rsym.sym = sym; + /* The current symbol has already been loaded, so we can avoid loading + it again. However, if it is a derived type, some of its components + can be used in expressions in the module. To avoid the module loading + failing, we need to associate the module's component pointer indexes + with the existing symbol's component pointers. */ + if (gfc_fl_struct (sym->attr.flavor)) + { + gfc_component *c; + + /* First seek to the symbol's component list. */ + mio_lparen (); /* symbol opening. */ + skip_list (); /* skip symbol attribute. */ + + mio_lparen (); /* component list opening. */ + for (c = sym->components; c; c = c->next) + { + pointer_info *p; + const char *comp_name = NULL; + int n = 0; + + mio_lparen (); /* component opening. */ + mio_integer (&n); + p = get_integer (n); + if (p->u.pointer == NULL) + associate_integer_pointer (p, c); + mio_pool_string (&comp_name); + if (comp_name != c->name) + { + gfc_fatal_error ("Mismatch in components of derived type " + "%qs from %qs at %C: expecting %qs, " + "but got %qs", sym->name, sym->module, + c->name, comp_name); + } + skip_list (1); /* component end. */ + } + mio_rparen (); /* component list closing. */ + + skip_list (1); /* symbol end. */ + } + else + skip_list (); + + /* 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; + } + } + + mio_rparen (); + + /* Parse the symtree lists. This lets us mark which symbols need to + be loaded. Renaming is also done at this point by replacing the + symtree name. */ + + mio_lparen (); + + while (peek_atom () != ATOM_RPAREN) + { + mio_internal_string (name); + mio_integer (&ambiguous); + mio_integer (&symbol); + + info = get_integer (symbol); + + /* See how many use names there are. If none, go through the start + of the loop at least once. */ + nuse = number_use_names (name, false); + info->u.rsym.renamed = nuse ? 1 : 0; + + 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, false); + + if (p == NULL && strcmp (name, module_name) == 0) + p = name; + + /* Exception: Always import vtabs & vtypes. */ + if (p == NULL && name[0] == '_' + && (startswith (name, "__vtab_") + || startswith (name, "__vtype_"))) + p = name; + + /* Skip symtree nodes not in an ONLY clause, unless there + is an existing symtree loaded from another USE statement. */ + if (p == NULL) + { + st = gfc_find_symtree (gfc_current_ns->sym_root, name); + if (st != NULL + && strcmp (st->n.sym->name, info->u.rsym.true_name) == 0 + && st->n.sym->module != NULL + && strcmp (st->n.sym->module, info->u.rsym.module) == 0) + { + info->u.rsym.symtree = st; + info->u.rsym.sym = st->n.sym; + } + continue; + } + + /* If a symbol of the same name and module exists already, + this symbol, which is not in an ONLY clause, must not be + added to the namespace(11.3.2). Note that find_symbol + only returns the first occurrence that it finds. */ + if (!only_flag && !info->u.rsym.renamed + && strcmp (name, module_name) != 0 + && find_symbol (gfc_current_ns->sym_root, name, + module_name, 0)) + continue; + + st = gfc_find_symtree (gfc_current_ns->sym_root, p); + + if (st != NULL + && !(st->n.sym && st->n.sym->attr.used_in_submodule)) + { + /* Check for ambiguous symbols. */ + if (check_for_ambiguous (st, info)) + st->ambiguous = 1; + else + info->u.rsym.symtree = st; + } + else + { + if (st) + { + /* This symbol is host associated from a module in a + submodule. Hide it with a unique symtree. */ + gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns); + s->n.sym = st->n.sym; + st->n.sym = NULL; + } + else + { + /* Create a symtree node in the current namespace for this + symbol. */ + st = check_unique_name (p) + ? gfc_get_unique_symtree (gfc_current_ns) + : gfc_new_symtree (&gfc_current_ns->sym_root, p); + st->ambiguous = ambiguous; + } + + sym = info->u.rsym.sym; + + /* Create a symbol node if it doesn't already exist. */ + if (sym == NULL) + { + info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name, + gfc_current_ns); + info->u.rsym.sym->name = gfc_dt_lower_string (info->u.rsym.true_name); + sym = info->u.rsym.sym; + sym->module = gfc_get_string ("%s", info->u.rsym.module); + + if (info->u.rsym.binding_label) + { + tree id = get_identifier (info->u.rsym.binding_label); + sym->binding_label = IDENTIFIER_POINTER (id); + } + } + + st->n.sym = sym; + st->n.sym->refs++; + + if (strcmp (name, p) != 0) + sym->attr.use_rename = 1; + + if (name[0] != '_' + || (!startswith (name, "__vtab_") + && !startswith (name, "__vtype_"))) + sym->attr.use_only = only_flag; + + /* Store the symtree pointing to this symbol. */ + info->u.rsym.symtree = st; + + if (info->u.rsym.state == UNUSED) + info->u.rsym.state = NEEDED; + info->u.rsym.referenced = 1; + } + } + } + + mio_rparen (); + + /* Load intrinsic operator interfaces. */ + set_module_locus (&operator_interfaces); + mio_lparen (); + + for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++) + { + gfc_use_rename *u = NULL, *v = NULL; + int j = i; + + if (i == INTRINSIC_USER) + continue; + + if (only_flag) + { + u = find_use_operator ((gfc_intrinsic_op) i); + + /* F2018:10.1.5.5.1 requires same interpretation of old and new-style + relational operators. Special handling for USE, ONLY. */ + switch (i) + { + case INTRINSIC_EQ: + j = INTRINSIC_EQ_OS; + break; + case INTRINSIC_EQ_OS: + j = INTRINSIC_EQ; + break; + case INTRINSIC_NE: + j = INTRINSIC_NE_OS; + break; + case INTRINSIC_NE_OS: + j = INTRINSIC_NE; + break; + case INTRINSIC_GT: + j = INTRINSIC_GT_OS; + break; + case INTRINSIC_GT_OS: + j = INTRINSIC_GT; + break; + case INTRINSIC_GE: + j = INTRINSIC_GE_OS; + break; + case INTRINSIC_GE_OS: + j = INTRINSIC_GE; + break; + case INTRINSIC_LT: + j = INTRINSIC_LT_OS; + break; + case INTRINSIC_LT_OS: + j = INTRINSIC_LT; + break; + case INTRINSIC_LE: + j = INTRINSIC_LE_OS; + break; + case INTRINSIC_LE_OS: + j = INTRINSIC_LE; + break; + default: + break; + } + + if (j != i) + v = find_use_operator ((gfc_intrinsic_op) j); + + if (u == NULL && v == NULL) + { + skip_list (); + continue; + } + + if (u) + u->found = 1; + if (v) + v->found = 1; + } + + mio_interface (&gfc_current_ns->op[i]); + if (!gfc_current_ns->op[i] && !gfc_current_ns->op[j]) + { + if (u) + u->found = 0; + if (v) + v->found = 0; + } + } + + mio_rparen (); + + /* Load generic and user operator interfaces. These must follow the + loading of symtree because otherwise symbols can be marked as + ambiguous. */ + + set_module_locus (&user_operators); + + load_operator_interfaces (); + load_generic_interfaces (); + + load_commons (); + load_equiv (); + + /* Load OpenMP user defined reductions. */ + set_module_locus (&omp_udrs); + load_omp_udrs (); + + /* At this point, we read those symbols that are needed but haven't + been loaded yet. If one symbol requires another, the other gets + marked as NEEDED if its previous state was UNUSED. */ + + while (load_needed (pi_root)); + + /* Make sure all elements of the rename-list were found in the module. */ + + for (u = gfc_rename_list; u; u = u->next) + { + if (u->found) + continue; + + if (u->op == INTRINSIC_NONE) + { + gfc_error ("Symbol %qs referenced at %L not found in module %qs", + u->use_name, &u->where, module_name); + continue; + } + + if (u->op == INTRINSIC_USER) + { + gfc_error ("User operator %qs referenced at %L not found " + "in module %qs", u->use_name, &u->where, module_name); + continue; + } + + gfc_error ("Intrinsic operator %qs referenced at %L not found " + "in module %qs", gfc_op2string (u->op), &u->where, + module_name); + } + + /* Clean up symbol nodes that were never loaded, create references + to hidden symbols. */ + + read_cleanup (pi_root); +} + + +/* Given an access type that is specific to an entity and the default + access, return nonzero if the entity is publicly accessible. If the + element is declared as PUBLIC, then it is public; if declared + PRIVATE, then private, and otherwise it is public unless the default + access in this context has been declared PRIVATE. */ + +static bool dump_smod = false; + +static bool +check_access (gfc_access specific_access, gfc_access default_access) +{ + if (dump_smod) + return true; + + if (specific_access == ACCESS_PUBLIC) + return TRUE; + if (specific_access == ACCESS_PRIVATE) + return FALSE; + + if (flag_module_private) + return default_access == ACCESS_PUBLIC; + else + return default_access != ACCESS_PRIVATE; +} + + +bool +gfc_check_symbol_access (gfc_symbol *sym) +{ + if (sym->attr.vtab || sym->attr.vtype) + return true; + else + return check_access (sym->attr.access, sym->ns->default_access); +} + + +/* A structure to remember which commons we've already written. */ + +struct written_common +{ + BBT_HEADER(written_common); + const char *name, *label; +}; + +static struct written_common *written_commons = NULL; + +/* Comparison function used for balancing the binary tree. */ + +static int +compare_written_commons (void *a1, void *b1) +{ + const char *aname = ((struct written_common *) a1)->name; + const char *alabel = ((struct written_common *) a1)->label; + const char *bname = ((struct written_common *) b1)->name; + const char *blabel = ((struct written_common *) b1)->label; + int c = strcmp (aname, bname); + + return (c != 0 ? c : strcmp (alabel, blabel)); +} + +/* Free a list of written commons. */ + +static void +free_written_common (struct written_common *w) +{ + if (!w) + return; + + if (w->left) + free_written_common (w->left); + if (w->right) + free_written_common (w->right); + + free (w); +} + +/* Write a common block to the module -- recursive helper function. */ + +static void +write_common_0 (gfc_symtree *st, bool this_module) +{ + gfc_common_head *p; + const char * name; + int flags; + const char *label; + struct written_common *w; + bool write_me = true; + + if (st == NULL) + return; + + write_common_0 (st->left, this_module); + + /* We will write out the binding label, or "" if no label given. */ + name = st->n.common->name; + p = st->n.common; + label = (p->is_bind_c && p->binding_label) ? p->binding_label : ""; + + /* Check if we've already output this common. */ + w = written_commons; + while (w) + { + int c = strcmp (name, w->name); + c = (c != 0 ? c : strcmp (label, w->label)); + if (c == 0) + write_me = false; + + w = (c < 0) ? w->left : w->right; + } + + if (this_module && p->use_assoc) + write_me = false; + + if (write_me) + { + /* Write the common to the module. */ + mio_lparen (); + mio_pool_string (&name); + + mio_symbol_ref (&p->head); + flags = p->saved ? 1 : 0; + if (p->threadprivate) + flags |= 2; + flags |= p->omp_device_type << 2; + mio_integer (&flags); + + /* Write out whether the common block is bind(c) or not. */ + mio_integer (&(p->is_bind_c)); + + mio_pool_string (&label); + mio_rparen (); + + /* Record that we have written this common. */ + w = XCNEW (struct written_common); + w->name = p->name; + w->label = label; + gfc_insert_bbt (&written_commons, w, compare_written_commons); + } + + write_common_0 (st->right, this_module); +} + + +/* Write a common, by initializing the list of written commons, calling + the recursive function write_common_0() and cleaning up afterwards. */ + +static void +write_common (gfc_symtree *st) +{ + written_commons = NULL; + write_common_0 (st, true); + write_common_0 (st, false); + free_written_common (written_commons); + written_commons = NULL; +} + + +/* 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; + + mio_lparen (); + + mio_pool_string (&name); + + mio_symbol_ref (&gfc_current_ns->blank_common.head); + 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 an empty binding label. */ + write_atom (ATOM_STRING, ""); + + mio_rparen (); +} + + +/* Write equivalences to the module. */ + +static void +write_equiv (void) +{ + gfc_equiv *eq, *e; + int num; + + num = 0; + for (eq = gfc_current_ns->equiv; eq; eq = eq->next) + { + mio_lparen (); + + for (e = eq; e; e = e->eq) + { + if (e->module == NULL) + e->module = gfc_get_string ("%s.eq.%d", module_name, num); + mio_allocated_string (e->module); + mio_expr (&e->expr); + } + + num++; + mio_rparen (); + } +} + + +/* Write a symbol to the module. */ + +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 %qs", sym->name); + + mio_integer (&n); + + if (gfc_fl_struct (sym->attr.flavor)) + { + const char *name; + name = gfc_dt_upper_string (sym->name); + mio_pool_string (&name); + } + else + mio_pool_string (&sym->name); + + mio_pool_string (&sym->module); + if ((sym->attr.is_bind_c || sym->attr.is_iso_c) && sym->binding_label) + { + label = sym->binding_label; + mio_pool_string (&label); + } + else + write_atom (ATOM_STRING, ""); + + mio_pointer_ref (&sym->ns); + + mio_symbol (sym); + write_char ('\n'); +} + + +/* Recursive traversal function to write the initial set of symbols to + the module. We check to see if the symbol should be written + according to the access specification. */ + +static void +write_symbol0 (gfc_symtree *st) +{ + gfc_symbol *sym; + pointer_info *p; + bool dont_write = false; + + if (st == NULL) + return; + + write_symbol0 (st->left); + + sym = st->n.sym; + if (sym->module == NULL) + sym->module = module_name; + + if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic + && !sym->attr.subroutine && !sym->attr.function) + dont_write = true; + + if (!gfc_check_symbol_access (sym)) + dont_write = true; + + if (!dont_write) + { + p = get_pointer (sym); + if (p->type == P_UNKNOWN) + p->type = P_SYMBOL; + + if (p->u.wsym.state != WRITTEN) + { + write_symbol (p->integer, sym); + p->u.wsym.state = WRITTEN; + } + } + + write_symbol0 (st->right); +} + + +static void +write_omp_udr (gfc_omp_udr *udr) +{ + switch (udr->rop) + { + case OMP_REDUCTION_USER: + /* Non-operators can't be used outside of the module. */ + if (udr->name[0] != '.') + return; + else + { + gfc_symtree *st; + size_t len = strlen (udr->name + 1); + char *name = XALLOCAVEC (char, len); + memcpy (name, udr->name, len - 1); + name[len - 1] = '\0'; + st = gfc_find_symtree (gfc_current_ns->uop_root, name); + /* If corresponding user operator is private, don't write + the UDR. */ + if (st != NULL) + { + gfc_user_op *uop = st->n.uop; + if (!check_access (uop->access, uop->ns->default_access)) + return; + } + } + break; + case OMP_REDUCTION_PLUS: + case OMP_REDUCTION_MINUS: + case OMP_REDUCTION_TIMES: + case OMP_REDUCTION_AND: + case OMP_REDUCTION_OR: + case OMP_REDUCTION_EQV: + case OMP_REDUCTION_NEQV: + /* If corresponding operator is private, don't write the UDR. */ + if (!check_access (gfc_current_ns->operator_access[udr->rop], + gfc_current_ns->default_access)) + return; + break; + default: + break; + } + if (udr->ts.type == BT_DERIVED || udr->ts.type == BT_CLASS) + { + /* If derived type is private, don't write the UDR. */ + if (!gfc_check_symbol_access (udr->ts.u.derived)) + return; + } + + mio_lparen (); + mio_pool_string (&udr->name); + mio_typespec (&udr->ts); + mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns, false); + if (udr->initializer_ns) + mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig, + udr->initializer_ns, true); + mio_rparen (); +} + + +static void +write_omp_udrs (gfc_symtree *st) +{ + if (st == NULL) + return; + + write_omp_udrs (st->left); + gfc_omp_udr *udr; + for (udr = st->n.omp_udr; udr; udr = udr->next) + write_omp_udr (udr); + write_omp_udrs (st->right); +} + + +/* Type for the temporary tree used when writing secondary symbols. */ + +struct sorted_pointer_info +{ + BBT_HEADER (sorted_pointer_info); + + pointer_info *p; +}; + +#define gfc_get_sorted_pointer_info() XCNEW (sorted_pointer_info) + +/* Recursively traverse the temporary tree, free its contents. */ + +static void +free_sorted_pointer_info_tree (sorted_pointer_info *p) +{ + if (!p) + return; + + free_sorted_pointer_info_tree (p->left); + free_sorted_pointer_info_tree (p->right); + + free (p); +} + +/* Comparison function for the temporary tree. */ + +static int +compare_sorted_pointer_info (void *_spi1, void *_spi2) +{ + sorted_pointer_info *spi1, *spi2; + spi1 = (sorted_pointer_info *)_spi1; + spi2 = (sorted_pointer_info *)_spi2; + + if (spi1->p->integer < spi2->p->integer) + return -1; + if (spi1->p->integer > spi2->p->integer) + return 1; + return 0; +} + + +/* Finds the symbols that need to be written and collects them in the + sorted_pi tree so that they can be traversed in an order + independent of memory addresses. */ + +static void +find_symbols_to_write(sorted_pointer_info **tree, pointer_info *p) +{ + if (!p) + return; + + if (p->type == P_SYMBOL && p->u.wsym.state == NEEDS_WRITE) + { + sorted_pointer_info *sp = gfc_get_sorted_pointer_info(); + sp->p = p; + + gfc_insert_bbt (tree, sp, compare_sorted_pointer_info); + } + + find_symbols_to_write (tree, p->left); + find_symbols_to_write (tree, p->right); +} + + +/* Recursive function that traverses the tree of symbols that need to be + written and writes them in order. */ + +static void +write_symbol1_recursion (sorted_pointer_info *sp) +{ + if (!sp) + return; + + write_symbol1_recursion (sp->left); + + pointer_info *p1 = sp->p; + gcc_assert (p1->type == P_SYMBOL && p1->u.wsym.state == NEEDS_WRITE); + + p1->u.wsym.state = WRITTEN; + write_symbol (p1->integer, p1->u.wsym.sym); + p1->u.wsym.sym->attr.public_used = 1; + + write_symbol1_recursion (sp->right); +} + + +/* Write the secondary set of symbols to the module file. These are + symbols that were not public yet are needed by the public symbols + or another dependent symbol. The act of writing a symbol can add + symbols to the pointer_info tree, so we return nonzero if a symbol + was written and pass that information upwards. The caller will + then call this function again until nothing was written. It uses + the utility functions and a temporary tree to ensure a reproducible + ordering of the symbol output and thus the module file. */ + +static int +write_symbol1 (pointer_info *p) +{ + if (!p) + return 0; + + /* Put symbols that need to be written into a tree sorted on the + integer field. */ + + sorted_pointer_info *spi_root = NULL; + find_symbols_to_write (&spi_root, p); + + /* No symbols to write, return. */ + if (!spi_root) + return 0; + + /* Otherwise, write and free the tree again. */ + write_symbol1_recursion (spi_root); + free_sorted_pointer_info_tree (spi_root); + + return 1; +} + + +/* Write operator interfaces associated with a symbol. */ + +static void +write_operator (gfc_user_op *uop) +{ + static char nullstring[] = ""; + const char *p = nullstring; + + if (uop->op == NULL || !check_access (uop->access, uop->ns->default_access)) + return; + + mio_symbol_interface (&uop->name, &p, &uop->op); +} + + +/* Write generic interfaces from the namespace sym_root. */ + +static void +write_generic (gfc_symtree *st) +{ + gfc_symbol *sym; + + if (st == NULL) + return; + + write_generic (st->left); + + sym = st->n.sym; + if (sym && !check_unique_name (st->name) + && sym->generic && gfc_check_symbol_access (sym)) + { + if (!sym->module) + sym->module = module_name; + + mio_symbol_interface (&st->name, &sym->module, &sym->generic); + } + + write_generic (st->right); +} + + +static void +write_symtree (gfc_symtree *st) +{ + gfc_symbol *sym; + pointer_info *p; + + sym = st->n.sym; + + /* A symbol in an interface body must not be visible in the + module file. */ + if (sym->ns != gfc_current_ns + && sym->ns->proc_name + && sym->ns->proc_name->attr.if_source == IFSRC_IFBODY) + return; + + if (!gfc_check_symbol_access (sym) + || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic + && !sym->attr.subroutine && !sym->attr.function)) + return; + + if (check_unique_name (st->name)) + return; + + /* From F2003 onwards, intrinsic procedures are no longer subject to + the restriction, "that an elemental intrinsic function here be of + type integer or character and each argument must be an initialization + expr of type integer or character" is lifted so that intrinsic + procedures can be over-ridden. This requires that the intrinsic + symbol not appear in the module file, thereby preventing ambiguity + when USEd. */ + if (strcmp (sym->module, "(intrinsic)") == 0 + && (gfc_option.allow_std & GFC_STD_F2003)) + return; + + p = find_pointer (sym); + if (p == NULL) + gfc_internal_error ("write_symtree(): Symbol not written"); + + mio_pool_string (&st->name); + mio_integer (&st->ambiguous); + mio_hwi (&p->integer); +} + + +static void +write_module (void) +{ + int i; + + /* Initialize the column counter. */ + module_column = 1; + + /* Write the operator interfaces. */ + mio_lparen (); + + for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++) + { + if (i == INTRINSIC_USER) + continue; + + mio_interface (check_access (gfc_current_ns->operator_access[i], + gfc_current_ns->default_access) + ? &gfc_current_ns->op[i] : NULL); + } + + mio_rparen (); + write_char ('\n'); + write_char ('\n'); + + mio_lparen (); + gfc_traverse_user_op (gfc_current_ns, write_operator); + mio_rparen (); + write_char ('\n'); + write_char ('\n'); + + mio_lparen (); + write_generic (gfc_current_ns->sym_root); + mio_rparen (); + write_char ('\n'); + write_char ('\n'); + + mio_lparen (); + write_blank_common (); + write_common (gfc_current_ns->common_root); + mio_rparen (); + write_char ('\n'); + write_char ('\n'); + + mio_lparen (); + write_equiv (); + mio_rparen (); + write_char ('\n'); + write_char ('\n'); + + mio_lparen (); + write_omp_udrs (gfc_current_ns->omp_udr_root); + mio_rparen (); + write_char ('\n'); + write_char ('\n'); + + /* Write symbol information. First we traverse all symbols in the + primary namespace, writing those that need to be written. + Sometimes writing one symbol will cause another to need to be + written. A list of these symbols ends up on the write stack, and + we end by popping the bottom of the stack and writing the symbol + until the stack is empty. */ + + mio_lparen (); + + write_symbol0 (gfc_current_ns->sym_root); + while (write_symbol1 (pi_root)) + /* Nothing. */; + + mio_rparen (); + + write_char ('\n'); + write_char ('\n'); + + mio_lparen (); + gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree); + mio_rparen (); +} + + +/* Read a CRC32 sum from the gzip trailer of a module file. Returns + true on success, false on failure. */ + +static bool +read_crc32_from_module_file (const char* filename, uLong* crc) +{ + FILE *file; + char buf[4]; + unsigned int val; + + /* Open the file in binary mode. */ + if ((file = fopen (filename, "rb")) == NULL) + return false; + + /* The gzip crc32 value is found in the [END-8, END-4] bytes of the + file. See RFC 1952. */ + if (fseek (file, -8, SEEK_END) != 0) + { + fclose (file); + return false; + } + + /* Read the CRC32. */ + if (fread (buf, 1, 4, file) != 4) + { + fclose (file); + return false; + } + + /* Close the file. */ + fclose (file); + + val = (buf[0] & 0xFF) + ((buf[1] & 0xFF) << 8) + ((buf[2] & 0xFF) << 16) + + ((buf[3] & 0xFF) << 24); + *crc = val; + + /* For debugging, the CRC value printed in hexadecimal should match + the CRC printed by "zcat -l -v filename". + printf("CRC of file %s is %x\n", filename, val); */ + + return true; +} + + +/* 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. */ + +static void +dump_module (const char *name, int dump_flag) +{ + int n; + char *filename, *filename_tmp; + uLong crc, crc_old; + + module_name = gfc_get_string ("%s", name); + + if (dump_smod) + { + name = submodule_name; + n = strlen (name) + strlen (SUBMODULE_EXTENSION) + 1; + } + else + n = strlen (name) + strlen (MODULE_EXTENSION) + 1; + + if (gfc_option.module_dir != NULL) + { + n += strlen (gfc_option.module_dir); + filename = (char *) alloca (n); + strcpy (filename, gfc_option.module_dir); + strcat (filename, name); + } + else + { + filename = (char *) alloca (n); + strcpy (filename, name); + } + + if (dump_smod) + strcat (filename, SUBMODULE_EXTENSION); + else + 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) + { + remove (filename); + return; + } + + if (gfc_cpp_makedep ()) + gfc_cpp_add_target (filename); + + /* Write the module to the temporary file. */ + module_fp = gzopen (filename_tmp, "w"); + if (module_fp == NULL) + gfc_fatal_error ("Cannot open module file %qs for writing at %C: %s", + filename_tmp, xstrerror (errno)); + + /* Use lbasename to ensure module files are reproducible regardless + of the build path (see the reproducible builds project). */ + gzprintf (module_fp, "GFORTRAN module version '%s' created from %s\n", + MOD_VERSION, lbasename (gfc_source_file)); + + /* Write the module itself. */ + iomode = IO_OUTPUT; + + init_pi_tree (); + + write_module (); + + free_pi_tree (pi_root); + pi_root = NULL; + + write_char ('\n'); + + if (gzclose (module_fp)) + gfc_fatal_error ("Error writing module file %qs for writing: %s", + filename_tmp, xstrerror (errno)); + + /* Read the CRC32 from the gzip trailers of the module files and + compare. */ + if (!read_crc32_from_module_file (filename_tmp, &crc) + || !read_crc32_from_module_file (filename, &crc_old) + || crc_old != crc) + { + /* Module file have changed, replace the old one. */ + if (remove (filename) && errno != ENOENT) + gfc_fatal_error ("Cannot delete module file %qs: %s", filename, + xstrerror (errno)); + if (rename (filename_tmp, filename)) + gfc_fatal_error ("Cannot rename module file %qs to %qs: %s", + filename_tmp, filename, xstrerror (errno)); + } + else + { + if (remove (filename_tmp)) + gfc_fatal_error ("Cannot delete temporary module file %qs: %s", + filename_tmp, xstrerror (errno)); + } +} + + +/* Suppress the output of a .smod file by module, if no module + procedures have been seen. */ +static bool no_module_procedures; + +static void +check_for_module_procedures (gfc_symbol *sym) +{ + if (sym && sym->attr.module_procedure) + no_module_procedures = false; +} + + +void +gfc_dump_module (const char *name, int dump_flag) +{ + if (gfc_state_stack->state == COMP_SUBMODULE) + dump_smod = true; + else + dump_smod =false; + + no_module_procedures = true; + gfc_traverse_ns (gfc_current_ns, check_for_module_procedures); + + dump_module (name, dump_flag); + + if (no_module_procedures || dump_smod) + return; + + /* Write a submodule file from a module. The 'dump_smod' flag switches + off the check for PRIVATE entities. */ + dump_smod = true; + submodule_name = module_name; + dump_module (name, dump_flag); + dump_smod = false; +} + +static void +create_intrinsic_function (const char *name, int id, + const char *modname, intmod_id module, + bool subroutine, gfc_symbol *result_type) +{ + 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) + { + if (tmp_symtree->n.sym && tmp_symtree->n.sym->module + && strcmp (modname, tmp_symtree->n.sym->module) == 0) + return; + gfc_error ("Symbol %qs at %C already declared", name); + return; + } + + gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); + sym = tmp_symtree->n.sym; + + if (subroutine) + { + gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id); + isym = gfc_intrinsic_subroutine_by_id (isym_id); + sym->attr.subroutine = 1; + } + else + { + gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id); + isym = gfc_intrinsic_function_by_id (isym_id); + + sym->attr.function = 1; + if (result_type) + { + sym->ts.type = BT_DERIVED; + sym->ts.u.derived = result_type; + sym->ts.is_c_interop = 1; + isym->ts.f90_type = BT_VOID; + isym->ts.type = BT_DERIVED; + isym->ts.f90_type = BT_VOID; + isym->ts.u.derived = result_type; + isym->ts.is_c_interop = 1; + } + } + gcc_assert (isym); + + sym->attr.flavor = FL_PROCEDURE; + sym->attr.intrinsic = 1; + + sym->module = gfc_get_string ("%s", 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 + list was provided. */ + +static void +import_iso_c_binding_module (void) +{ + gfc_symbol *mod_sym = NULL, *return_type; + gfc_symtree *mod_symtree = NULL, *tmp_symtree; + gfc_symtree *c_ptr = NULL, *c_funptr = NULL; + const char *iso_c_module_name = "__iso_c_binding"; + gfc_use_rename *u; + int i; + bool want_c_ptr = false, want_c_funptr = false; + + /* 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, + false); + + 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 ("%s", iso_c_module_name); + mod_sym->from_intmod = INTMOD_ISO_C_BINDING; + } + + /* Check whether C_PTR or C_FUNPTR are in the include list, if so, load it; + check also whether C_NULL_(FUN)PTR or C_(FUN)LOC are requested, which + need C_(FUN)PTR. */ + for (u = gfc_rename_list; u; u = u->next) + { + if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_PTR].name, + u->use_name) == 0) + want_c_ptr = true; + else if (strcmp (c_interop_kinds_table[ISOCBINDING_LOC].name, + u->use_name) == 0) + want_c_ptr = true; + else if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_FUNPTR].name, + u->use_name) == 0) + want_c_funptr = true; + else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNLOC].name, + u->use_name) == 0) + want_c_funptr = true; + else if (strcmp (c_interop_kinds_table[ISOCBINDING_PTR].name, + u->use_name) == 0) + { + c_ptr = generate_isocbinding_symbol (iso_c_module_name, + (iso_c_binding_symbol) + ISOCBINDING_PTR, + u->local_name[0] ? u->local_name + : u->use_name, + NULL, false); + } + else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNPTR].name, + u->use_name) == 0) + { + c_funptr + = generate_isocbinding_symbol (iso_c_module_name, + (iso_c_binding_symbol) + ISOCBINDING_FUNPTR, + u->local_name[0] ? u->local_name + : u->use_name, + NULL, false); + } + } + + if ((want_c_ptr || !only_flag) && !c_ptr) + c_ptr = generate_isocbinding_symbol (iso_c_module_name, + (iso_c_binding_symbol) + ISOCBINDING_PTR, + NULL, NULL, only_flag); + if ((want_c_funptr || !only_flag) && !c_funptr) + c_funptr = generate_isocbinding_symbol (iso_c_module_name, + (iso_c_binding_symbol) + ISOCBINDING_FUNPTR, + NULL, NULL, only_flag); + + /* Generate the symbols for the named constants representing + the kinds for intrinsic data types. */ + for (i = 0; i < ISOCBINDING_NUMBER; i++) + { + bool found = false; + for (u = gfc_rename_list; u; u = u->next) + if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0) + { + bool not_in_std; + const char *name; + u->found = 1; + found = true; + + switch (i) + { +#define NAMED_FUNCTION(a,b,c,d) \ + case a: \ + not_in_std = (gfc_option.allow_std & d) == 0; \ + name = b; \ + break; +#define NAMED_SUBROUTINE(a,b,c,d) \ + case a: \ + not_in_std = (gfc_option.allow_std & d) == 0; \ + name = b; \ + break; +#define NAMED_INTCST(a,b,c,d) \ + case a: \ + not_in_std = (gfc_option.allow_std & d) == 0; \ + name = b; \ + break; +#define NAMED_REALCST(a,b,c,d) \ + case a: \ + not_in_std = (gfc_option.allow_std & d) == 0; \ + name = b; \ + break; +#define NAMED_CMPXCST(a,b,c,d) \ + case a: \ + not_in_std = (gfc_option.allow_std & d) == 0; \ + name = b; \ + break; +#include "iso-c-binding.def" + default: + not_in_std = false; + name = ""; + } + + if (not_in_std) + { + gfc_error ("The symbol %qs, referenced at %L, is not " + "in the selected standard", name, &u->where); + continue; + } + + switch (i) + { +#define NAMED_FUNCTION(a,b,c,d) \ + case a: \ + if (a == ISOCBINDING_LOC) \ + return_type = c_ptr->n.sym; \ + else if (a == ISOCBINDING_FUNLOC) \ + return_type = c_funptr->n.sym; \ + else \ + return_type = NULL; \ + create_intrinsic_function (u->local_name[0] \ + ? u->local_name : u->use_name, \ + a, iso_c_module_name, \ + INTMOD_ISO_C_BINDING, false, \ + return_type); \ + break; +#define NAMED_SUBROUTINE(a,b,c,d) \ + case a: \ + create_intrinsic_function (u->local_name[0] ? u->local_name \ + : u->use_name, \ + a, iso_c_module_name, \ + INTMOD_ISO_C_BINDING, true, NULL); \ + break; +#include "iso-c-binding.def" + + case ISOCBINDING_PTR: + case ISOCBINDING_FUNPTR: + /* Already handled above. */ + break; + default: + if (i == ISOCBINDING_NULL_PTR) + tmp_symtree = c_ptr; + else if (i == ISOCBINDING_NULL_FUNPTR) + tmp_symtree = c_funptr; + else + tmp_symtree = NULL; + generate_isocbinding_symbol (iso_c_module_name, + (iso_c_binding_symbol) i, + u->local_name[0] + ? u->local_name : u->use_name, + tmp_symtree, false); + } + } + + if (!found && !only_flag) + { + /* Skip, if the symbol is not in the enabled standard. */ + switch (i) + { +#define NAMED_FUNCTION(a,b,c,d) \ + case a: \ + if ((gfc_option.allow_std & d) == 0) \ + continue; \ + break; +#define NAMED_SUBROUTINE(a,b,c,d) \ + case a: \ + if ((gfc_option.allow_std & d) == 0) \ + continue; \ + break; +#define NAMED_INTCST(a,b,c,d) \ + case a: \ + if ((gfc_option.allow_std & d) == 0) \ + continue; \ + break; +#define NAMED_REALCST(a,b,c,d) \ + case a: \ + if ((gfc_option.allow_std & d) == 0) \ + continue; \ + break; +#define NAMED_CMPXCST(a,b,c,d) \ + case a: \ + if ((gfc_option.allow_std & d) == 0) \ + continue; \ + break; +#include "iso-c-binding.def" + default: + ; /* Not GFC_STD_* versioned. */ + } + + switch (i) + { +#define NAMED_FUNCTION(a,b,c,d) \ + case a: \ + if (a == ISOCBINDING_LOC) \ + return_type = c_ptr->n.sym; \ + else if (a == ISOCBINDING_FUNLOC) \ + return_type = c_funptr->n.sym; \ + else \ + return_type = NULL; \ + create_intrinsic_function (b, a, iso_c_module_name, \ + INTMOD_ISO_C_BINDING, false, \ + return_type); \ + break; +#define NAMED_SUBROUTINE(a,b,c,d) \ + case a: \ + create_intrinsic_function (b, a, iso_c_module_name, \ + INTMOD_ISO_C_BINDING, true, NULL); \ + break; +#include "iso-c-binding.def" + + case ISOCBINDING_PTR: + case ISOCBINDING_FUNPTR: + /* Already handled above. */ + break; + default: + if (i == ISOCBINDING_NULL_PTR) + tmp_symtree = c_ptr; + else if (i == ISOCBINDING_NULL_FUNPTR) + tmp_symtree = c_funptr; + else + tmp_symtree = NULL; + generate_isocbinding_symbol (iso_c_module_name, + (iso_c_binding_symbol) i, NULL, + tmp_symtree, false); + } + } + } + + for (u = gfc_rename_list; u; u = u->next) + { + if (u->found) + continue; + + gfc_error ("Symbol %qs 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, + intmod_id module, int id) +{ + 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 %qs already declared", name); + } + + gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); + sym = tmp_symtree->n.sym; + + sym->module = gfc_get_string ("%s", modname); + sym->attr.flavor = FL_PARAMETER; + sym->ts.type = BT_INTEGER; + sym->ts.kind = gfc_default_integer_kind; + sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL, value); + sym->attr.use_assoc = 1; + sym->from_intmod = module; + sym->intmod_sym_id = id; +} + + +/* Value is already contained by the array constructor, but not + yet the shape. */ + +static void +create_int_parameter_array (const char *name, int size, gfc_expr *value, + const char *modname, intmod_id module, int id) +{ + 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 %qs already declared", name); + } + + gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); + sym = tmp_symtree->n.sym; + + sym->module = gfc_get_string ("%s", modname); + sym->attr.flavor = FL_PARAMETER; + sym->ts.type = BT_INTEGER; + sym->ts.kind = gfc_default_integer_kind; + sym->attr.use_assoc = 1; + sym->from_intmod = module; + sym->intmod_sym_id = id; + sym->attr.dimension = 1; + sym->as = gfc_get_array_spec (); + sym->as->rank = 1; + sym->as->type = AS_EXPLICIT; + sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); + sym->as->upper[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, size); + + sym->value = value; + sym->value->shape = gfc_get_shape (1); + mpz_init_set_ui (sym->value->shape[0], size); +} + + +/* Add an derived type for a given module. */ + +static void +create_derived_type (const char *name, const char *modname, + intmod_id module, int id) +{ + gfc_symtree *tmp_symtree; + gfc_symbol *sym, *dt_sym; + gfc_interface *intr, *head; + + 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 %qs already declared", name); + } + + gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); + sym = tmp_symtree->n.sym; + sym->module = gfc_get_string ("%s", modname); + sym->from_intmod = module; + sym->intmod_sym_id = id; + sym->attr.flavor = FL_PROCEDURE; + sym->attr.function = 1; + sym->attr.generic = 1; + + gfc_get_sym_tree (gfc_dt_upper_string (sym->name), + gfc_current_ns, &tmp_symtree, false); + dt_sym = tmp_symtree->n.sym; + dt_sym->name = gfc_get_string ("%s", sym->name); + dt_sym->attr.flavor = FL_DERIVED; + dt_sym->attr.private_comp = 1; + dt_sym->attr.zero_comp = 1; + dt_sym->attr.use_assoc = 1; + dt_sym->module = gfc_get_string ("%s", modname); + dt_sym->from_intmod = module; + dt_sym->intmod_sym_id = id; + + head = sym->generic; + intr = gfc_get_interface (); + intr->sym = dt_sym; + intr->where = gfc_current_locus; + intr->next = head; + sym->generic = intr; + sym->attr.if_source = IFSRC_DECL; +} + + +/* Read the contents of the module file into a temporary buffer. */ + +static void +read_module_to_tmpbuf () +{ + /* We don't know the uncompressed size, so enlarge the buffer as + needed. */ + int cursz = 4096; + int rsize = cursz; + int len = 0; + + module_content = XNEWVEC (char, cursz); + + while (1) + { + int nread = gzread (module_fp, module_content + len, rsize); + len += nread; + if (nread < rsize) + break; + cursz *= 2; + module_content = XRESIZEVEC (char, module_content, cursz); + rsize = cursz - len; + } + + module_content = XRESIZEVEC (char, module_content, len + 1); + module_content[len] = '\0'; + + module_pos = 0; +} + + +/* USE the ISO_FORTRAN_ENV intrinsic module. */ + +static void +use_iso_fortran_env_module (void) +{ + static char mod[] = "iso_fortran_env"; + gfc_use_rename *u; + gfc_symbol *mod_sym; + gfc_symtree *mod_symtree; + gfc_expr *expr; + int i, j; + + intmod_sym symbol[] = { +#define NAMED_INTCST(a,b,c,d) { a, b, 0, d }, +#define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d }, +#define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d }, +#define NAMED_FUNCTION(a,b,c,d) { a, b, c, d }, +#define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d }, +#include "iso-fortran-env.def" + { ISOFORTRANENV_INVALID, NULL, -1234, 0 } }; + + i = 0; +#define NAMED_INTCST(a,b,c,d) symbol[i++].value = c; +#include "iso-fortran-env.def" + + /* 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, false); + 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 ("%s", mod); + mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV; + } + else + if (!mod_symtree->n.sym->attr.intrinsic) + gfc_error ("Use of intrinsic module %qs at %C conflicts with " + "non-intrinsic module name used previously", mod); + + /* Generate the symbols for the module integer named constants. */ + + for (i = 0; symbol[i].name; i++) + { + bool found = false; + for (u = gfc_rename_list; u; u = u->next) + { + if (strcmp (symbol[i].name, u->use_name) == 0) + { + found = true; + u->found = 1; + + if (!gfc_notify_std (symbol[i].standard, "The symbol %qs, " + "referenced at %L, is not in the selected " + "standard", symbol[i].name, &u->where)) + continue; + + if ((flag_default_integer || flag_default_real_8) + && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE) + gfc_warning_now (0, "Use of the NUMERIC_STORAGE_SIZE named " + "constant from intrinsic module " + "ISO_FORTRAN_ENV at %L is incompatible with " + "option %qs", &u->where, + flag_default_integer + ? "-fdefault-integer-8" + : "-fdefault-real-8"); + switch (symbol[i].id) + { +#define NAMED_INTCST(a,b,c,d) \ + case a: +#include "iso-fortran-env.def" + create_int_parameter (u->local_name[0] ? u->local_name + : u->use_name, + symbol[i].value, mod, + INTMOD_ISO_FORTRAN_ENV, symbol[i].id); + break; + +#define NAMED_KINDARRAY(a,b,KINDS,d) \ + case a:\ + expr = gfc_get_array_expr (BT_INTEGER, \ + gfc_default_integer_kind,\ + NULL); \ + for (j = 0; KINDS[j].kind != 0; j++) \ + gfc_constructor_append_expr (&expr->value.constructor, \ + gfc_get_int_expr (gfc_default_integer_kind, NULL, \ + KINDS[j].kind), NULL); \ + create_int_parameter_array (u->local_name[0] ? u->local_name \ + : u->use_name, \ + j, expr, mod, \ + INTMOD_ISO_FORTRAN_ENV, \ + symbol[i].id); \ + break; +#include "iso-fortran-env.def" + +#define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \ + case a: +#include "iso-fortran-env.def" + create_derived_type (u->local_name[0] ? u->local_name + : u->use_name, + mod, INTMOD_ISO_FORTRAN_ENV, + symbol[i].id); + break; + +#define NAMED_FUNCTION(a,b,c,d) \ + case a: +#include "iso-fortran-env.def" + create_intrinsic_function (u->local_name[0] ? u->local_name + : u->use_name, + symbol[i].id, mod, + INTMOD_ISO_FORTRAN_ENV, false, + NULL); + break; + + default: + gcc_unreachable (); + } + } + } + + if (!found && !only_flag) + { + if ((gfc_option.allow_std & symbol[i].standard) == 0) + continue; + + if ((flag_default_integer || flag_default_real_8) + && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE) + gfc_warning_now (0, + "Use of the NUMERIC_STORAGE_SIZE named constant " + "from intrinsic module ISO_FORTRAN_ENV at %C is " + "incompatible with option %s", + flag_default_integer + ? "-fdefault-integer-8" : "-fdefault-real-8"); + + switch (symbol[i].id) + { +#define NAMED_INTCST(a,b,c,d) \ + case a: +#include "iso-fortran-env.def" + create_int_parameter (symbol[i].name, symbol[i].value, mod, + INTMOD_ISO_FORTRAN_ENV, symbol[i].id); + break; + +#define NAMED_KINDARRAY(a,b,KINDS,d) \ + case a:\ + expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \ + NULL); \ + for (j = 0; KINDS[j].kind != 0; j++) \ + gfc_constructor_append_expr (&expr->value.constructor, \ + gfc_get_int_expr (gfc_default_integer_kind, NULL, \ + KINDS[j].kind), NULL); \ + create_int_parameter_array (symbol[i].name, j, expr, mod, \ + INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\ + break; +#include "iso-fortran-env.def" + +#define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \ + case a: +#include "iso-fortran-env.def" + create_derived_type (symbol[i].name, mod, INTMOD_ISO_FORTRAN_ENV, + symbol[i].id); + break; + +#define NAMED_FUNCTION(a,b,c,d) \ + case a: +#include "iso-fortran-env.def" + create_intrinsic_function (symbol[i].name, symbol[i].id, mod, + INTMOD_ISO_FORTRAN_ENV, false, + NULL); + break; + + default: + gcc_unreachable (); + } + } + } + + for (u = gfc_rename_list; u; u = u->next) + { + if (u->found) + continue; + + gfc_error ("Symbol %qs referenced at %L not found in intrinsic " + "module ISO_FORTRAN_ENV", u->use_name, &u->where); + } +} + + +/* Process a USE directive. */ + +static void +gfc_use_module (gfc_use_list *module) +{ + char *filename; + gfc_state_data *p; + int c, line, start; + gfc_symtree *mod_symtree; + gfc_use_list *use_stmt; + locus old_locus = gfc_current_locus; + + gfc_current_locus = module->where; + module_name = module->module_name; + gfc_rename_list = module->rename; + only_flag = module->only_flag; + current_intmod = INTMOD_NONE; + + if (!only_flag) + gfc_warning_now (OPT_Wuse_without_only, + "USE statement at %C has no ONLY qualifier"); + + if (gfc_state_stack->state == COMP_MODULE + || module->submodule_name == NULL) + { + filename = XALLOCAVEC (char, strlen (module_name) + + strlen (MODULE_EXTENSION) + 1); + strcpy (filename, module_name); + strcat (filename, MODULE_EXTENSION); + } + else + { + filename = XALLOCAVEC (char, strlen (module->submodule_name) + + strlen (SUBMODULE_EXTENSION) + 1); + strcpy (filename, module->submodule_name); + strcat (filename, SUBMODULE_EXTENSION); + } + + /* First, try to find an non-intrinsic module, unless the USE statement + specified that the module is intrinsic. */ + module_fp = NULL; + if (!module->intrinsic) + module_fp = gzopen_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 && !module->non_intrinsic) + { + if (strcmp (module_name, "iso_fortran_env") == 0 + && gfc_notify_std (GFC_STD_F2003, "ISO_FORTRAN_ENV " + "intrinsic module at %C")) + { + use_iso_fortran_env_module (); + free_rename (module->rename); + module->rename = NULL; + gfc_current_locus = old_locus; + module->intrinsic = true; + return; + } + + if (strcmp (module_name, "iso_c_binding") == 0 + && gfc_notify_std (GFC_STD_F2003, "ISO_C_BINDING module at %C")) + { + import_iso_c_binding_module(); + free_rename (module->rename); + module->rename = NULL; + gfc_current_locus = old_locus; + module->intrinsic = true; + return; + } + + module_fp = gzopen_intrinsic_module (filename); + + if (module_fp == NULL && module->intrinsic) + gfc_fatal_error ("Cannot find an intrinsic module named %qs at %C", + module_name); + + /* Check for the IEEE modules, so we can mark their symbols + accordingly when we read them. */ + if (strcmp (module_name, "ieee_features") == 0 + && gfc_notify_std (GFC_STD_F2003, "IEEE_FEATURES module at %C")) + { + current_intmod = INTMOD_IEEE_FEATURES; + } + else if (strcmp (module_name, "ieee_exceptions") == 0 + && gfc_notify_std (GFC_STD_F2003, + "IEEE_EXCEPTIONS module at %C")) + { + current_intmod = INTMOD_IEEE_EXCEPTIONS; + } + else if (strcmp (module_name, "ieee_arithmetic") == 0 + && gfc_notify_std (GFC_STD_F2003, + "IEEE_ARITHMETIC module at %C")) + { + current_intmod = INTMOD_IEEE_ARITHMETIC; + } + } + + if (module_fp == NULL) + { + if (gfc_state_stack->state != COMP_SUBMODULE + && module->submodule_name == NULL) + gfc_fatal_error ("Cannot open module file %qs for reading at %C: %s", + filename, xstrerror (errno)); + else + gfc_fatal_error ("Module file %qs has not been generated, either " + "because the module does not contain a MODULE " + "PROCEDURE or there is an error in the module.", + filename); + } + + /* 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 %qs at %C conflicts with " + "intrinsic module name used previously", module_name); + + iomode = IO_INPUT; + module_line = 1; + module_column = 1; + start = 0; + + read_module_to_tmpbuf (); + gzclose (module_fp); + + /* Skip the first line of the module, after checking that this is + a gfortran module file. */ + line = 0; + while (line < 1) + { + c = module_char (); + if (c == EOF) + bad_module ("Unexpected end of module"); + if (start++ < 3) + parse_name (c); + if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0) + || (start == 2 && strcmp (atom_name, " module") != 0)) + gfc_fatal_error ("File %qs opened at %C is not a GNU Fortran" + " module file", module_fullpath); + if (start == 3) + { + if (strcmp (atom_name, " version") != 0 + || module_char () != ' ' + || parse_atom () != ATOM_STRING + || strcmp (atom_string, MOD_VERSION)) + gfc_fatal_error ("Cannot read module file %qs opened at %C," + " because it was created by a different" + " version of GNU Fortran", module_fullpath); + + free (atom_string); + } + + if (c == '\n') + line++; + } + + /* Make sure we're not reading the same module that we may be building. */ + for (p = gfc_state_stack; p; p = p->previous) + if ((p->state == COMP_MODULE || p->state == COMP_SUBMODULE) + && strcmp (p->sym->name, module_name) == 0) + { + if (p->state == COMP_SUBMODULE) + gfc_fatal_error ("Cannot USE a submodule that is currently built"); + else + gfc_fatal_error ("Cannot USE a module that is currently built"); + } + + init_pi_tree (); + init_true_name_tree (); + + read_module (); + + free_true_name (true_name_root); + true_name_root = NULL; + + free_pi_tree (pi_root); + pi_root = NULL; + + XDELETEVEC (module_content); + module_content = NULL; + + use_stmt = gfc_get_use_list (); + *use_stmt = *module; + use_stmt->next = gfc_current_ns->use_stmts; + gfc_current_ns->use_stmts = use_stmt; + + gfc_current_locus = old_locus; +} + + +/* Remove duplicated intrinsic operators from the rename list. */ + +static void +rename_list_remove_duplicate (gfc_use_rename *list) +{ + gfc_use_rename *seek, *last; + + for (; list; list = list->next) + if (list->op != INTRINSIC_USER && list->op != INTRINSIC_NONE) + { + last = list; + for (seek = list->next; seek; seek = last->next) + { + if (list->op == seek->op) + { + last->next = seek->next; + free (seek); + } + else + last = seek; + } + } +} + + +/* 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; + rename_list_remove_duplicate (module_list->rename); + gfc_use_module (module_list); + free (module_list); + } + gfc_rename_list = NULL; +} + + +void +gfc_free_use_stmts (gfc_use_list *use_stmts) +{ + gfc_use_list *next; + for (; use_stmts; use_stmts = next) + { + gfc_use_rename *next_rename; + + for (; use_stmts->rename; use_stmts->rename = next_rename) + { + next_rename = use_stmts->rename->next; + free (use_stmts->rename); + } + next = use_stmts->next; + free (use_stmts); + } +} + + +void +gfc_module_init_2 (void) +{ + last_atom = ATOM_LPAREN; + gfc_rename_list = NULL; + module_list = NULL; +} + + +void +gfc_module_done_2 (void) +{ + free_rename (gfc_rename_list); + gfc_rename_list = NULL; +} |