/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/module.cc

Bug Summary

File:	build/gcc/fortran/module.cc
Warning:	line 1846, column 7 Assigned value is garbage or undefined
Annotated Source Code

Press '?' to see keyboard shortcuts
Show analyzer invocation
clang -cc1 -cc1 -triple x86_64-suse-linux -analyze -disable-free -clear-ast-before-backend -disable-llvm-verifier -discard-value-names -main-file-name module.cc -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=cplusplus -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -analyzer-config-compatibility-mode=true -mrelocation-model static -mframe-pointer=none -fmath-errno -ffp-contract=on -fno-rounding-math -mconstructor-aliases -funwind-tables=2 -target-cpu x86-64 -tune-cpu generic -debugger-tuning=gdb -fcoverage-compilation-dir=/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/gcc -resource-dir /usr/lib64/clang/15.0.7 -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../zlib -D IN_GCC_FRONTEND -D IN_GCC -D HAVE_CONFIG_H -I . -I fortran -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../include -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcpp/include -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcody -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber/bid -I ../libdecnumber -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libbacktrace -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../include/c++/13 -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../include/c++/13/x86_64-suse-linux -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../include/c++/13/backward -internal-isystem /usr/lib64/clang/15.0.7/include -internal-isystem /usr/local/include -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../x86_64-suse-linux/include -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -Wno-narrowing -Wwrite-strings -Wno-long-long -Wno-variadic-macros -Wno-overlength-strings -fdeprecated-macro -fdebug-compilation-dir=/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/gcc -ferror-limit 19 -fno-rtti -fgnuc-version=4.2.1 -vectorize-loops -vectorize-slp -analyzer-output=plist-html -analyzer-config silence-checkers=core.NullDereference -faddrsig -D__GCC_HAVE_DWARF2_CFI_ASM=1 -o /buildworker/marxinbox-gcc-clang-static-analyzer/objdir/clang-static-analyzer/2023-03-27-141847-20772-1/report-1WVZw_.plist -x c++ /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/module.cc
1/* Handle modules, which amounts to loading and saving symbols and
 their attendant structures.
 Copyright (C) 2000-2023 Free Software Foundation, Inc.
 Contributed by Andy Vaught

6This file is part of GCC.

8GCC is free software; you can redistribute it and/or modify it under
9the terms of the GNU General Public License as published by the Free
10Software Foundation; either version 3, or (at your option) any later
11version.

13GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14WARRANTY; without even the implied warranty of MERCHANTABILITY or
15FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
16for more details.

18You should have received a copy of the GNU General Public License
19along with GCC; see the file COPYING3.  If not see
20<http://www.gnu.org/licenses/>.  */

22/* 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.  */

67#include "config.h"
68#include "system.h"
69#include "coretypes.h"
70#include "options.h"
71#include "tree.h"
72#include "gfortran.h"
73#include "stringpool.h"
74#include "arith.h"
75#include "match.h"
76#include "parse.h" /* FIXME */
77#include "constructor.h"
78#include "cpp.h"
79#include "scanner.h"
80#include <zlib.h>

82#define MODULE_EXTENSION".mod" ".mod"
83#define SUBMODULE_EXTENSION".smod" ".smod"

85/* Don't put any single quote (') in MOD_VERSION, if you want it to be
 recognized.  */
87#define MOD_VERSION"15" "15"


90/* Structure that describes a position within a module file.  */

92typedef struct
93{
int column, line;
long pos;
96}
97module_locus;

99/* Structure for list of symbols of intrinsic modules.  */
100typedef struct
101{
int id;
const char *name;
int value;
int standard;
106}
107intmod_sym;


110typedef enum
111{
P_UNKNOWN = 0, P_OTHER, P_NAMESPACE, P_COMPONENT, P_SYMBOL
113}
114pointer_t;

116/* The fixup structure lists pointers to pointers that have to
 be updated when a pointer value becomes known.  */

119typedef struct fixup_t
120{
void **pointer;
struct fixup_t *next;
123}
124fixup_t;


127/* Structure for holding extra info needed for pointers being read.  */

129enum gfc_rsym_state
130{
UNUSED,
NEEDED,
USED
134};

136enum gfc_wsym_state
137{
UNREFERENCED = 0,
NEEDS_WRITE,
WRITTEN
141};

143typedef struct pointer_info
144{
BBT_HEADER (pointer_info)int priority; struct pointer_info *left, *right;
HOST_WIDE_INTlong 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;

179}
180pointer_info;

182#define gfc_get_pointer_info()((pointer_info *) xcalloc (1, sizeof (pointer_info))) XCNEW (pointer_info)((pointer_info *) xcalloc (1, sizeof (pointer_info)))


185/* Local variables */

187/* The gzFile for the module we're reading or writing.  */
188static gzFile module_fp;

190/* Fully qualified module path */
191static char *module_fullpath = NULL__null;

193/* The name of the module we're reading (USE'ing) or writing.  */
194static const char *module_name;
195/* The name of the .smod file that the submodule will write to.  */
196static const char *submodule_name;

198static gfc_use_list *module_list;

200/* If we're reading an intrinsic module, this is its ID.  */
201static intmod_id current_intmod;

203/* Content of module.  */
204static char* module_content;

206static long module_pos;
207static int module_line, module_column, only_flag;
208static int prev_module_line, prev_module_column;

210static enum
211{ IO_INPUT, IO_OUTPUT }
212iomode;

214static gfc_use_rename *gfc_rename_list;
215static pointer_info *pi_root;
216static int symbol_number;	/* Counter for assigning symbol numbers */

218/* Tells mio_expr_ref to make symbols for unused equivalence members.  */
219static bool in_load_equiv;



223/*****************************************************************/

225/* 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.  */

229/* Recursively free the tree of pointer structures.  */

231static void
232free_pi_tree (pointer_info *p)
233{
if (p == NULL__null)
  return;

if (p->fixup != NULL__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)free ((void*) (p->u.rsym.true_name));
    XDELETEVEC (p->u.rsym.module)free ((void*) (p->u.rsym.module));
    XDELETEVEC (p->u.rsym.binding_label)free ((void*) (p->u.rsym.binding_label));
  }

free (p);
251}


254/* Compare pointers when searching by pointer.  Used when writing a
 module.  */

257static int
258compare_pointers (void *_sn1, void *_sn2)
259{
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;
271}


274/* Compare integers when searching by integer.  Used when reading a
 module.  */

277static int
278compare_integers (void *_sn1, void *_sn2)
279{
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;
291}


294/* Initialize the pointer_info tree.  */

296static void
297init_pi_tree (void)
298{
compare_fn compare;
pointer_info *p;

pi_root = NULL__null;
compare = (iomode == IO_INPUT) ? compare_integers : compare_pointers;

/* Pointer 0 is the NULL pointer.  */
p = gfc_get_pointer_info ()((pointer_info *) xcalloc (1, sizeof (pointer_info)));
p->u.pointer = NULL__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 ()((pointer_info *) xcalloc (1, sizeof (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;
322}


325/* During module writing, call here with a pointer to something,
 returning the pointer_info node.  */

328static pointer_info *
329find_pointer (void *gp)
330{
pointer_info *p;

p = pi_root;
while (p != NULL__null)
  {
    if (p->u.pointer == gp)
break;
    p = (gp < p->u.pointer) ? p->left : p->right;
  }

return p;
342}


345/* Given a pointer while writing, returns the pointer_info tree node,
 creating it if it doesn't exist.  */

348static pointer_info *
349get_pointer (void *gp)
350{
pointer_info *p;

p = find_pointer (gp);
if (p != NULL__null)
  return p;

/* Pointer doesn't have an integer.  Give it one.  */
p = gfc_get_pointer_info ()((pointer_info *) xcalloc (1, sizeof (pointer_info)));

p->u.pointer = gp;
p->integer = symbol_number++;

gfc_insert_bbt (&pi_root, p, compare_pointers);

return p;
366}


369/* Given an integer during reading, find it in the pointer_info tree,
 creating the node if not found.  */

372static pointer_info *
373get_integer (HOST_WIDE_INTlong integer)
374{
pointer_info *p, t;
int c;

t.integer = integer;

p = pi_root;
while (p != NULL__null)
  {
    c = compare_integers (&t, p);
    if (c == 0)
break;

    p = (c < 0) ? p->left : p->right;
  }

if (p != NULL__null)
  return p;

p = gfc_get_pointer_info ()((pointer_info *) xcalloc (1, sizeof (pointer_info)));
p->integer = integer;
p->u.pointer = NULL__null;

gfc_insert_bbt (&pi_root, p, compare_integers);

return p;
400}


403/* Resolve any fixups using a known pointer.  */

405static void
406resolve_fixups (fixup_t *f, void *gp)
407{
fixup_t *next;

for (; f; f = next)
  {
    next = f->next;
    *(f->pointer) = gp;
    free (f);
  }
416}


419/* 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.  */

423const char *
424gfc_dt_lower_string (const char *name)
425{
if (name[0] != (char) TOLOWER ((unsigned char) name[0])_sch_tolower[((unsigned char) name[0]) & 0xff])
  return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name[0])_sch_tolower[((unsigned char) name[0]) & 0xff],
	   &name[1]);
return gfc_get_string ("%s", name);
430}


433/* 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.  */

438const char *
439gfc_dt_upper_string (const char *name)
440{
if (name[0] != (char) TOUPPER ((unsigned char) name[0])_sch_toupper[((unsigned char) name[0]) & 0xff])
  return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name[0])_sch_toupper[((unsigned char) name[0]) & 0xff],
	   &name[1]);
return gfc_get_string ("%s", name);
445}

447/* Call here during module reading when we know what pointer to
 associate with an integer.  Any fixups that exist are resolved at
 this time.  */

451static void
452associate_integer_pointer (pointer_info *p, void *gp)
453{
if (p->u.pointer != NULL__null)
  gfc_internal_error ("associate_integer_pointer(): Already associated");

p->u.pointer = gp;

resolve_fixups (p->fixup, gp);

p->fixup = NULL__null;
462}


465/* 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.  */

472static pointer_info *
473add_fixup (HOST_WIDE_INTlong integer, void *gp)
474{
pointer_info *p;
fixup_t *f;
char **cp;

p = get_integer (integer);

if (p->integer == 0 || p->u.pointer != NULL__null)
  {
    cp = (char **) gp;
    *cp = (char *) p->u.pointer;
  }
else
  {
    f = XCNEW (fixup_t)((fixup_t *) xcalloc (1, sizeof (fixup_t)));

    f->next = p->fixup;
    p->fixup = f;

    f->pointer = (void **) gp;
  }

return p;
497}


500/*****************************************************************/

502/* Parser related subroutines */

504/* Free the rename list left behind by a USE statement.  */

506static void
507free_rename (gfc_use_rename *list)
508{
gfc_use_rename *next;

for (; list; list = next)
  {
    next = list->next;
    free (list);
  }
516}


519/* Match a USE statement.  */

521match
522gfc_match_use (void)
523{
char name[GFC_MAX_SYMBOL_LEN63 + 1], module_nature[GFC_MAX_SYMBOL_LEN63 + 1];
gfc_use_rename *tail = NULL__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 ()((gfc_use_list *) xcalloc (1, sizeof (gfc_use_list)));

if (gfc_match (" , ") == MATCH_YES)
  {
    if ((m = gfc_match (" %n ::", module_nature)) == MATCH_YES)
{
 if (!gfc_notify_std (GFC_STD_F2003(1<<4), "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(1<<4), "\"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 ()((gfc_use_rename *) xcalloc (1, sizeof (gfc_use_rename)));;
    new_use->where = gfc_current_locus;
    new_use->found = 0;

    if (use_list->rename == NULL__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(1<<4), "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 ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/module.cc"
, 710, __FUNCTION__));
}

    if (gfc_match_eos () == MATCH_YES)
break;
    if (gfc_match_char (',') != MATCH_YES)
goto syntax;
  }

719done:
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;

732syntax:
gfc_syntax_error (ST_USE)gfc_error ("Syntax error in %s statement at %C", gfc_ascii_statement
 (ST_USE));;

735cleanup:
free_rename (use_list->rename);
free (use_list);
return MATCH_ERROR;
739}


742/* 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.  */

754match
755gfc_match_submodule (void)
756{
match m;
char name[GFC_MAX_SYMBOL_LEN63 + 1];
gfc_use_list *use_list;
bool seen_colon = false;

if (!gfc_notify_std (GFC_STD_F2008(1<<7), "SUBMODULE declaration at %C"))
  return MATCH_ERROR;

if (gfc_current_state ()(gfc_state_stack->state) != COMP_NONE)
  {
    gfc_error ("SUBMODULE declaration at %C cannot appear within "
 "another scoping unit");
    return MATCH_ERROR;
  }

gfc_new_block = NULL__null;
gcc_assert (module_list == NULL)((void)(!(module_list == __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/module.cc"
, 773, __FUNCTION__), 0 : 0));

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 ()((gfc_use_list *) xcalloc (1, sizeof (gfc_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__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;

841syntax:
gfc_error ("Syntax error in SUBMODULE statement at %C");
return MATCH_ERROR;
844}


847/* 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.  */

854static const char *
855find_use_name_n (const char *name, int *inst, bool interface)
856{
gfc_use_rename *u;
const char *low_name = NULL__null;
int i;

/* For derived types.  */
if (name[0] != (char) TOLOWER ((unsigned char) name[0])_sch_tolower[((unsigned char) name[0]) & 0xff])
  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__null;
  }

if (u == NULL__null)
  return only_flag ? NULL__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;
896}


899/* Given a name, return the name under which to load this symbol.
 Returns NULL if this symbol shouldn't be loaded.  */

902static const char *
903find_use_name (const char *name, bool interface)
904{
int i = 1;
return find_use_name_n (name, &i, interface);
907}


910/* Given a real name, return the number of use names associated with it.  */

912static int
913number_use_names (const char *name, bool interface)
914{
int i = 0;
find_use_name_n (name, &i, interface);
return i;
918}


921/* Try to find the operator in the current list.  */

923static gfc_use_rename *
924find_use_operator (gfc_intrinsic_op op)
925{
gfc_use_rename *u;

for (u = gfc_rename_list; u; u = u->next)
  if (u->op == op)
    return u;

return NULL__null;
933}


936/*****************************************************************/

938/* 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.  */

949typedef struct true_name
950{
BBT_HEADER (true_name)int priority; struct true_name *left, *right;
const char *name;
gfc_symbol *sym;
954}
955true_name;

957static true_name *true_name_root;


960/* Compare two true_name structures.  */

962static int
963compare_true_names (void *_t1, void *_t2)
964{
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);
977}


980/* Given a true name, search the true name tree to see if it exists
 within the main namespace.  */

983static gfc_symbol *
984find_true_name (const char *name, const char *module)
985{
true_name t, *p;
gfc_symbol sym;
int c;

t.name = gfc_get_string ("%s", name);
if (module != NULL__null)
  sym.module = gfc_get_string ("%s", module);
else
  sym.module = NULL__null;
t.sym = &sym;

p = true_name_root;
while (p != NULL__null)
  {
    c = compare_true_names ((void *) (&t), (void *) p);
    if (c == 0)
return p->sym;

    p = (c < 0) ? p->left : p->right;
  }

return NULL__null;
1008}


1011/* Given a gfc_symbol pointer that is not in the true name tree, add it.  */

1013static void
1014add_true_name (gfc_symbol *sym)
1015{
true_name *t;

t = XCNEW (true_name)((true_name *) xcalloc (1, sizeof (true_name)));
t->sym = sym;
if (gfc_fl_struct (sym->attr.flavor)((sym->attr.flavor) == FL_DERIVED || (sym->attr.flavor)
 == FL_UNION || (sym->attr.flavor) == FL_STRUCT))
  t->name = gfc_dt_upper_string (sym->name);
else
  t->name = sym->name;

gfc_insert_bbt (&true_name_root, t, compare_true_names);
1026}


1029/* Recursive function to build the initial true name tree by
 recursively traversing the current namespace.  */

1032static void
1033build_tnt (gfc_symtree *st)
1034{
const char *name;
if (st == NULL__null)
  return;

build_tnt (st->left);
build_tnt (st->right);

if (gfc_fl_struct (st->n.sym->attr.flavor)((st->n.sym->attr.flavor) == FL_DERIVED || (st->n.sym
->attr.flavor) == FL_UNION || (st->n.sym->attr.flavor
) == FL_STRUCT))
  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__null)
  return;

add_true_name (st->n.sym);
1051}


1054/* Initialize the true name tree with the current namespace.  */

1056static void
1057init_true_name_tree (void)
1058{
true_name_root = NULL__null;
build_tnt (gfc_current_ns->sym_root);
1061}


1064/* Recursively free a true name tree node.  */

1066static void
1067free_true_name (true_name *t)
1068{
if (t == NULL__null)
  return;
free_true_name (t->left);
free_true_name (t->right);

free (t);
1075}


1078/*****************************************************************/

1080/* Module reading and writing.  */

1082/* The following are versions similar to the ones in scanner.cc, but
 for dealing with compressed module files.  */

1085static gzFile
1086gzopen_included_file_1 (const char *name, gfc_directorylist *list,
                   bool module, bool system)
1088{
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) + 2)__builtin_alloca(strlen (p->path) + strlen (name) + 2);
    strcpy (fullname, p->path);
    strcat (fullname, "/");
    strcat (fullname, name);

    f = gzopen (fullname, "r");
    if (f != NULL__null)
     {
       if (gfc_cpp_makedep ())
         gfc_cpp_add_dep (fullname, system);

free (module_fullpath);
module_fullpath = xstrdup (fullname);
       return f;
     }
  }

return NULL__null;
1116}

1118static gzFile
1119gzopen_included_file (const char *name, bool include_cwd, bool module)
1120{
gzFile f = NULL__null;

if (IS_ABSOLUTE_PATH (name)(((((name)[0]) == '/') || ((((name)[0]) == '\\') && (
0))) || ((name)[0] && ((name)[1] == ':') && (
0))) || 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;
1140}

1142static gzFile
1143gzopen_intrinsic_module (const char* name)
1144{
gzFile f = NULL__null;

if (IS_ABSOLUTE_PATH (name)(((((name)[0]) == '/') || ((((name)[0]) == '\\') && (
0))) || ((name)[0] && ((name)[1] == ':') && (
0))))
  {
    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;
1164}


1167enum atom_type
1168{
ATOM_NAME, ATOM_LPAREN, ATOM_RPAREN, ATOM_INTEGER, ATOM_STRING
1170};

1172static atom_type last_atom;


1175/* 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!  */

1181#define MAX_ATOM_SIZE100 100

1183static HOST_WIDE_INTlong atom_int;
1184static char *atom_string, atom_name[MAX_ATOM_SIZE100];


1187/* Report problems with a module.  Error reporting is not very
 elaborate, since this sorts of errors shouldn't really happen.
 This subroutine never returns.  */

1191static void bad_module (const char *) ATTRIBUTE_NORETURN__attribute__ ((__noreturn__));

1193static void
1194bad_module (const char *msgid)
1195{
XDELETEVEC (module_content)free ((void*) (module_content));
module_content = NULL__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;
  }
1214}


1217/* Set the module's input pointer.  */

1219static void
1220set_module_locus (module_locus *m)
1221{
module_column = m->column;
module_line = m->line;
module_pos = m->pos;
1225}


1228/* Get the module's input pointer so that we can restore it later.  */

1230static void
1231get_module_locus (module_locus *m)
1232{
m->column = module_column;
m->line = module_line;
m->pos = module_pos;
1236}

1238/* Peek at the next character in the module.  */

1240static int
1241module_peek_char (void)
1242{
return module_content[module_pos];
1244}

1246/* Get the next character in the module, updating our reckoning of
 where we are.  */

1249static int
1250module_char (void)
1251{
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;
1267}

1269/* Unget a character while remembering the line and column.  Works for
 a single character only.  */

1272static void
1273module_unget_char (void)
1274{
module_line = prev_module_line;
module_column = prev_module_column;
module_pos--;
1278}

1280/* Parse a string constant.  The delimiter is guaranteed to be a
 single quote.  */

1283static void
1284parse_string (void)
1285{
int c;
size_t cursz = 30;
size_t len = 0;

atom_string = XNEWVEC (char, cursz)((char *) xmalloc (sizeof (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)((char *) xrealloc ((void *) (atom_string), sizeof (char) * (
cursz)));
}
    atom_string[len] = c;
    len++;
  }

atom_string = XRESIZEVEC (char, atom_string, len + 1)((char *) xrealloc ((void *) (atom_string), sizeof (char) * (
len + 1)));
atom_string[len] = '\0'; 	/* C-style string for debug purposes.  */
1317}


1320/* Parse an integer. Should fit in a HOST_WIDE_INT.  */

1322static void
1323parse_integer (int c)
1324{
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)(_sch_istable[(c) & 0xff] & (unsigned short)(_sch_isdigit
)))
{
 module_unget_char ();
 break;
}

    atom_int = 10 * atom_int + c - '0';
  }

atom_int *= sign; 
1352}


1355/* Parse a name.  */

1357static void
1358parse_name (int c)
1359{
char *p;
int len;

p = atom_name;

*p++ = c;
len = 1;

for (;;)
  {
    c = module_char ();
    if (!ISALNUM (c)(_sch_istable[(c) & 0xff] & (unsigned short)(_sch_isalnum
)) && c != '_' && c != '-')
{
 module_unget_char ();
 break;
}

    *p++ = c;
    if (++len > GFC_MAX_SYMBOL_LEN63)
bad_module ("Name too long");
  }

*p = '\0';

1384}


1387/* Read the next atom in the module's input stream.  */

1389static atom_type
1390parse_atom (void)
1391{
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 ())(_sch_istable[(module_peek_char ()) & 0xff] & (unsigned
 short)(_sch_isdigit)))
{
 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.  */
1495}


1498/* Peek at the next atom on the input.  */

1500static atom_type
1501peek_atom (void)
1502{
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 ())(_sch_istable[(module_peek_char ()) & 0xff] & (unsigned
 short)(_sch_isdigit)))
{
 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");
  }
1606}


1609/* Read the next atom from the input, requiring that it be a
 particular kind.  */

1612static void
1613require_atom (atom_type type)
1614{
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")gettext ("Expected name");
 break;
case ATOM_LPAREN:
 p = _("Expected left parenthesis")gettext ("Expected left parenthesis");
 break;
case ATOM_RPAREN:
 p = _("Expected right parenthesis")gettext ("Expected right parenthesis");
 break;
case ATOM_INTEGER:
 p = _("Expected integer")gettext ("Expected integer");
 break;
case ATOM_STRING:
 p = _("Expected string")gettext ("Expected string");
 break;
default:
 gfc_internal_error ("require_atom(): bad atom type required");
}

    module_column = column;
    module_line = line;
    bad_module (p);
  }
1650}


1653/* 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.  */

1656static int
1657find_enum (const mstring *m)
1658{
int i;

i = gfc_string2code (m, atom_name);
if (i >= 0)
  return i;

bad_module ("find_enum(): Enum not found");

/* Not reached.  */
1668}


1671/* Read a string. The caller is responsible for freeing.  */

1673static char*
1674read_string (void)
1675{
char* p;
require_atom (ATOM_STRING);
p = atom_string;
atom_string = NULL__null;
return p;
1681}


1684/**************** Module output subroutines ***************************/

1686/* Output a character to a module file.  */

1688static void
1689write_char (char out)
1690{
if (gzputc (module_fp, out) == EOF(-1))
  gfc_fatal_error ("Error writing modules file: %s", xstrerror (errno(*__errno_location ())));

if (out != '\n')
  module_column++;
else
  {
    module_column = 1;
    module_line++;
  }
1701}


1704/* 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.  */

1708static void
1709write_atom (atom_type atom, const void *v)
1710{
char buffer[32];

/* Workaround -Wmaybe-uninitialized false positive during
   profiledbootstrap by initializing them.  */
int len;
HOST_WIDE_INTlong 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_INTlong *) v);

    snprintf (buffer, sizeof (buffer), HOST_WIDE_INT_PRINT_DEC"%" "l" "d", i);
    p = buffer;
    break;

  default:
    gfc_internal_error ("write_atom(): Trying to write dab atom");

  }

if(p == NULL__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__null && *p)
  {
    if (atom == ATOM_STRING && *p == '\'')
write_char ('\'');
    write_char (*p++);
  }

if (atom == ATOM_STRING)
  write_char ('\'');

last_atom = atom;
1777}



1781/***************** Mid-level I/O subroutines *****************/

1783/* 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.  */

1788static void mio_expr (gfc_expr **);
1789pointer_info *mio_symbol_ref (gfc_symbol **);
1790pointer_info *mio_interface_rest (gfc_interface **);
1791static void mio_symtree_ref (gfc_symtree **);

1793/* 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.  */

1797static int
1798mio_name (int t, const mstring *m)
1799{
if (iomode == IO_OUTPUT)
  write_atom (ATOM_NAME, gfc_code2string (m, t));
else
  {
    require_atom (ATOM_NAME);
    t = find_enum (m);
  }

return t;
1809}

1811/* Specialization of mio_name.  */

1813#define DECL_MIO_NAME(TYPE) \
static inline TYPE \
MIO_NAME(TYPE)mio_name_TYPE (TYPE t, const mstring *m) \
{ \
 return (TYPE) mio_name ((int) t, m); \
}
1819#define MIO_NAME(TYPE)mio_name_TYPE mio_name_##TYPE

1821static void
1822mio_lparen (void)
1823{
if (iomode == IO_OUTPUT)
  write_atom (ATOM_LPAREN, NULL__null);
else
  require_atom (ATOM_LPAREN);
1828}


1831static void
1832mio_rparen (void)
1833{
if (iomode == IO_OUTPUT)
  write_atom (ATOM_RPAREN, NULL__null);
else
  require_atom (ATOM_RPAREN);
1838}


1841static void
1842mio_integer (int *ip)
1843{
if (iomode == IO_OUTPUT)
27
←
Assuming 'iomode' is equal to IO_OUTPUT→
28
←
Taking true branch→
  {
    HOST_WIDE_INTlong hwi = *ip;
29
←
Assigned value is garbage or undefined
    write_atom (ATOM_INTEGER, &hwi);
  }
else
  {
    require_atom (ATOM_INTEGER);
    *ip = atom_int;
  }
1854}

1856static void
1857mio_hwi (HOST_WIDE_INTlong *hwi)
1858{
if (iomode == IO_OUTPUT)
  write_atom (ATOM_INTEGER, hwi);
else
  {
    require_atom (ATOM_INTEGER);
    *hwi = atom_int;
  }
1866}


1869/* Read or write a gfc_intrinsic_op value.  */

1871static void
1872mio_intrinsic_op (gfc_intrinsic_op* op)
1873{
/* FIXME: Would be nicer to do this via the operators symbolic name.  */
if (iomode == IO_OUTPUT)
  {
    HOST_WIDE_INTlong converted = (HOST_WIDE_INTlong) *op;
    write_atom (ATOM_INTEGER, &converted);
  }
else
  {
    require_atom (ATOM_INTEGER);
    *op = (gfc_intrinsic_op) atom_int;
  }
1885}


1888/* Read or write a character pointer that points to a string on the heap.  */

1890static const char *
1891mio_allocated_string (const char *s)
1892{
if (iomode == IO_OUTPUT)
  {
    write_atom (ATOM_STRING, s);
    return s;
  }
else
  {
    require_atom (ATOM_STRING);
    return atom_string;
  }
1903}


1906/* Functions for quoting and unquoting strings.  */

1908static char *
1909quote_string (const gfc_char_t *s, const size_t slength)
1910{
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)((char *) xcalloc ((len + 1), sizeof (char)));
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"l" "x",
   (unsigned HOST_WIDE_INTlong) *p);
 q += 10;
}
    else
*q++ = (unsigned char) *p;
  }

res[len] = '\0';
return res;
1944}

1946static gfc_char_t *
1947unquote_string (const char *s)
1948{
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)((gfc_char_t *) xcalloc ((len + 1), sizeof (gfc_char_t)));
for (i = 0, p = s; i < len; i++, p++)
  {
    gcc_assert (*p)((void)(!(*p) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/module.cc"
, 1969, __FUNCTION__), 0 : 0));

    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')((void)(!(p[1] == 'U') ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/module.cc"
, 1985, __FUNCTION__), 0 : 0));
 for (j = 0; j < 8; j++)
   {
     c = c << 4;
     gcc_assert (sscanf (&p[j+2], "%01x", &n) == 1)((void)(!(sscanf (&p[j+2], "%01x", &n) == 1) ? fancy_abort
 ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/module.cc"
, 1989, __FUNCTION__), 0 : 0));
     c += n;
   }

 res[i] = c;
 p += 9;
}
  }

res[len] = '\0';
return res;
2000}


2003/* 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.  */

2008static const gfc_char_t *
2009mio_allocated_wide_string (const gfc_char_t *s, const size_t length)
2010{
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;
  }
2027}


2030/* Read or write a string that is in static memory.  */

2032static void
2033mio_pool_string (const char **stringp)
2034{
/* 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__null ? "" : *stringp;
    write_atom (ATOM_STRING, p);
  }
else
  {
    require_atom (ATOM_STRING);
    *stringp = (atom_string[0] == '\0'
  ? NULL__null : gfc_get_string ("%s", atom_string));
    free (atom_string);
  }
2053}


2056/* Read or write a string that is inside of some already-allocated
 structure.  */

2059static void
2060mio_internal_string (char *string)
2061{
if (iomode == IO_OUTPUT)
  write_atom (ATOM_STRING, string);
else
  {
    require_atom (ATOM_STRING);
    strcpy (string, atom_string);
    free (atom_string);
  }
2070}


2073enum ab_attribute
2074{ 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
2098};

2100static const mstring attr_bits[] =
2101{
  minit ("ALLOCATABLE", AB_ALLOCATABLE){ "ALLOCATABLE", __null, AB_ALLOCATABLE },
  minit ("ARTIFICIAL", AB_ARTIFICIAL){ "ARTIFICIAL", __null, AB_ARTIFICIAL },
  minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS){ "ASYNCHRONOUS", __null, AB_ASYNCHRONOUS },
  minit ("DIMENSION", AB_DIMENSION){ "DIMENSION", __null, AB_DIMENSION },
  minit ("CODIMENSION", AB_CODIMENSION){ "CODIMENSION", __null, AB_CODIMENSION },
  minit ("CONTIGUOUS", AB_CONTIGUOUS){ "CONTIGUOUS", __null, AB_CONTIGUOUS },
  minit ("EXTERNAL", AB_EXTERNAL){ "EXTERNAL", __null, AB_EXTERNAL },
  minit ("INTRINSIC", AB_INTRINSIC){ "INTRINSIC", __null, AB_INTRINSIC },
  minit ("OPTIONAL", AB_OPTIONAL){ "OPTIONAL", __null, AB_OPTIONAL },
  minit ("POINTER", AB_POINTER){ "POINTER", __null, AB_POINTER },
  minit ("VOLATILE", AB_VOLATILE){ "VOLATILE", __null, AB_VOLATILE },
  minit ("TARGET", AB_TARGET){ "TARGET", __null, AB_TARGET },
  minit ("THREADPRIVATE", AB_THREADPRIVATE){ "THREADPRIVATE", __null, AB_THREADPRIVATE },
  minit ("DUMMY", AB_DUMMY){ "DUMMY", __null, AB_DUMMY },
  minit ("RESULT", AB_RESULT){ "RESULT", __null, AB_RESULT },
  minit ("DATA", AB_DATA){ "DATA", __null, AB_DATA },
  minit ("IN_NAMELIST", AB_IN_NAMELIST){ "IN_NAMELIST", __null, AB_IN_NAMELIST },
  minit ("IN_COMMON", AB_IN_COMMON){ "IN_COMMON", __null, AB_IN_COMMON },
  minit ("FUNCTION", AB_FUNCTION){ "FUNCTION", __null, AB_FUNCTION },
  minit ("SUBROUTINE", AB_SUBROUTINE){ "SUBROUTINE", __null, AB_SUBROUTINE },
  minit ("SEQUENCE", AB_SEQUENCE){ "SEQUENCE", __null, AB_SEQUENCE },
  minit ("ELEMENTAL", AB_ELEMENTAL){ "ELEMENTAL", __null, AB_ELEMENTAL },
  minit ("PURE", AB_PURE){ "PURE", __null, AB_PURE },
  minit ("RECURSIVE", AB_RECURSIVE){ "RECURSIVE", __null, AB_RECURSIVE },
  minit ("GENERIC", AB_GENERIC){ "GENERIC", __null, AB_GENERIC },
  minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT){ "ALWAYS_EXPLICIT", __null, AB_ALWAYS_EXPLICIT },
  minit ("CRAY_POINTER", AB_CRAY_POINTER){ "CRAY_POINTER", __null, AB_CRAY_POINTER },
  minit ("CRAY_POINTEE", AB_CRAY_POINTEE){ "CRAY_POINTEE", __null, AB_CRAY_POINTEE },
  minit ("IS_BIND_C", AB_IS_BIND_C){ "IS_BIND_C", __null, AB_IS_BIND_C },
  minit ("IS_C_INTEROP", AB_IS_C_INTEROP){ "IS_C_INTEROP", __null, AB_IS_C_INTEROP },
  minit ("IS_ISO_C", AB_IS_ISO_C){ "IS_ISO_C", __null, AB_IS_ISO_C },
  minit ("VALUE", AB_VALUE){ "VALUE", __null, AB_VALUE },
  minit ("ALLOC_COMP", AB_ALLOC_COMP){ "ALLOC_COMP", __null, AB_ALLOC_COMP },
  minit ("COARRAY_COMP", AB_COARRAY_COMP){ "COARRAY_COMP", __null, AB_COARRAY_COMP },
  minit ("LOCK_COMP", AB_LOCK_COMP){ "LOCK_COMP", __null, AB_LOCK_COMP },
  minit ("EVENT_COMP", AB_EVENT_COMP){ "EVENT_COMP", __null, AB_EVENT_COMP },
  minit ("POINTER_COMP", AB_POINTER_COMP){ "POINTER_COMP", __null, AB_POINTER_COMP },
  minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP){ "PROC_POINTER_COMP", __null, AB_PROC_POINTER_COMP },
  minit ("PRIVATE_COMP", AB_PRIVATE_COMP){ "PRIVATE_COMP", __null, AB_PRIVATE_COMP },
  minit ("ZERO_COMP", AB_ZERO_COMP){ "ZERO_COMP", __null, AB_ZERO_COMP },
  minit ("PROTECTED", AB_PROTECTED){ "PROTECTED", __null, AB_PROTECTED },
  minit ("ABSTRACT", AB_ABSTRACT){ "ABSTRACT", __null, AB_ABSTRACT },
  minit ("IS_CLASS", AB_IS_CLASS){ "IS_CLASS", __null, AB_IS_CLASS },
  minit ("PROCEDURE", AB_PROCEDURE){ "PROCEDURE", __null, AB_PROCEDURE },
  minit ("PROC_POINTER", AB_PROC_POINTER){ "PROC_POINTER", __null, AB_PROC_POINTER },
  minit ("VTYPE", AB_VTYPE){ "VTYPE", __null, AB_VTYPE },
  minit ("VTAB", AB_VTAB){ "VTAB", __null, AB_VTAB },
  minit ("CLASS_POINTER", AB_CLASS_POINTER){ "CLASS_POINTER", __null, AB_CLASS_POINTER },
  minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE){ "IMPLICIT_PURE", __null, AB_IMPLICIT_PURE },
  minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY){ "UNLIMITED_POLY", __null, AB_UNLIMITED_POLY },
  minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET){ "OMP_DECLARE_TARGET", __null, AB_OMP_DECLARE_TARGET },
  minit ("ARRAY_OUTER_DEPENDENCY", AB_ARRAY_OUTER_DEPENDENCY){ "ARRAY_OUTER_DEPENDENCY", __null, AB_ARRAY_OUTER_DEPENDENCY
 },
  minit ("MODULE_PROCEDURE", AB_MODULE_PROCEDURE){ "MODULE_PROCEDURE", __null, AB_MODULE_PROCEDURE },
  minit ("OACC_DECLARE_CREATE", AB_OACC_DECLARE_CREATE){ "OACC_DECLARE_CREATE", __null, AB_OACC_DECLARE_CREATE },
  minit ("OACC_DECLARE_COPYIN", AB_OACC_DECLARE_COPYIN){ "OACC_DECLARE_COPYIN", __null, AB_OACC_DECLARE_COPYIN },
  minit ("OACC_DECLARE_DEVICEPTR", AB_OACC_DECLARE_DEVICEPTR){ "OACC_DECLARE_DEVICEPTR", __null, AB_OACC_DECLARE_DEVICEPTR
 },
  minit ("OACC_DECLARE_DEVICE_RESIDENT", AB_OACC_DECLARE_DEVICE_RESIDENT){ "OACC_DECLARE_DEVICE_RESIDENT", __null, AB_OACC_DECLARE_DEVICE_RESIDENT
 },
  minit ("OACC_DECLARE_LINK", AB_OACC_DECLARE_LINK){ "OACC_DECLARE_LINK", __null, AB_OACC_DECLARE_LINK },
  minit ("OMP_DECLARE_TARGET_LINK", AB_OMP_DECLARE_TARGET_LINK){ "OMP_DECLARE_TARGET_LINK", __null, AB_OMP_DECLARE_TARGET_LINK
 },
  minit ("PDT_KIND", AB_PDT_KIND){ "PDT_KIND", __null, AB_PDT_KIND },
  minit ("PDT_LEN", AB_PDT_LEN){ "PDT_LEN", __null, AB_PDT_LEN },
  minit ("PDT_TYPE", AB_PDT_TYPE){ "PDT_TYPE", __null, AB_PDT_TYPE },
  minit ("PDT_TEMPLATE", AB_PDT_TEMPLATE){ "PDT_TEMPLATE", __null, AB_PDT_TEMPLATE },
  minit ("PDT_ARRAY", AB_PDT_ARRAY){ "PDT_ARRAY", __null, AB_PDT_ARRAY },
  minit ("PDT_STRING", AB_PDT_STRING){ "PDT_STRING", __null, AB_PDT_STRING },
  minit ("OACC_ROUTINE_LOP_GANG", AB_OACC_ROUTINE_LOP_GANG){ "OACC_ROUTINE_LOP_GANG", __null, AB_OACC_ROUTINE_LOP_GANG },
  minit ("OACC_ROUTINE_LOP_WORKER", AB_OACC_ROUTINE_LOP_WORKER){ "OACC_ROUTINE_LOP_WORKER", __null, AB_OACC_ROUTINE_LOP_WORKER
 },
  minit ("OACC_ROUTINE_LOP_VECTOR", AB_OACC_ROUTINE_LOP_VECTOR){ "OACC_ROUTINE_LOP_VECTOR", __null, AB_OACC_ROUTINE_LOP_VECTOR
 },
  minit ("OACC_ROUTINE_LOP_SEQ", AB_OACC_ROUTINE_LOP_SEQ){ "OACC_ROUTINE_LOP_SEQ", __null, AB_OACC_ROUTINE_LOP_SEQ },
  minit ("OACC_ROUTINE_NOHOST", AB_OACC_ROUTINE_NOHOST){ "OACC_ROUTINE_NOHOST", __null, AB_OACC_ROUTINE_NOHOST },
  minit ("OMP_REQ_REVERSE_OFFLOAD", AB_OMP_REQ_REVERSE_OFFLOAD){ "OMP_REQ_REVERSE_OFFLOAD", __null, AB_OMP_REQ_REVERSE_OFFLOAD
 },
  minit ("OMP_REQ_UNIFIED_ADDRESS", AB_OMP_REQ_UNIFIED_ADDRESS){ "OMP_REQ_UNIFIED_ADDRESS", __null, AB_OMP_REQ_UNIFIED_ADDRESS
 },
  minit ("OMP_REQ_UNIFIED_SHARED_MEMORY", AB_OMP_REQ_UNIFIED_SHARED_MEMORY){ "OMP_REQ_UNIFIED_SHARED_MEMORY", __null, AB_OMP_REQ_UNIFIED_SHARED_MEMORY
 },
  minit ("OMP_REQ_DYNAMIC_ALLOCATORS", AB_OMP_REQ_DYNAMIC_ALLOCATORS){ "OMP_REQ_DYNAMIC_ALLOCATORS", __null, AB_OMP_REQ_DYNAMIC_ALLOCATORS
 },
  minit ("OMP_REQ_MEM_ORDER_SEQ_CST", AB_OMP_REQ_MEM_ORDER_SEQ_CST){ "OMP_REQ_MEM_ORDER_SEQ_CST", __null, AB_OMP_REQ_MEM_ORDER_SEQ_CST
 },
  minit ("OMP_REQ_MEM_ORDER_ACQ_REL", AB_OMP_REQ_MEM_ORDER_ACQ_REL){ "OMP_REQ_MEM_ORDER_ACQ_REL", __null, AB_OMP_REQ_MEM_ORDER_ACQ_REL
 },
  minit ("OMP_REQ_MEM_ORDER_RELAXED", AB_OMP_REQ_MEM_ORDER_RELAXED){ "OMP_REQ_MEM_ORDER_RELAXED", __null, AB_OMP_REQ_MEM_ORDER_RELAXED
 },
  minit ("OMP_DEVICE_TYPE_HOST", AB_OMP_DEVICE_TYPE_HOST){ "OMP_DEVICE_TYPE_HOST", __null, AB_OMP_DEVICE_TYPE_HOST },
  minit ("OMP_DEVICE_TYPE_NOHOST", AB_OMP_DEVICE_TYPE_NOHOST){ "OMP_DEVICE_TYPE_NOHOST", __null, AB_OMP_DEVICE_TYPE_NOHOST
 },
  minit ("OMP_DEVICE_TYPE_ANYHOST", AB_OMP_DEVICE_TYPE_ANY){ "OMP_DEVICE_TYPE_ANYHOST", __null, AB_OMP_DEVICE_TYPE_ANY },
  minit (NULL, -1){ __null, __null, -1 }
2183};

2185/* For binding attributes.  */
2186static const mstring binding_passing[] =
2187{
  minit ("PASS", 0){ "PASS", __null, 0 },
  minit ("NOPASS", 1){ "NOPASS", __null, 1 },
  minit (NULL, -1){ __null, __null, -1 }
2191};
2192static const mstring binding_overriding[] =
2193{
  minit ("OVERRIDABLE", 0){ "OVERRIDABLE", __null, 0 },
  minit ("NON_OVERRIDABLE", 1){ "NON_OVERRIDABLE", __null, 1 },
  minit ("DEFERRED", 2){ "DEFERRED", __null, 2 },
  minit (NULL, -1){ __null, __null, -1 }
2198};
2199static const mstring binding_generic[] =
2200{
  minit ("SPECIFIC", 0){ "SPECIFIC", __null, 0 },
  minit ("GENERIC", 1){ "GENERIC", __null, 1 },
  minit (NULL, -1){ __null, __null, -1 }
2204};
2205static const mstring binding_ppc[] =
2206{
  minit ("NO_PPC", 0){ "NO_PPC", __null, 0 },
  minit ("PPC", 1){ "PPC", __null, 1 },
  minit (NULL, -1){ __null, __null, -1 }
2210};

2212/* Specialization of mio_name.  */
2213DECL_MIO_NAME (ab_attribute)
2214DECL_MIO_NAME (ar_type)
2215DECL_MIO_NAME (array_type)
2216DECL_MIO_NAME (bt)
2217DECL_MIO_NAME (expr_t)
2218DECL_MIO_NAME (gfc_access)
2219DECL_MIO_NAME (gfc_intrinsic_op)
2220DECL_MIO_NAME (ifsrc)
2221DECL_MIO_NAME (save_state)
2222DECL_MIO_NAME (procedure_type)
2223DECL_MIO_NAME (ref_type)
2224DECL_MIO_NAME (sym_flavor)
2225DECL_MIO_NAME (sym_intent)
2226DECL_MIO_NAME (inquiry_type)
2227#undef DECL_MIO_NAME

2229/* Verify OACC_ROUTINE_LOP_NONE.  */

2231static void
2232verify_OACC_ROUTINE_LOP_NONE (enum oacc_routine_lop lop)
2233{
if (lop != OACC_ROUTINE_LOP_NONE)
  bad_module ("Unsupported: multiple OpenACC 'routine' levels of parallelism");
2236}

2238/* 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.  */

2244static void
2245mio_symbol_attribute (symbol_attribute *attr)
2246{
atom_type t;
unsigned ext_attr,extension_level;

mio_lparen ();

attr->flavor = MIO_NAME (sym_flavor)mio_name_sym_flavor (attr->flavor, flavors);
attr->intent = MIO_NAME (sym_intent)mio_name_sym_intent (attr->intent, intents);
attr->proc = MIO_NAME (procedure_type)mio_name_procedure_type (attr->proc, procedures);
attr->if_source = MIO_NAME (ifsrc)mio_name_ifsrc (attr->if_source, ifsrc_types);
attr->save = MIO_NAME (save_state)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)mio_name_ab_attribute (AB_ALLOCATABLE, attr_bits);
    if (attr->artificial)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_ARTIFICIAL, attr_bits);
    if (attr->asynchronous)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_ASYNCHRONOUS, attr_bits);
    if (attr->dimension)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_DIMENSION, attr_bits);
    if (attr->codimension)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_CODIMENSION, attr_bits);
    if (attr->contiguous)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_CONTIGUOUS, attr_bits);
    if (attr->external)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_EXTERNAL, attr_bits);
    if (attr->intrinsic)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_INTRINSIC, attr_bits);
    if (attr->optional)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_OPTIONAL, attr_bits);
    if (attr->pointer)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_POINTER, attr_bits);
    if (attr->class_pointer)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_CLASS_POINTER, attr_bits);
    if (attr->is_protected)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_PROTECTED, attr_bits);
    if (attr->value)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_VALUE, attr_bits);
    if (attr->volatile_)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_VOLATILE, attr_bits);
    if (attr->target)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_TARGET, attr_bits);
    if (attr->threadprivate)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_THREADPRIVATE, attr_bits);
    if (attr->dummy)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_DUMMY, attr_bits);
    if (attr->result)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_RESULT, attr_bits);
    /* We deliberately don't preserve the "entry" flag.  */

    if (attr->data)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_DATA, attr_bits);
    if (attr->in_namelist)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_IN_NAMELIST, attr_bits);
    if (attr->in_common)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_IN_COMMON, attr_bits);

    if (attr->function)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_FUNCTION, attr_bits);
    if (attr->subroutine)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_SUBROUTINE, attr_bits);
    if (attr->generic)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_GENERIC, attr_bits);
    if (attr->abstract)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_ABSTRACT, attr_bits);

    if (attr->sequence)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_SEQUENCE, attr_bits);
    if (attr->elemental)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_ELEMENTAL, attr_bits);
    if (attr->pure)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_PURE, attr_bits);
    if (attr->implicit_pure)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_IMPLICIT_PURE, attr_bits);
    if (attr->unlimited_polymorphic)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_UNLIMITED_POLY, attr_bits);
    if (attr->recursive)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_RECURSIVE, attr_bits);
    if (attr->always_explicit)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_ALWAYS_EXPLICIT, attr_bits);
    if (attr->cray_pointer)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_CRAY_POINTER, attr_bits);
    if (attr->cray_pointee)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_CRAY_POINTEE, attr_bits);
    if (attr->is_bind_c)
MIO_NAME(ab_attribute)mio_name_ab_attribute (AB_IS_BIND_C, attr_bits);
    if (attr->is_c_interop)
MIO_NAME(ab_attribute)mio_name_ab_attribute (AB_IS_C_INTEROP, attr_bits);
    if (attr->is_iso_c)
MIO_NAME(ab_attribute)mio_name_ab_attribute (AB_IS_ISO_C, attr_bits);
    if (attr->alloc_comp)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_ALLOC_COMP, attr_bits);
    if (attr->pointer_comp)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_POINTER_COMP, attr_bits);
    if (attr->proc_pointer_comp)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_PROC_POINTER_COMP, attr_bits);
    if (attr->private_comp)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_PRIVATE_COMP, attr_bits);
    if (attr->coarray_comp)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_COARRAY_COMP, attr_bits);
    if (attr->lock_comp)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_LOCK_COMP, attr_bits);
    if (attr->event_comp)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_EVENT_COMP, attr_bits);
    if (attr->zero_comp)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_ZERO_COMP, attr_bits);
    if (attr->is_class)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_IS_CLASS, attr_bits);
    if (attr->procedure)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_PROCEDURE, attr_bits);
    if (attr->proc_pointer)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_PROC_POINTER, attr_bits);
    if (attr->vtype)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_VTYPE, attr_bits);
    if (attr->vtab)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_VTAB, attr_bits);
    if (attr->omp_declare_target)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_OMP_DECLARE_TARGET, attr_bits);
    if (attr->array_outer_dependency)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_ARRAY_OUTER_DEPENDENCY, attr_bits);
    if (attr->module_procedure)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_MODULE_PROCEDURE, attr_bits);
    if (attr->oacc_declare_create)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_OACC_DECLARE_CREATE, attr_bits);
    if (attr->oacc_declare_copyin)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_OACC_DECLARE_COPYIN, attr_bits);
    if (attr->oacc_declare_deviceptr)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_OACC_DECLARE_DEVICEPTR, attr_bits);
    if (attr->oacc_declare_device_resident)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_OACC_DECLARE_DEVICE_RESIDENT, attr_bits);
    if (attr->oacc_declare_link)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_OACC_DECLARE_LINK, attr_bits);
    if (attr->omp_declare_target_link)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_OMP_DECLARE_TARGET_LINK, attr_bits);
    if (attr->pdt_kind)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_PDT_KIND, attr_bits);
    if (attr->pdt_len)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_PDT_LEN, attr_bits);
    if (attr->pdt_type)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_PDT_TYPE, attr_bits);
    if (attr->pdt_template)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_PDT_TEMPLATE, attr_bits);
    if (attr->pdt_array)
MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_PDT_ARRAY, attr_bits);
    if (attr->pdt_string)
MIO_NAME (ab_attribute)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)mio_name_ab_attribute (AB_OACC_ROUTINE_LOP_GANG, attr_bits);
 break;
case OACC_ROUTINE_LOP_WORKER:
 MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_OACC_ROUTINE_LOP_WORKER, attr_bits);
 break;
case OACC_ROUTINE_LOP_VECTOR:
 MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_OACC_ROUTINE_LOP_VECTOR, attr_bits);
 break;
case OACC_ROUTINE_LOP_SEQ:
 MIO_NAME (ab_attribute)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 ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/module.cc"
, 2424, __FUNCTION__));
}
    if (attr->oacc_routine_nohost)
MIO_NAME (ab_attribute)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)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)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)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)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)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)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)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)mio_name_ab_attribute (AB_OMP_DEVICE_TYPE_HOST, attr_bits);
 break;
case OMP_DEVICE_TYPE_NOHOST:
 MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_OMP_DEVICE_TYPE_NOHOST, attr_bits);
 break;
case OMP_DEVICE_TYPE_ANY:
 MIO_NAME (ab_attribute)mio_name_ab_attribute (AB_OMP_DEVICE_TYPE_ANY, attr_bits);
 break;
default:
 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/module.cc"
, 2463, __FUNCTION__));
}
    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;
   }
}
  }
2744}


2747static const mstring bt_types[] = {
  minit ("INTEGER", BT_INTEGER){ "INTEGER", __null, BT_INTEGER },
  minit ("REAL", BT_REAL){ "REAL", __null, BT_REAL },
  minit ("COMPLEX", BT_COMPLEX){ "COMPLEX", __null, BT_COMPLEX },
  minit ("LOGICAL", BT_LOGICAL){ "LOGICAL", __null, BT_LOGICAL },
  minit ("CHARACTER", BT_CHARACTER){ "CHARACTER", __null, BT_CHARACTER },
  minit ("UNION", BT_UNION){ "UNION", __null, BT_UNION },
  minit ("DERIVED", BT_DERIVED){ "DERIVED", __null, BT_DERIVED },
  minit ("CLASS", BT_CLASS){ "CLASS", __null, BT_CLASS },
  minit ("PROCEDURE", BT_PROCEDURE){ "PROCEDURE", __null, BT_PROCEDURE },
  minit ("UNKNOWN", BT_UNKNOWN){ "UNKNOWN", __null, BT_UNKNOWN },
  minit ("VOID", BT_VOID){ "VOID", __null, BT_VOID },
  minit ("ASSUMED", BT_ASSUMED){ "ASSUMED", __null, BT_ASSUMED },
  minit (NULL, -1){ __null, __null, -1 }
2761};


2764static void
2765mio_charlen (gfc_charlen **clp)
2766{
gfc_charlen *cl;

mio_lparen ();

if (iomode == IO_OUTPUT)
  {
    cl = *clp;
    if (cl != NULL__null)
mio_expr (&cl->length);
  }
else
  {
    if (peek_atom () != ATOM_RPAREN)
{
 cl = gfc_new_charlen (gfc_current_ns, NULL__null);
 mio_expr (&cl->length);
 *clp = cl;
}
  }

mio_rparen ();
2788}


2791/* See if a name is a generated name.  */

2793static int
2794check_unique_name (const char *name)
2795{
return *name == '@';
2797}


2800static void
2801mio_typespec (gfc_typespec *ts)
2802{
mio_lparen ();

ts->type = MIO_NAME (bt)mio_name_bt (ts->type, bt_types);

if (!gfc_bt_struct (ts->type)((ts->type) == BT_DERIVED || (ts->type) == BT_UNION) && 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)mio_name_bt (ts->f90_type, bt_types);
else
  ts->f90_type = MIO_NAME (bt)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 ();
2850}


2853static const mstring array_spec_types[] = {
  minit ("EXPLICIT", AS_EXPLICIT){ "EXPLICIT", __null, AS_EXPLICIT },
  minit ("ASSUMED_RANK", AS_ASSUMED_RANK){ "ASSUMED_RANK", __null, AS_ASSUMED_RANK },
  minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE){ "ASSUMED_SHAPE", __null, AS_ASSUMED_SHAPE },
  minit ("DEFERRED", AS_DEFERRED){ "DEFERRED", __null, AS_DEFERRED },
  minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE){ "ASSUMED_SIZE", __null, AS_ASSUMED_SIZE },
  minit (NULL, -1){ __null, __null, -1 }
2860};


2863static void
2864mio_array_spec (gfc_array_spec **asp)
2865{
gfc_array_spec *as;
int i;

mio_lparen ();

if (iomode == IO_OUTPUT)
  {
    int rank;

    if (*asp == NULL__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__null;
 goto done;
}

    *asp = as = gfc_get_array_spec ()((gfc_array_spec *) xcalloc (1, sizeof (gfc_array_spec)));
    mio_integer (&as->rank);
  }

mio_integer (&as->corank);
as->type = MIO_NAME (array_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]);
    }

2910done:
mio_rparen ();
2912}


2915/* 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.  */

2921static const mstring array_ref_types[] = {
  minit ("FULL", AR_FULL){ "FULL", __null, AR_FULL },
  minit ("ELEMENT", AR_ELEMENT){ "ELEMENT", __null, AR_ELEMENT },
  minit ("SECTION", AR_SECTION){ "SECTION", __null, AR_SECTION },
  minit (NULL, -1){ __null, __null, -1 }
2926};


2929static void
2930mio_array_ref (gfc_array_ref *ar)
2931{
int i;

mio_lparen ();
ar->type = MIO_NAME (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_INTlong tmp = (HOST_WIDE_INTlong)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 ();
2992}


2995/* 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.  */

2999static pointer_info *
3000mio_pointer_ref (void *gp)
3001{
pointer_info *p;

if (iomode == IO_OUTPUT)
  {
    p = get_pointer (*((char **) gp));
    HOST_WIDE_INTlong hwi = p->integer;
    write_atom (ATOM_INTEGER, &hwi);
  }
else
  {
    require_atom (ATOM_INTEGER);
    p = add_fixup (atom_int, gp);
  }

return p;
3017}


3020/* 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.  */

3026static void
3027mio_component_ref (gfc_component **cp)
3028{
pointer_info *p;

p = mio_pointer_ref (cp);
if (p->type == P_UNKNOWN)
  p->type = P_COMPONENT;
3034}


3037static void mio_namespace_ref (gfc_namespace **nsp);
3038static void mio_formal_arglist (gfc_formal_arglist **formal);
3039static void mio_typebound_proc (gfc_typebound_proc** proc);
3040static void mio_actual_arglist (gfc_actual_arglist **ap, bool pdt);

3042static void
3043mio_component (gfc_component *c, int vtype)
3044{
pointer_info *p;

mio_lparen ();

if (iomode == IO_OUTPUT)
  {
    p = get_pointer (c);
    mio_hwi (&p->integer);
  }
else
  {
    HOST_WIDE_INTlong 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)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 ();
3090}


3093static void
3094mio_component_list (gfc_component **cp, int vtype)
3095{
gfc_component *c, *tail;

mio_lparen ();

if (iomode == IO_OUTPUT)
  {
    for (c = *cp; c; c = c->next)
mio_component (c, vtype);
  }
else
  {
    *cp = NULL__null;
    tail = NULL__null;

    for (;;)
{
 if (peek_atom () == ATOM_RPAREN)
   break;

 c = gfc_get_component ()((gfc_component *) xcalloc (1, sizeof (gfc_component)));
 mio_component (c, vtype);

 if (tail == NULL__null)
   *cp = c;
 else
   tail->next = c;

 tail = c;
}
  }

mio_rparen ();
3128}


3131static void
3132mio_actual_arg (gfc_actual_arglist *a, bool pdt)
3133{
mio_lparen ();
mio_pool_string (&a->name);
mio_expr (&a->expr);
if (pdt)
  mio_integer ((int *)&a->spec_type);
mio_rparen ();
3140}


3143static void
3144mio_actual_arglist (gfc_actual_arglist **ap, bool pdt)
3145{
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__null;

    for (;;)
{
 if (peek_atom () != ATOM_LPAREN)
   break;

 a = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist
)));

 if (tail == NULL__null)
   *ap = a;
 else
   tail->next = a;

 tail = a;
 mio_actual_arg (a, pdt);
}
  }

mio_rparen ();
3178}


3181/* Read and write formal argument lists.  */

3183static void
3184mio_formal_arglist (gfc_formal_arglist **formal)
3185{
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__null;

    while (peek_atom () != ATOM_RPAREN)
{
 f = gfc_get_formal_arglist ()((gfc_formal_arglist *) xcalloc (1, sizeof (gfc_formal_arglist
)));
 mio_symbol_ref (&f->sym);

 if (*formal == NULL__null)
   *formal = f;
 else
   tail->next = f;

 tail = f;
}
  }

mio_rparen ();
3214}


3217/* Save or restore a reference to a symbol node.  */

3219pointer_info *
3220mio_symbol_ref (gfc_symbol **symp)
3221{
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;
3239}


3242/* Save or restore a reference to a symtree node.  */

3244static void
3245mio_symtree_ref (gfc_symtree **stp)
3246{
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__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__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__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__null)
{
 *stp = p->u.rsym.symtree;
}
    else
{
 f = XCNEW (fixup_t)((fixup_t *) xcalloc (1, sizeof (fixup_t)));

 f->next = p->u.rsym.stfixup;
 p->u.rsym.stfixup = f;

 f->pointer = (void **) stp;
}
  }
3303}


3306static void
3307mio_iterator (gfc_iterator **ip)
3308{
gfc_iterator *iter;

mio_lparen ();

if (iomode == IO_OUTPUT)
  {
    if (*ip == NULL__null)
goto done;
  }
else
  {
    if (peek_atom () == ATOM_RPAREN)
{
 *ip = NULL__null;
 goto done;
}

    *ip = gfc_get_iterator ()((gfc_iterator *) xcalloc (1, sizeof (gfc_iterator)));
  }

iter = *ip;

mio_expr (&iter->var);
mio_expr (&iter->start);
mio_expr (&iter->end);
mio_expr (&iter->step);

3336done:
mio_rparen ();
3338}


3341static void
3342mio_constructor (gfc_constructor_base *cp)
3343{
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, NULL__null);

 mio_lparen ();
 mio_expr (&c->expr);
 mio_iterator (&c->iterator);
 mio_rparen ();
}
  }

mio_rparen ();
3372}


3375static const mstring ref_types[] = {
  minit ("ARRAY", REF_ARRAY){ "ARRAY", __null, REF_ARRAY },
  minit ("COMPONENT", REF_COMPONENT){ "COMPONENT", __null, REF_COMPONENT },
  minit ("SUBSTRING", REF_SUBSTRING){ "SUBSTRING", __null, REF_SUBSTRING },
  minit ("INQUIRY", REF_INQUIRY){ "INQUIRY", __null, REF_INQUIRY },
  minit (NULL, -1){ __null, __null, -1 }
3381};

3383static const mstring inquiry_types[] = {
  minit ("RE", INQUIRY_RE){ "RE", __null, INQUIRY_RE },
  minit ("IM", INQUIRY_IM){ "IM", __null, INQUIRY_IM },
  minit ("KIND", INQUIRY_KIND){ "KIND", __null, INQUIRY_KIND },
  minit ("LEN", INQUIRY_LEN){ "LEN", __null, INQUIRY_LEN },
  minit (NULL, -1){ __null, __null, -1 }
3389};


3392static void
3393mio_ref (gfc_ref **rp)
3394{
gfc_ref *r;

mio_lparen ();

r = *rp;
r->type = MIO_NAME (ref_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)mio_name_inquiry_type (r->u.i, inquiry_types);
    break;
  }

mio_rparen ();
3425}


3428static void
3429mio_ref_list (gfc_ref **rp)
3430{
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__null;

    while (peek_atom () != ATOM_RPAREN)
{
 if (head == NULL__null)
   head = tail = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref)));
 else
   {
     tail->next = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref)));
     tail = tail->next;
   }

 mio_ref (&tail);
}

    *rp = head;
  }

mio_rparen ();
3461}


3464/* Read and write an integer value.  */

3466static void
3467mio_gmp_integer (mpz_t *integer)
3468{
char *p;

if (iomode == IO_INPUT)
  {
    if (parse_atom () != ATOM_STRING)
bad_module ("Expected integer string");

    mpz_init__gmpz_init (*integer);
    if (mpz_set_str__gmpz_set_str (*integer, atom_string, 10))
bad_module ("Error converting integer");

    free (atom_string);
  }
else
  {
    p = mpz_get_str__gmpz_get_str (NULL__null, 10, *integer);
    write_atom (ATOM_STRING, p);
    free (p);
  }
3488}


3491static void
3492mio_gmp_real (mpfr_t *real)
3493{
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_MODEMPFR_RNDN);
    free (atom_string);
  }
else
  {
    p = mpfr_get_str (NULL__null, &exponent, 16, 0, *real, GFC_RND_MODEMPFR_RNDN);

    if (mpfr_nan_p (*real)(((mpfr_srcptr) (0 ? (*real) : (mpfr_srcptr) (*real)))->_mpfr_exp
 == (1 - ((mpfr_exp_t) (((mpfr_uexp_t) -1) >> 1)))) || mpfr_inf_p (*real)(((mpfr_srcptr) (0 ? (*real) : (mpfr_srcptr) (*real)))->_mpfr_exp
 == (2 - ((mpfr_exp_t) (((mpfr_uexp_t) -1) >> 1)))))
{
 write_atom (ATOM_STRING, p);
 free (p);
 return;
}

    atom_string = XCNEWVEC (char, strlen (p) + 20)((char *) xcalloc ((strlen (p) + 20), sizeof (char)));

    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);
  }
3534}


3537/* Save and restore the shape of an array constructor.  */

3539static void
3540mio_shape (mpz_t **pshape, int rank)
3541{
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__null;
 mio_rparen ();
 return;
}

    shape = gfc_get_shape (rank)(((mpz_t *) xcalloc (((rank)), sizeof (mpz_t))));
    *pshape = shape;
  }

for (n = 0; n < rank; n++)
  mio_gmp_integer (&shape[n]);

mio_rparen ();
3576}


3579static const mstring expr_types[] = {
  minit ("OP", EXPR_OP){ "OP", __null, EXPR_OP },
  minit ("FUNCTION", EXPR_FUNCTION){ "FUNCTION", __null, EXPR_FUNCTION },
  minit ("CONSTANT", EXPR_CONSTANT){ "CONSTANT", __null, EXPR_CONSTANT },
  minit ("VARIABLE", EXPR_VARIABLE){ "VARIABLE", __null, EXPR_VARIABLE },
  minit ("SUBSTRING", EXPR_SUBSTRING){ "SUBSTRING", __null, EXPR_SUBSTRING },
  minit ("STRUCTURE", EXPR_STRUCTURE){ "STRUCTURE", __null, EXPR_STRUCTURE },
  minit ("ARRAY", EXPR_ARRAY){ "ARRAY", __null, EXPR_ARRAY },
  minit ("NULL", EXPR_NULL){ "NULL", __null, EXPR_NULL },
  minit ("COMPCALL", EXPR_COMPCALL){ "COMPCALL", __null, EXPR_COMPCALL },
  minit (NULL, -1){ __null, __null, -1 }
3590};

3592/* 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.  */

3596static const mstring intrinsics[] =
3597{
  minit ("UPLUS", INTRINSIC_UPLUS){ "UPLUS", __null, INTRINSIC_UPLUS },
  minit ("UMINUS", INTRINSIC_UMINUS){ "UMINUS", __null, INTRINSIC_UMINUS },
  minit ("PLUS", INTRINSIC_PLUS){ "PLUS", __null, INTRINSIC_PLUS },
  minit ("MINUS", INTRINSIC_MINUS){ "MINUS", __null, INTRINSIC_MINUS },
  minit ("TIMES", INTRINSIC_TIMES){ "TIMES", __null, INTRINSIC_TIMES },
  minit ("DIVIDE", INTRINSIC_DIVIDE){ "DIVIDE", __null, INTRINSIC_DIVIDE },
  minit ("POWER", INTRINSIC_POWER){ "POWER", __null, INTRINSIC_POWER },
  minit ("CONCAT", INTRINSIC_CONCAT){ "CONCAT", __null, INTRINSIC_CONCAT },
  minit ("AND", INTRINSIC_AND){ "AND", __null, INTRINSIC_AND },
  minit ("OR", INTRINSIC_OR){ "OR", __null, INTRINSIC_OR },
  minit ("EQV", INTRINSIC_EQV){ "EQV", __null, INTRINSIC_EQV },
  minit ("NEQV", INTRINSIC_NEQV){ "NEQV", __null, INTRINSIC_NEQV },
  minit ("EQ_SIGN", INTRINSIC_EQ){ "EQ_SIGN", __null, INTRINSIC_EQ },
  minit ("EQ", INTRINSIC_EQ_OS){ "EQ", __null, INTRINSIC_EQ_OS },
  minit ("NE_SIGN", INTRINSIC_NE){ "NE_SIGN", __null, INTRINSIC_NE },
  minit ("NE", INTRINSIC_NE_OS){ "NE", __null, INTRINSIC_NE_OS },
  minit ("GT_SIGN", INTRINSIC_GT){ "GT_SIGN", __null, INTRINSIC_GT },
  minit ("GT", INTRINSIC_GT_OS){ "GT", __null, INTRINSIC_GT_OS },
  minit ("GE_SIGN", INTRINSIC_GE){ "GE_SIGN", __null, INTRINSIC_GE },
  minit ("GE", INTRINSIC_GE_OS){ "GE", __null, INTRINSIC_GE_OS },
  minit ("LT_SIGN", INTRINSIC_LT){ "LT_SIGN", __null, INTRINSIC_LT },
  minit ("LT", INTRINSIC_LT_OS){ "LT", __null, INTRINSIC_LT_OS },
  minit ("LE_SIGN", INTRINSIC_LE){ "LE_SIGN", __null, INTRINSIC_LE },
  minit ("LE", INTRINSIC_LE_OS){ "LE", __null, INTRINSIC_LE_OS },
  minit ("NOT", INTRINSIC_NOT){ "NOT", __null, INTRINSIC_NOT },
  minit ("PARENTHESES", INTRINSIC_PARENTHESES){ "PARENTHESES", __null, INTRINSIC_PARENTHESES },
  minit ("USER", INTRINSIC_USER){ "USER", __null, INTRINSIC_USER },
  minit (NULL, -1){ __null, __null, -1 }
3626};


3629/* Remedy a couple of situations where the gfc_expr's can be defective.  */

3631static void
3632fix_mio_expr (gfc_expr *e)
3633{
gfc_symtree *ns_st = NULL__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)((e->symtree->n.sym->attr.flavor) == FL_DERIVED || (
e->symtree->n.sym->attr.flavor) == FL_UNION || (e->
symtree->n.sym->attr.flavor) == FL_STRUCT))
   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);
  }
3688}


3691/* Read and write expressions.  The form "()" is allowed to indicate a
 NULL expression.  */

3694static void
3695mio_expr (gfc_expr **ep)
3696{
HOST_WIDE_INTlong hwi;
gfc_expr *e;
atom_type t;
int flag;

mio_lparen ();

if (iomode == IO_OUTPUT)
  {
    if (*ep == NULL__null)
{
 mio_rparen ();
 return;
}

    e = *ep;
    MIO_NAME (expr_t)mio_name_expr_t (e->expr_type, expr_types);
  }
else
  {
    t = parse_atom ();
    if (t == ATOM_RPAREN)
{
 *ep = NULL__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)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__null)
{
  size_t len = strlen (name);
  char *name2 = XCNEWVEC (char, len + 2)((char *) xcalloc ((len + 2), sizeof (char)));
  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__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__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 *,(const_cast<gfc_char_t *> ((mio_allocated_wide_string (
e->value.character.string, e->value.character.length)))
)
      mio_allocated_wide_string (e->value.character.string,(const_cast<gfc_char_t *> ((mio_allocated_wide_string (
e->value.character.string, e->value.character.length)))
)
				 e->value.character.length))(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)((e->value.complex)->re));
 mio_gmp_real (&mpc_imagref (e->value.complex)((e->value.complex)->im));
 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 *,(const_cast<gfc_char_t *> ((mio_allocated_wide_string (
e->value.character.string, e->value.character.length)))
)
	  mio_allocated_wide_string (e->value.character.string,(const_cast<gfc_char_t *> ((mio_allocated_wide_string (
e->value.character.string, e->value.character.length)))
)
				     e->value.character.length))(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 ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/module.cc"
, 3933, __FUNCTION__));
    break;
  }

/* PDT types store the expression specification list here. */
mio_actual_arglist (&e->param_list, true);

mio_rparen ();
3941}


3944/* Read and write namelists.  */

3946static void
3947mio_namelist (gfc_symbol *sym)
3948{
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__null;
    while (peek_atom () != ATOM_RPAREN)
{
 n = gfc_get_namelist ()((gfc_namelist *) xcalloc (1, sizeof (gfc_namelist)));
 mio_symbol_ref (&n->sym);

 if (sym->namelist == NULL__null)
   sym->namelist = n;
 else
   m->next = n;

 m = n;
}
    sym->namelist_tail = m;
  }

mio_rparen ();
3977}


3980/* 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.  */

3985pointer_info *
3986mio_interface_rest (gfc_interface **ip)
3987{
gfc_interface *tail, *p;
pointer_info *pi = NULL__null;

if (iomode == IO_OUTPUT)
  {
    if (ip != NULL__null)
for (p = *ip; p; p = p->next)
 mio_symbol_ref (&p->sym);
  }
else
  {
    if (*ip == NULL__null)
tail = NULL__null;
    else
{
 tail = *ip;
 while (tail->next)
   tail = tail->next;
}

    for (;;)
{
 if (peek_atom () == ATOM_RPAREN)
   break;

 p = gfc_get_interface ()((gfc_interface *) xcalloc (1, sizeof (gfc_interface)));
 p->where = gfc_current_locus;
 pi = mio_symbol_ref (&p->sym);

 if (tail == NULL__null)
   *ip = p;
 else
   tail->next = p;

 tail = p;
}
  }

mio_rparen ();
return pi;
4028}


4031/* Save/restore a nameless operator interface.  */

4033static void
4034mio_interface (gfc_interface **ip)
4035{
mio_lparen ();
mio_interface_rest (ip);
4038}


4041/* Save/restore a named operator interface.  */

4043static void
4044mio_symbol_interface (const char **name, const char **module,
      gfc_interface **ip)
4046{
mio_lparen ();
mio_pool_string (name);
mio_pool_string (module);
mio_interface_rest (ip);
4051}


4054static void
4055mio_namespace_ref (gfc_namespace **nsp)
4056{
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__null)
{
 ns = gfc_get_namespace (NULL__null, 0);
 associate_integer_pointer (p, ns);
}
    else
ns->refs++;
  }
4076}


4079/* Save/restore the f2k_derived namespace of a derived-type symbol.  */

4081static gfc_namespace* current_f2k_derived;

4083static void
4084mio_typebound_proc (gfc_typebound_proc** proc)
4085{
int flag;
int overriding_flag;

if (iomode == IO_INPUT)
  {
    *proc = gfc_get_typebound_proc (NULL__null);
    (*proc)->where = gfc_current_locus;
  }
gcc_assert (*proc)((void)(!(*proc) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/module.cc"
, 4094, __FUNCTION__), 0 : 0));

mio_lparen ();

(*proc)->access = MIO_NAME (gfc_access)mio_name_gfc_access ((*proc)->access, access_types);

/* IO the NON_OVERRIDABLE/DEFERRED combination.  */
gcc_assert (!((*proc)->deferred && (*proc)->non_overridable))((void)(!(!((*proc)->deferred && (*proc)->non_overridable
)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/module.cc"
, 4101, __FUNCTION__), 0 : 0));
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))((void)(!(!((*proc)->deferred && (*proc)->non_overridable
)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/module.cc"
, 4106, __FUNCTION__), 0 : 0));

(*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__null;
 while (peek_atom () != ATOM_RPAREN)
   {
     gfc_symtree** sym_root;

     g = gfc_get_tbp_generic ()((gfc_tbp_generic *) xcalloc (1, sizeof (gfc_tbp_generic)));
     g->specific = NULL__null;

     mio_integer (&iop);
     g->is_operator = (bool) iop;

     require_atom (ATOM_STRING);
     sym_root = &current_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 ();
4161}

4163/* Walker-callback function for this purpose.  */
4164static void
4165mio_typebound_symtree (gfc_symtree* st)
4166{
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 ();
4179}

4181/* IO a full symtree (in all depth).  */
4182static void
4183mio_full_typebound_tree (gfc_symtree** root)
4184{
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 ();
4206}

4208static void
4209mio_finalizer (gfc_finalizer **f)
4210{
if (iomode == IO_OUTPUT)
  {
    gcc_assert (*f)((void)(!(*f) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/module.cc"
, 4213, __FUNCTION__), 0 : 0));
    gcc_assert ((*f)->proc_tree)((void)(!((*f)->proc_tree) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/module.cc"
, 4214, __FUNCTION__), 0 : 0)); /* Should already be resolved.  */
    mio_symtree_ref (&(*f)->proc_tree);
  }
else
  {
    *f = gfc_get_finalizer ()((gfc_finalizer *) xcalloc (1, sizeof (gfc_finalizer)));
    (*f)->where = gfc_current_locus; /* Value should not matter.  */
    (*f)->next = NULL__null;

    mio_symtree_ref (&(*f)->proc_tree);
    (*f)->proc_sym = NULL__null;
  }
4226}

4228static void
4229mio_f2k_derived (gfc_namespace *f2k)
4230{
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__null;
    while (peek_atom () != ATOM_RPAREN)
{
 gfc_finalizer *cur = NULL__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 ();
4290}

4292static void
4293mio_full_f2k_derived (gfc_symbol *sym)
4294{
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__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__null;
     ns->refs++;
     gfc_free_namespace (ns);
     ns = NULL__null;
   }

 mio_f2k_derived (sym->f2k_derived);
}
    else
gcc_assert (!sym->f2k_derived)((void)(!(!sym->f2k_derived) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/module.cc"
, 4327, __FUNCTION__), 0 : 0));
  }

mio_rparen ();
4331}

4333static const mstring omp_declare_simd_clauses[] =
4334{
  minit ("INBRANCH", 0){ "INBRANCH", __null, 0 },
  minit ("NOTINBRANCH", 1){ "NOTINBRANCH", __null, 1 },
  minit ("SIMDLEN", 2){ "SIMDLEN", __null, 2 },
  minit ("UNIFORM", 3){ "UNIFORM", __null, 3 },
  minit ("LINEAR", 4){ "LINEAR", __null, 4 },
  minit ("ALIGNED", 5){ "ALIGNED", __null, 5 },
  minit ("LINEAR_REF", 33){ "LINEAR_REF", __null, 33 },
  minit ("LINEAR_VAL", 34){ "LINEAR_VAL", __null, 34 },
  minit ("LINEAR_UVAL", 35){ "LINEAR_UVAL", __null, 35 },
  minit (NULL, -1){ __null, __null, -1 }
4345};

4347/* Handle !$omp declare simd.  */

4349static void
4350mio_omp_declare_simd (gfc_namespace *ns, gfc_omp_declare_simd **odsp)
4351{
if (iomode == IO_OUTPUT)
  {
    if (*odsp == NULL__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__null, NULL__null };

    require_atom (ATOM_NAME);
    *odsp = ods = gfc_get_omp_declare_simd ()((gfc_omp_declare_simd *) xcalloc (1, sizeof (gfc_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 ()((gfc_omp_clauses *) xcalloc (1, sizeof (gfc_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 ()((gfc_omp_namelist *) xcalloc (1, sizeof (gfc_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 ()((gfc_omp_namelist *) xcalloc (1, sizeof (gfc_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 ();
4451}


4454static const mstring omp_declare_reduction_stmt[] =
4455{
  minit ("ASSIGN", 0){ "ASSIGN", __null, 0 },
  minit ("CALL", 1){ "CALL", __null, 1 },
  minit (NULL, -1){ __null, __null, -1 }
4459};


4462static void
4463mio_omp_udr_expr (gfc_omp_udr *udr, gfc_symbol **sym1, gfc_symbol **sym2,
  gfc_namespace *ns, bool is_initializer)
4465{
if (iomode == IO_OUTPUT)
13
←
Assuming 'iomode' is not equal to IO_OUTPUT→
14
←
Taking false branch→
  {
    if ((*sym1)->module == NULL__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__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)((void)(!(p1->u.rsym.ns == p2->u.rsym.ns) ? fancy_abort
 ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/module.cc"
, 4501, __FUNCTION__), 0 : 0));
15
←
Assuming 'p1->u.rsym.ns' is equal to 'p2->u.rsym.ns'→
16
←
'?' condition is false→
    gcc_assert (p1->u.rsym.sym == NULL)((void)(!(p1->u.rsym.sym == __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/module.cc"
, 4502, __FUNCTION__), 0 : 0));
17
←
Assuming the condition is true→
18
←
'?' condition is false→
    /* 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_initializer18.1
'is_initializer' is false
 ? "omp_priv" : "omp_out", ns);
19
←
'?' condition is false→
    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)((void)(!(p2->u.rsym.sym == __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/module.cc"
, 4511, __FUNCTION__), 0 : 0));
20
←
Assuming the condition is true→
21
←
'?' condition is false→
    sym = gfc_new_symbol (is_initializer21.1
'is_initializer' is false
 ? "omp_orig" : "omp_in", ns);
22
←
'?' condition is false→
    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)
23
←
Assuming the condition is false→
24
←
Taking false branch→
{
 ns->code = gfc_get_code (EXEC_ASSIGN);
 mio_expr (&ns->code->expr1);
 mio_expr (&ns->code->expr2);
}
    else
{
 int flag;
25
←
'flag' declared without an initial value→
 ns->code = gfc_get_code (EXEC_CALL);
 mio_symtree_ref (&ns->code->symtree);
 mio_actual_arglist (&ns->code->ext.actual, false);

 mio_integer (&flag);
26
←
Calling 'mio_integer'→
 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;
  }
4543}


4546/* 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").   */

4551static void
4552mio_symbol (gfc_symbol *sym)
4553{
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__null)
  sym->component_access
    = MIO_NAME (gfc_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.  */
4608/*   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)((sym->attr.flavor) == FL_DERIVED || (sym->attr.flavor)
 == FL_UNION || (sym->attr.flavor) == FL_STRUCT))
  mio_integer (&(sym->hash_value));

if (sym->formal_ns
    && sym->formal_ns->proc_name == sym
    && sym->formal_ns->entries == NULL__null)
  mio_omp_declare_simd (sym->formal_ns, &sym->formal_ns->omp_declare_simd);

mio_rparen ();
4634}


4637/************************* Top level subroutines *************************/

4639/* 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.  */
4644static gfc_symtree *
4645find_symbol (gfc_symtree *st, const char *name,
    const char *module, int generic)
4647{
int c;
gfc_symtree *retval, *s;

if (st == NULL__null || st->n.sym == NULL__null)
  return NULL__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__null && !st->n.sym->attr.use_rename))
return st;
  }

retval = find_symbol (st->left, name, module, generic);

if (retval == NULL__null)
  retval = find_symbol (st->right, name, module, generic);

return retval;
4676}


4679/* 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).  */

4684static void
4685skip_list (int nest_level = 0)
4686{
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);
4712}


4715/* Load operator interfaces from the module.  Interfaces are unusual
 in that they attach themselves to existing symbols.  */

4718static void
4719load_operator_interfaces (void)
4720{
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_LEN63 + 1], module[2 * GFC_MAX_SYMBOL_LEN63 + 2];
gfc_user_op *uop;
pointer_info *pi = NULL__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__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__null))
continue;
     uop = gfc_get_uop (p);
     uop->op = gfc_get_interface ()((gfc_interface *) xcalloc (1, sizeof (gfc_interface)));
     uop->op->where = gfc_current_locus;
     add_fixup (pi->integer, &uop->op->sym);
   }
}
  }

mio_rparen ();
4770}


4773/* Load interfaces from the module.  Interfaces are unusual in that
 they attach themselves to existing symbols.  */

4776static void
4777load_generic_interfaces (void)
4778{
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_LEN63 + 1], module[2 * GFC_MAX_SYMBOL_LEN63 + 2];
gfc_symbol *sym;
gfc_interface *generic = NULL__null, *gen = NULL__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__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__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__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 ();
4904}


4907/* Load common blocks.  */

4909static void
4910load_commons (void)
4911{
char name[GFC_MAX_SYMBOL_LEN63 + 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))((const char *) (tree_check (((__builtin_constant_p (label) ?
 get_identifier_with_length ((label), strlen (label)) : get_identifier
 (label))), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/module.cc"
, 4940, __FUNCTION__, (IDENTIFIER_NODE)))->identifier.id.str
);
    XDELETEVEC (label)free ((void*) (label));

    mio_rparen ();
  }

mio_rparen ();
4947}


4950/* 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.  */

4954static void
4955load_equiv (void)
4956{
gfc_equiv *head, *tail, *end, *eq, *equiv;
bool duplicate;

mio_lparen ();
in_load_equiv = true;

end = gfc_current_ns->equiv;
while (end != NULL__null && end->next != NULL__null)
  end = end->next;

while (peek_atom () != ATOM_RPAREN) {
  mio_lparen ();
  head = tail = NULL__null;

  while(peek_atom () != ATOM_RPAREN)
    {
if (head == NULL__null)
 head = tail = gfc_get_equiv ()((gfc_equiv *) xcalloc (1, sizeof (gfc_equiv)));
else
 {
   tail->eq = gfc_get_equiv ()((gfc_equiv *) xcalloc (1, sizeof (gfc_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__null)
    gfc_current_ns->equiv = head;
  else
    end->next = head;

  if (head != NULL__null)
    end = head;

  mio_rparen ();
}

mio_rparen ();
in_load_equiv = false;
5020}


5023/* This function loads OpenMP user defined reductions.  */
5024static void
5025load_omp_udrs (void)
5026{
mio_lparen ();
while (peek_atom () != ATOM_RPAREN)
  {
    const char *name = NULL__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__null;
    if (rop == OMP_REDUCTION_USER && name[0] == '.')
{
 size_t len = strlen (name + 1);
 altname = XALLOCAVEC (char, len)((char *) __builtin_alloca(sizeof (char) * (len)));
 gcc_assert (name[len] == '.')((void)(!(name[len] == '.') ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/module.cc"
, 5063, __FUNCTION__), 0 : 0));
 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__null)
newname = NULL__null;
    if (newname == NULL__null)
{
 skip_list (1);
 continue;
}
    if (altname && newname != altname)
{
 size_t len = strlen (newname);
 altname = XALLOCAVEC (char, len + 3)((char *) __builtin_alloca(sizeof (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 ()((gfc_omp_udr *) xcalloc (1, sizeof (gfc_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 ();
5134}


5137/* 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.  */

5141static int
5142load_needed (pointer_info *p)
5143{
gfc_namespace *ns;
pointer_info *q;
gfc_symbol *sym;
int rv;

rv = 0;
if (p == NULL__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__null)
  {
    q = get_integer (p->u.rsym.ns);

    ns = (gfc_namespace *) q->u.pointer;
    if (ns == NULL__null)
{
 /* Create an interface namespace if necessary.  These are
    the namespaces that hold the formal parameters of module
    procedures.  */

 ns = gfc_get_namespace (NULL__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((const char *) (tree_check (((__builtin_constant_p (p->u.
rsym.binding_label) ? get_identifier_with_length ((p->u.rsym
.binding_label), strlen (p->u.rsym.binding_label)) : get_identifier
 (p->u.rsym.binding_label))), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/module.cc"
, 5190, __FUNCTION__, (IDENTIFIER_NODE)))->identifier.id.str
)
				 (p->u.rsym.binding_label))((const char *) (tree_check (((__builtin_constant_p (p->u.
rsym.binding_label) ? get_identifier_with_length ((p->u.rsym
.binding_label), strlen (p->u.rsym.binding_label)) : get_identifier
 (p->u.rsym.binding_label))), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/module.cc"
, 5190, __FUNCTION__, (IDENTIFIER_NODE)))->identifier.id.str
);

    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;
5228}


5231/* Recursive function for cleaning up things after a module has been read.  */

5233static void
5234read_cleanup (pointer_info *p)
5235{
gfc_symtree *st;
pointer_info *q;

if (p == NULL__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__null;
  }

/* Free unused symbols.  */
if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED)
  gfc_free_symbol (p->u.rsym.sym);
5277}


5280/* It is not quite enough to check for ambiguity in the symbols by
 the loaded symbol and the new symbol not being identical.  */
5282static bool
5283check_for_ambiguous (gfc_symtree *st, pointer_info *info)
5284{
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;
5324}


5327/* Read a module file.  */

5329static void
5330read_module (void)
5331{
module_locus operator_interfaces, user_operators, omp_udrs;
const char *p;
char name[GFC_MAX_SYMBOL_LEN63 + 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__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)free ((void*) (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__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)((sym->attr.flavor) == FL_DERIVED || (sym->attr.flavor)
 == FL_UNION || (sym->attr.flavor) == FL_STRUCT))
{
 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__null;
     int n = 0;

     mio_lparen (); /* component opening.  */
     mio_integer (&n);
     p = get_integer (n);
     if (p->u.pointer == NULL__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__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__null && strcmp (name, module_name) == 0)
   p = name;

 /* Exception: Always import vtabs & vtypes.  */
 if (p == NULL__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__null)
   {
     st = gfc_find_symtree (gfc_current_ns->sym_root, name);
     if (st != NULL__null
  && strcmp (st->n.sym->name, info->u.rsym.true_name) == 0
  && st->n.sym->module != NULL__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__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__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__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)(__builtin_constant_p (info->u.rsym.binding_label) ? get_identifier_with_length
 ((info->u.rsym.binding_label), strlen (info->u.rsym.binding_label
)) : get_identifier (info->u.rsym.binding_label));
      sym->binding_label = IDENTIFIER_POINTER (id)((const char *) (tree_check ((id), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/module.cc"
, 5563, __FUNCTION__, (IDENTIFIER_NODE)))->identifier.id.str
);
    }
}

     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__null, *v = NULL__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__null && v == NULL__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);
5729}


5732/* 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.  */

5738static bool dump_smod = false;

5740static bool
5741check_access (gfc_access specific_access, gfc_access default_access)
5742{
if (dump_smod)
  return true;

if (specific_access == ACCESS_PUBLIC)
  return TRUEtrue;
if (specific_access == ACCESS_PRIVATE)
  return FALSEfalse;

if (flag_module_privateglobal_options.x_flag_module_private)
  return default_access == ACCESS_PUBLIC;
else
  return default_access != ACCESS_PRIVATE;
5755}


5758bool
5759gfc_check_symbol_access (gfc_symbol *sym)
5760{
if (sym->attr.vtab || sym->attr.vtype)
  return true;
else
  return check_access (sym->attr.access, sym->ns->default_access);
5765}


5768/* A structure to remember which commons we've already written.  */

5770struct written_common
5771{
BBT_HEADER(written_common)int priority; struct written_common *left, *right;
const char *name, *label;
5774};

5776static struct written_common *written_commons = NULL__null;

5778/* Comparison function used for balancing the binary tree.  */

5780static int
5781compare_written_commons (void *a1, void *b1)
5782{
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));
5790}

5792/* Free a list of written commons.  */

5794static void
5795free_written_common (struct written_common *w)
5796{
if (!w)
  return;

if (w->left)
  free_written_common (w->left);
if (w->right)
  free_written_common (w->right);

free (w);
5806}

5808/* Write a common block to the module -- recursive helper function.  */

5810static void
5811write_common_0 (gfc_symtree *st, bool this_module)
5812{
gfc_common_head *p;
const char * name;
int flags;
const char *label;
struct written_common *w;
bool write_me = true;

if (st == NULL__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)((struct written_common *) xcalloc (1, sizeof (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);
5872}


5875/* Write a common, by initializing the list of written commons, calling
 the recursive function write_common_0() and cleaning up afterwards.  */

5878static void
5879write_common (gfc_symtree *st)
5880{
written_commons = NULL__null;
write_common_0 (st, true);
write_common_0 (st, false);
free_written_common (written_commons);
written_commons = NULL__null;
5886}


5889/* Write the blank common block to the module.  */

5891static void
5892write_blank_common (void)
5893{
const char * name = BLANK_COMMON_NAME"__BLNK__";
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__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 ();
5918}


5921/* Write equivalences to the module.  */

5923static void
5924write_equiv (void)
5925{
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__null)
   e->module = gfc_get_string ("%s.eq.%d", module_name, num);
 mio_allocated_string (e->module);
 mio_expr (&e->expr);
}

    num++;
    mio_rparen ();
  }
5945}


5948/* Write a symbol to the module.  */

5950static void
5951write_symbol (int n, gfc_symbol *sym)
5952{
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)((sym->attr.flavor) == FL_DERIVED || (sym->attr.flavor)
 == FL_UNION || (sym->attr.flavor) == FL_STRUCT))
  {
    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');
5982}


5985/* 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.  */

5989static void
5990write_symbol0 (gfc_symtree *st)
5991{
gfc_symbol *sym;
pointer_info *p;
bool dont_write = false;

if (st == NULL__null)
  return;

write_symbol0 (st->left);

sym = st->n.sym;
if (sym->module == NULL__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);
6026}


6029static void
6030write_omp_udr (gfc_omp_udr *udr)
6031{
switch (udr->rop)
8
←
Control jumps to the 'default' case at line 6068→
  {
  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)((char *) __builtin_alloca(sizeof (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__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)
9
←
Assuming field 'type' is not equal to BT_DERIVED→
10
←
Assuming field 'type' is not equal to BT_CLASS→
11
←
Taking false branch→
  {
    /* 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);
12
←
Calling 'mio_omp_udr_expr'→
if (udr->initializer_ns)
  mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig,
      udr->initializer_ns, true);
mio_rparen ();
6086}


6089static void
6090write_omp_udrs (gfc_symtree *st)
6091{
if (st == NULL__null)
1
Assuming 'st' is not equal to NULL→
2
←
Taking false branch→
4
←
Assuming 'st' is not equal to NULL→
5
←
Taking false branch→
  return;

write_omp_udrs (st->left);
3
←
Calling 'write_omp_udrs'→
gfc_omp_udr *udr;
for (udr = st->n.omp_udr; udr; udr = udr->next)
6
←
Loop condition is true.  Entering loop body→
  write_omp_udr (udr);
7
←
Calling 'write_omp_udr'→
write_omp_udrs (st->right);
6100}


6103/* Type for the temporary tree used when writing secondary symbols.  */

6105struct sorted_pointer_info
6106{
BBT_HEADER (sorted_pointer_info)int priority; struct sorted_pointer_info *left, *right;

pointer_info *p;
6110};

6112#define gfc_get_sorted_pointer_info()((sorted_pointer_info *) xcalloc (1, sizeof (sorted_pointer_info
))) XCNEW (sorted_pointer_info)((sorted_pointer_info *) xcalloc (1, sizeof (sorted_pointer_info
)))

6114/* Recursively traverse the temporary tree, free its contents.  */

6116static void
6117free_sorted_pointer_info_tree (sorted_pointer_info *p)
6118{
if (!p)
  return;

free_sorted_pointer_info_tree (p->left);
free_sorted_pointer_info_tree (p->right);

free (p);
6126}

6128/* Comparison function for the temporary tree.  */

6130static int
6131compare_sorted_pointer_info (void *_spi1, void *_spi2)
6132{
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;
6142}


6145/* 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.  */

6149static void
6150find_symbols_to_write(sorted_pointer_info **tree, pointer_info *p)
6151{
if (!p)
  return;

if (p->type == P_SYMBOL && p->u.wsym.state == NEEDS_WRITE)
  {
    sorted_pointer_info *sp = gfc_get_sorted_pointer_info()((sorted_pointer_info *) xcalloc (1, sizeof (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);
6165}


6168/* Recursive function that traverses the tree of symbols that need to be
 written and writes them in order.  */

6171static void
6172write_symbol1_recursion (sorted_pointer_info *sp)
6173{
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)((void)(!(p1->type == P_SYMBOL && p1->u.wsym.state
 == NEEDS_WRITE) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/module.cc"
, 6180, __FUNCTION__), 0 : 0));

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);
6187}


6190/* 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.  */

6199static int
6200write_symbol1 (pointer_info *p)
6201{
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__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;
6220}


6223/* Write operator interfaces associated with a symbol.  */

6225static void
6226write_operator (gfc_user_op *uop)
6227{
static char nullstring[] = "";
const char *p = nullstring;

if (uop->op == NULL__null || !check_access (uop->access, uop->ns->default_access))
  return;

mio_symbol_interface (&uop->name, &p, &uop->op);
6235}


6238/* Write generic interfaces from the namespace sym_root.  */

6240static void
6241write_generic (gfc_symtree *st)
6242{
gfc_symbol *sym;

if (st == NULL__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);
6261}


6264static void
6265write_symtree (gfc_symtree *st)
6266{
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(1<<4)))
  return;

p = find_pointer (sym);
if (p == NULL__null)
  gfc_internal_error ("write_symtree(): Symbol not written");

mio_pool_string (&st->name);
mio_integer (&st->ambiguous);
mio_hwi (&p->integer);
6305}


6308static void
6309write_module (void)
6310{
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__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 ();
6385}


6388/* Read a CRC32 sum from the gzip trailer of a module file.  Returns
 true on success, false on failure.  */

6391static bool
6392read_crc32_from_module_file (const char* filename, uLong* crc)
6393{
FILE *file;
char buf[4];
unsigned int val;

/* Open the file in binary mode.  */
if ((file = fopen (filename, "rb")) == NULL__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_END2) != 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;
6429}


6432/* 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.  */

6436static void
6437dump_module (const char *name, int dump_flag)
6438{
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".smod") + 1;
  }
else
  n = strlen (name) + strlen (MODULE_EXTENSION".mod") + 1;

if (gfc_option.module_dir != NULL__null)
  {
    n += strlen (gfc_option.module_dir);
    filename = (char *) alloca (n)__builtin_alloca(n);
    strcpy (filename, gfc_option.module_dir);
    strcat (filename, name);
  }
else
  {
    filename = (char *) alloca (n)__builtin_alloca(n);
    strcpy (filename, name);
  }

if (dump_smod)
  strcat (filename, SUBMODULE_EXTENSION".smod");
else
strcat (filename, MODULE_EXTENSION".mod");

/* Name of the temporary file used to write the module.  */
filename_tmp = (char *) alloca (n + 1)__builtin_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__null)
  gfc_fatal_error ("Cannot open module file %qs for writing at %C: %s",
     filename_tmp, xstrerror (errno(*__errno_location ())));

/* 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"15", lbasename (gfc_source_file));

/* Write the module itself.  */
iomode = IO_OUTPUT;

init_pi_tree ();

write_module ();

free_pi_tree (pi_root);
pi_root = NULL__null;
