LCOV - code coverage report
Current view: top level - gcc/fortran - module.cc (source / functions) Coverage Total Hit
Test: gcc.info Lines: 93.2 % 3639 3393
Test Date: 2024-03-23 14:05:01 Functions: 91.1 % 146 133
Legend: Lines: hit not hit | Branches: + taken - not taken # not executed Branches: - 0 0

             Branch data     Line data    Source code
       1                 :             : /* Handle modules, which amounts to loading and saving symbols and
       2                 :             :    their attendant structures.
       3                 :             :    Copyright (C) 2000-2024 Free Software Foundation, Inc.
       4                 :             :    Contributed by Andy Vaught
       5                 :             : 
       6                 :             : This file is part of GCC.
       7                 :             : 
       8                 :             : GCC is free software; you can redistribute it and/or modify it under
       9                 :             : the terms of the GNU General Public License as published by the Free
      10                 :             : Software Foundation; either version 3, or (at your option) any later
      11                 :             : version.
      12                 :             : 
      13                 :             : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
      14                 :             : WARRANTY; without even the implied warranty of MERCHANTABILITY or
      15                 :             : FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
      16                 :             : for more details.
      17                 :             : 
      18                 :             : You should have received a copy of the GNU General Public License
      19                 :             : along with GCC; see the file COPYING3.  If not see
      20                 :             : <http://www.gnu.org/licenses/>.  */
      21                 :             : 
      22                 :             : /* The syntax of gfortran modules resembles that of lisp lists, i.e. a
      23                 :             :    sequence of atoms, which can be left or right parenthesis, names,
      24                 :             :    integers or strings.  Parenthesis are always matched which allows
      25                 :             :    us to skip over sections at high speed without having to know
      26                 :             :    anything about the internal structure of the lists.  A "name" is
      27                 :             :    usually a fortran 95 identifier, but can also start with '@' in
      28                 :             :    order to reference a hidden symbol.
      29                 :             : 
      30                 :             :    The first line of a module is an informational message about what
      31                 :             :    created the module, the file it came from and when it was created.
      32                 :             :    The second line is a warning for people not to edit the module.
      33                 :             :    The rest of the module looks like:
      34                 :             : 
      35                 :             :    ( ( <Interface info for UPLUS> )
      36                 :             :      ( <Interface info for UMINUS> )
      37                 :             :      ...
      38                 :             :    )
      39                 :             :    ( ( <name of operator interface> <module of op interface> <i/f1> ... )
      40                 :             :      ...
      41                 :             :    )
      42                 :             :    ( ( <name of generic interface> <module of generic interface> <i/f1> ... )
      43                 :             :      ...
      44                 :             :    )
      45                 :             :    ( ( <common name> <symbol> <saved flag>)
      46                 :             :      ...
      47                 :             :    )
      48                 :             : 
      49                 :             :    ( equivalence list )
      50                 :             : 
      51                 :             :    ( <Symbol Number (in no particular order)>
      52                 :             :      <True name of symbol>
      53                 :             :      <Module name of symbol>
      54                 :             :      ( <symbol information> )
      55                 :             :      ...
      56                 :             :    )
      57                 :             :    ( <Symtree name>
      58                 :             :      <Ambiguous flag>
      59                 :             :      <Symbol number>
      60                 :             :      ...
      61                 :             :    )
      62                 :             : 
      63                 :             :    In general, symbols refer to other symbols by their symbol number,
      64                 :             :    which are zero based.  Symbols are written to the module in no
      65                 :             :    particular order.  */
      66                 :             : 
      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>
      81                 :             : 
      82                 :             : #define MODULE_EXTENSION ".mod"
      83                 :             : #define SUBMODULE_EXTENSION ".smod"
      84                 :             : 
      85                 :             : /* Don't put any single quote (') in MOD_VERSION, if you want it to be
      86                 :             :    recognized.  */
      87                 :             : #define MOD_VERSION "15"
      88                 :             : 
      89                 :             : 
      90                 :             : /* Structure that describes a position within a module file.  */
      91                 :             : 
      92                 :             : typedef struct
      93                 :             : {
      94                 :             :   int column, line;
      95                 :             :   long pos;
      96                 :             : }
      97                 :             : module_locus;
      98                 :             : 
      99                 :             : /* Structure for list of symbols of intrinsic modules.  */
     100                 :             : typedef struct
     101                 :             : {
     102                 :             :   int id;
     103                 :             :   const char *name;
     104                 :             :   int value;
     105                 :             :   int standard;
     106                 :             : }
     107                 :             : intmod_sym;
     108                 :             : 
     109                 :             : 
     110                 :             : typedef enum
     111                 :             : {
     112                 :             :   P_UNKNOWN = 0, P_OTHER, P_NAMESPACE, P_COMPONENT, P_SYMBOL
     113                 :             : }
     114                 :             : pointer_t;
     115                 :             : 
     116                 :             : /* The fixup structure lists pointers to pointers that have to
     117                 :             :    be updated when a pointer value becomes known.  */
     118                 :             : 
     119                 :             : typedef struct fixup_t
     120                 :             : {
     121                 :             :   void **pointer;
     122                 :             :   struct fixup_t *next;
     123                 :             : }
     124                 :             : fixup_t;
     125                 :             : 
     126                 :             : 
     127                 :             : /* Structure for holding extra info needed for pointers being read.  */
     128                 :             : 
     129                 :             : enum gfc_rsym_state
     130                 :             : {
     131                 :             :   UNUSED,
     132                 :             :   NEEDED,
     133                 :             :   USED
     134                 :             : };
     135                 :             : 
     136                 :             : enum gfc_wsym_state
     137                 :             : {
     138                 :             :   UNREFERENCED = 0,
     139                 :             :   NEEDS_WRITE,
     140                 :             :   WRITTEN
     141                 :             : };
     142                 :             : 
     143                 :             : typedef struct pointer_info
     144                 :             : {
     145                 :             :   BBT_HEADER (pointer_info);
     146                 :             :   HOST_WIDE_INT integer;
     147                 :             :   pointer_t type;
     148                 :             : 
     149                 :             :   /* The first component of each member of the union is the pointer
     150                 :             :      being stored.  */
     151                 :             : 
     152                 :             :   fixup_t *fixup;
     153                 :             : 
     154                 :             :   union
     155                 :             :   {
     156                 :             :     void *pointer;      /* Member for doing pointer searches.  */
     157                 :             : 
     158                 :             :     struct
     159                 :             :     {
     160                 :             :       gfc_symbol *sym;
     161                 :             :       char *true_name, *module, *binding_label;
     162                 :             :       fixup_t *stfixup;
     163                 :             :       gfc_symtree *symtree;
     164                 :             :       enum gfc_rsym_state state;
     165                 :             :       int ns, referenced, renamed;
     166                 :             :       module_locus where;
     167                 :             :     }
     168                 :             :     rsym;
     169                 :             : 
     170                 :             :     struct
     171                 :             :     {
     172                 :             :       gfc_symbol *sym;
     173                 :             :       enum gfc_wsym_state state;
     174                 :             :     }
     175                 :             :     wsym;
     176                 :             :   }
     177                 :             :   u;
     178                 :             : 
     179                 :             : }
     180                 :             : pointer_info;
     181                 :             : 
     182                 :             : #define gfc_get_pointer_info() XCNEW (pointer_info)
     183                 :             : 
     184                 :             : 
     185                 :             : /* Local variables */
     186                 :             : 
     187                 :             : /* The gzFile for the module we're reading or writing.  */
     188                 :             : static gzFile module_fp;
     189                 :             : 
     190                 :             : /* Fully qualified module path */
     191                 :             : static char *module_fullpath = NULL;
     192                 :             : 
     193                 :             : /* The name of the module we're reading (USE'ing) or writing.  */
     194                 :             : static const char *module_name;
     195                 :             : /* The name of the .smod file that the submodule will write to.  */
     196                 :             : static const char *submodule_name;
     197                 :             : 
     198                 :             : /* The list of use statements to apply to the current namespace
     199                 :             :    before parsing the non-use statements.  */
     200                 :             : static gfc_use_list *module_list;
     201                 :             : /* The end of the MODULE_LIST list above at the time the recognition
     202                 :             :    of the current statement started.  */
     203                 :             : static gfc_use_list **old_module_list_tail;
     204                 :             : 
     205                 :             : /* If we're reading an intrinsic module, this is its ID.  */
     206                 :             : static intmod_id current_intmod;
     207                 :             : 
     208                 :             : /* Content of module.  */
     209                 :             : static char* module_content;
     210                 :             : 
     211                 :             : static long module_pos;
     212                 :             : static int module_line, module_column, only_flag;
     213                 :             : static int prev_module_line, prev_module_column;
     214                 :             : 
     215                 :             : static enum
     216                 :             : { IO_INPUT, IO_OUTPUT }
     217                 :             : iomode;
     218                 :             : 
     219                 :             : static gfc_use_rename *gfc_rename_list;
     220                 :             : static pointer_info *pi_root;
     221                 :             : static int symbol_number;       /* Counter for assigning symbol numbers */
     222                 :             : 
     223                 :             : /* Tells mio_expr_ref to make symbols for unused equivalence members.  */
     224                 :             : static bool in_load_equiv;
     225                 :             : 
     226                 :             : 
     227                 :             : 
     228                 :             : /*****************************************************************/
     229                 :             : 
     230                 :             : /* Pointer/integer conversion.  Pointers between structures are stored
     231                 :             :    as integers in the module file.  The next couple of subroutines
     232                 :             :    handle this translation for reading and writing.  */
     233                 :             : 
     234                 :             : /* Recursively free the tree of pointer structures.  */
     235                 :             : 
     236                 :             : static void
     237                 :     3318124 : free_pi_tree (pointer_info *p)
     238                 :             : {
     239                 :     3318124 :   if (p == NULL)
     240                 :             :     return;
     241                 :             : 
     242                 :     1648745 :   if (p->fixup != NULL)
     243                 :           0 :     gfc_internal_error ("free_pi_tree(): Unresolved fixup");
     244                 :             : 
     245                 :     1648745 :   free_pi_tree (p->left);
     246                 :     1648745 :   free_pi_tree (p->right);
     247                 :             : 
     248                 :     1648745 :   if (iomode == IO_INPUT)
     249                 :             :     {
     250                 :     1308772 :       XDELETEVEC (p->u.rsym.true_name);
     251                 :     1308772 :       XDELETEVEC (p->u.rsym.module);
     252                 :     1308772 :       XDELETEVEC (p->u.rsym.binding_label);
     253                 :             :     }
     254                 :             : 
     255                 :     1648745 :   free (p);
     256                 :             : }
     257                 :             : 
     258                 :             : 
     259                 :             : /* Compare pointers when searching by pointer.  Used when writing a
     260                 :             :    module.  */
     261                 :             : 
     262                 :             : static int
     263                 :     1930421 : compare_pointers (void *_sn1, void *_sn2)
     264                 :             : {
     265                 :     1930421 :   pointer_info *sn1, *sn2;
     266                 :             : 
     267                 :     1930421 :   sn1 = (pointer_info *) _sn1;
     268                 :     1930421 :   sn2 = (pointer_info *) _sn2;
     269                 :             : 
     270                 :     1930421 :   if (sn1->u.pointer < sn2->u.pointer)
     271                 :             :     return -1;
     272                 :     1123229 :   if (sn1->u.pointer > sn2->u.pointer)
     273                 :     1123229 :     return 1;
     274                 :             : 
     275                 :             :   return 0;
     276                 :             : }
     277                 :             : 
     278                 :             : 
     279                 :             : /* Compare integers when searching by integer.  Used when reading a
     280                 :             :    module.  */
     281                 :             : 
     282                 :             : static int
     283                 :    61102120 : compare_integers (void *_sn1, void *_sn2)
     284                 :             : {
     285                 :    61102120 :   pointer_info *sn1, *sn2;
     286                 :             : 
     287                 :    61102120 :   sn1 = (pointer_info *) _sn1;
     288                 :    61102120 :   sn2 = (pointer_info *) _sn2;
     289                 :             : 
     290                 :     9959824 :   if (sn1->integer < sn2->integer)
     291                 :             :     return -1;
     292                 :    28057347 :   if (sn1->integer > sn2->integer)
     293                 :     6751004 :     return 1;
     294                 :             : 
     295                 :             :   return 0;
     296                 :             : }
     297                 :             : 
     298                 :             : 
     299                 :             : /* Initialize the pointer_info tree.  */
     300                 :             : 
     301                 :             : static void
     302                 :       20634 : init_pi_tree (void)
     303                 :             : {
     304                 :       20634 :   compare_fn compare;
     305                 :       20634 :   pointer_info *p;
     306                 :             : 
     307                 :       20634 :   pi_root = NULL;
     308                 :       20634 :   compare = (iomode == IO_INPUT) ? compare_integers : compare_pointers;
     309                 :             : 
     310                 :             :   /* Pointer 0 is the NULL pointer.  */
     311                 :       20634 :   p = gfc_get_pointer_info ();
     312                 :       20634 :   p->u.pointer = NULL;
     313                 :       20634 :   p->integer = 0;
     314                 :       20634 :   p->type = P_OTHER;
     315                 :             : 
     316                 :       20634 :   gfc_insert_bbt (&pi_root, p, compare);
     317                 :             : 
     318                 :             :   /* Pointer 1 is the current namespace.  */
     319                 :       20634 :   p = gfc_get_pointer_info ();
     320                 :       20634 :   p->u.pointer = gfc_current_ns;
     321                 :       20634 :   p->integer = 1;
     322                 :       20634 :   p->type = P_NAMESPACE;
     323                 :             : 
     324                 :       20634 :   gfc_insert_bbt (&pi_root, p, compare);
     325                 :             : 
     326                 :       20634 :   symbol_number = 2;
     327                 :       20634 : }
     328                 :             : 
     329                 :             : 
     330                 :             : /* During module writing, call here with a pointer to something,
     331                 :             :    returning the pointer_info node.  */
     332                 :             : 
     333                 :             : static pointer_info *
     334                 :     1657647 : find_pointer (void *gp)
     335                 :             : {
     336                 :     1657647 :   pointer_info *p;
     337                 :             : 
     338                 :     1657647 :   p = pi_root;
     339                 :     8908344 :   while (p != NULL)
     340                 :             :     {
     341                 :     8585855 :       if (p->u.pointer == gp)
     342                 :             :         break;
     343                 :     7250697 :       p = (gp < p->u.pointer) ? p->left : p->right;
     344                 :             :     }
     345                 :             : 
     346                 :     1657647 :   return p;
     347                 :             : }
     348                 :             : 
     349                 :             : 
     350                 :             : /* Given a pointer while writing, returns the pointer_info tree node,
     351                 :             :    creating it if it doesn't exist.  */
     352                 :             : 
     353                 :             : static pointer_info *
     354                 :     1551766 : get_pointer (void *gp)
     355                 :             : {
     356                 :     1551766 :   pointer_info *p;
     357                 :             : 
     358                 :     1551766 :   p = find_pointer (gp);
     359                 :     1551766 :   if (p != NULL)
     360                 :             :     return p;
     361                 :             : 
     362                 :             :   /* Pointer doesn't have an integer.  Give it one.  */
     363                 :      322489 :   p = gfc_get_pointer_info ();
     364                 :             : 
     365                 :      322489 :   p->u.pointer = gp;
     366                 :      322489 :   p->integer = symbol_number++;
     367                 :             : 
     368                 :      322489 :   gfc_insert_bbt (&pi_root, p, compare_pointers);
     369                 :             : 
     370                 :      322489 :   return p;
     371                 :             : }
     372                 :             : 
     373                 :             : 
     374                 :             : /* Given an integer during reading, find it in the pointer_info tree,
     375                 :             :    creating the node if not found.  */
     376                 :             : 
     377                 :             : static pointer_info *
     378                 :     6548596 : get_integer (HOST_WIDE_INT integer)
     379                 :             : {
     380                 :     6548596 :   pointer_info *p, t;
     381                 :     6548596 :   int c;
     382                 :             : 
     383                 :     6548596 :   t.integer = integer;
     384                 :             : 
     385                 :     6548596 :   p = pi_root;
     386                 :    52427284 :   while (p != NULL)
     387                 :             :     {
     388                 :    51142296 :       c = compare_integers (&t, p);
     389                 :             :       if (c == 0)
     390                 :             :         break;
     391                 :             : 
     392                 :    45878688 :       p = (c < 0) ? p->left : p->right;
     393                 :             :     }
     394                 :             : 
     395                 :     6548596 :   if (p != NULL)
     396                 :             :     return p;
     397                 :             : 
     398                 :     1284988 :   p = gfc_get_pointer_info ();
     399                 :     1284988 :   p->integer = integer;
     400                 :     1284988 :   p->u.pointer = NULL;
     401                 :             : 
     402                 :     1284988 :   gfc_insert_bbt (&pi_root, p, compare_integers);
     403                 :             : 
     404                 :     1284988 :   return p;
     405                 :             : }
     406                 :             : 
     407                 :             : 
     408                 :             : /* Resolve any fixups using a known pointer.  */
     409                 :             : 
     410                 :             : static void
     411                 :     1379746 : resolve_fixups (fixup_t *f, void *gp)
     412                 :             : {
     413                 :     1379746 :   fixup_t *next;
     414                 :             : 
     415                 :     2072684 :   for (; f; f = next)
     416                 :             :     {
     417                 :      692938 :       next = f->next;
     418                 :      692938 :       *(f->pointer) = gp;
     419                 :      692938 :       free (f);
     420                 :             :     }
     421                 :     1379746 : }
     422                 :             : 
     423                 :             : 
     424                 :             : /* Convert a string such that it starts with a lower-case character. Used
     425                 :             :    to convert the symtree name of a derived-type to the symbol name or to
     426                 :             :    the name of the associated generic function.  */
     427                 :             : 
     428                 :             : const char *
     429                 :      786413 : gfc_dt_lower_string (const char *name)
     430                 :             : {
     431                 :      786413 :   if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
     432                 :       50316 :     return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name[0]),
     433                 :       50316 :                            &name[1]);
     434                 :      736097 :   return gfc_get_string ("%s", name);
     435                 :             : }
     436                 :             : 
     437                 :             : 
     438                 :             : /* Convert a string such that it starts with an upper-case character. Used to
     439                 :             :    return the symtree-name for a derived type; the symbol name itself and the
     440                 :             :    symtree/symbol name of the associated generic function start with a lower-
     441                 :             :    case character.  */
     442                 :             : 
     443                 :             : const char *
     444                 :      347152 : gfc_dt_upper_string (const char *name)
     445                 :             : {
     446                 :      347152 :   if (name[0] != (char) TOUPPER ((unsigned char) name[0]))
     447                 :      328585 :     return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name[0]),
     448                 :      328585 :                            &name[1]);
     449                 :       18567 :   return gfc_get_string ("%s", name);
     450                 :             : }
     451                 :             : 
     452                 :             : /* Call here during module reading when we know what pointer to
     453                 :             :    associate with an integer.  Any fixups that exist are resolved at
     454                 :             :    this time.  */
     455                 :             : 
     456                 :             : static void
     457                 :      840214 : associate_integer_pointer (pointer_info *p, void *gp)
     458                 :             : {
     459                 :      840214 :   if (p->u.pointer != NULL)
     460                 :           0 :     gfc_internal_error ("associate_integer_pointer(): Already associated");
     461                 :             : 
     462                 :      840214 :   p->u.pointer = gp;
     463                 :             : 
     464                 :      840214 :   resolve_fixups (p->fixup, gp);
     465                 :             : 
     466                 :      840214 :   p->fixup = NULL;
     467                 :      840214 : }
     468                 :             : 
     469                 :             : 
     470                 :             : /* During module reading, given an integer and a pointer to a pointer,
     471                 :             :    either store the pointer from an already-known value or create a
     472                 :             :    fixup structure in order to store things later.  Returns zero if
     473                 :             :    the reference has been actually stored, or nonzero if the reference
     474                 :             :    must be fixed later (i.e., associate_integer_pointer must be called
     475                 :             :    sometime later.  Returns the pointer_info structure.  */
     476                 :             : 
     477                 :             : static pointer_info *
     478                 :     4023776 : add_fixup (HOST_WIDE_INT integer, void *gp)
     479                 :             : {
     480                 :     4023776 :   pointer_info *p;
     481                 :     4023776 :   fixup_t *f;
     482                 :     4023776 :   char **cp;
     483                 :             : 
     484                 :     4023776 :   p = get_integer (integer);
     485                 :             : 
     486                 :     4023776 :   if (p->integer == 0 || p->u.pointer != NULL)
     487                 :             :     {
     488                 :     3338809 :       cp = (char **) gp;
     489                 :     3338809 :       *cp = (char *) p->u.pointer;
     490                 :             :     }
     491                 :             :   else
     492                 :             :     {
     493                 :      684967 :       f = XCNEW (fixup_t);
     494                 :             : 
     495                 :      684967 :       f->next = p->fixup;
     496                 :      684967 :       p->fixup = f;
     497                 :             : 
     498                 :      684967 :       f->pointer = (void **) gp;
     499                 :             :     }
     500                 :             : 
     501                 :     4023776 :   return p;
     502                 :             : }
     503                 :             : 
     504                 :             : 
     505                 :             : /*****************************************************************/
     506                 :             : 
     507                 :             : /* Parser related subroutines */
     508                 :             : 
     509                 :             : /* Free the rename list left behind by a USE statement.  */
     510                 :             : 
     511                 :             : static void
     512                 :       83935 : free_rename (gfc_use_rename *list)
     513                 :             : {
     514                 :       83935 :   gfc_use_rename *next;
     515                 :             : 
     516                 :       92077 :   for (; list; list = next)
     517                 :             :     {
     518                 :        8142 :       next = list->next;
     519                 :        8142 :       free (list);
     520                 :             :     }
     521                 :           0 : }
     522                 :             : 
     523                 :             : 
     524                 :             : /* Match a USE statement.  */
     525                 :             : 
     526                 :             : match
     527                 :       20265 : gfc_match_use (void)
     528                 :             : {
     529                 :       20265 :   char name[GFC_MAX_SYMBOL_LEN + 1], module_nature[GFC_MAX_SYMBOL_LEN + 1];
     530                 :       20265 :   gfc_use_rename *tail = NULL, *new_use;
     531                 :       20265 :   interface_type type, type2;
     532                 :       20265 :   gfc_intrinsic_op op;
     533                 :       20265 :   match m;
     534                 :       20265 :   gfc_use_list *use_list;
     535                 :       20265 :   gfc_symtree *st;
     536                 :       20265 :   locus loc;
     537                 :             : 
     538                 :       20265 :   use_list = gfc_get_use_list ();
     539                 :             : 
     540                 :       20265 :   if (gfc_match (" , ") == MATCH_YES)
     541                 :             :     {
     542                 :        2569 :       if ((m = gfc_match (" %n ::", module_nature)) == MATCH_YES)
     543                 :             :         {
     544                 :        2567 :           if (!gfc_notify_std (GFC_STD_F2003, "module "
     545                 :             :                                "nature in USE statement at %C"))
     546                 :           0 :             goto cleanup;
     547                 :             : 
     548                 :        2567 :           if (strcmp (module_nature, "intrinsic") == 0)
     549                 :        2553 :             use_list->intrinsic = true;
     550                 :             :           else
     551                 :             :             {
     552                 :          14 :               if (strcmp (module_nature, "non_intrinsic") == 0)
     553                 :          13 :                 use_list->non_intrinsic = true;
     554                 :             :               else
     555                 :             :                 {
     556                 :           1 :                   gfc_error ("Module nature in USE statement at %C shall "
     557                 :             :                              "be either INTRINSIC or NON_INTRINSIC");
     558                 :           1 :                   goto cleanup;
     559                 :             :                 }
     560                 :             :             }
     561                 :             :         }
     562                 :             :       else
     563                 :             :         {
     564                 :             :           /* Help output a better error message than "Unclassifiable
     565                 :             :              statement".  */
     566                 :           2 :           gfc_match (" %n", module_nature);
     567                 :           2 :           if (strcmp (module_nature, "intrinsic") == 0
     568                 :           1 :               || strcmp (module_nature, "non_intrinsic") == 0)
     569                 :           2 :             gfc_error ("\"::\" was expected after module nature at %C "
     570                 :             :                        "but was not found");
     571                 :           2 :           free (use_list);
     572                 :           2 :           return m;
     573                 :             :         }
     574                 :             :     }
     575                 :             :   else
     576                 :             :     {
     577                 :       17696 :       m = gfc_match (" ::");
     578                 :       18027 :       if (m == MATCH_YES &&
     579                 :         331 :           !gfc_notify_std(GFC_STD_F2003, "\"USE :: module\" at %C"))
     580                 :           0 :         goto cleanup;
     581                 :             : 
     582                 :       17696 :       if (m != MATCH_YES)
     583                 :             :         {
     584                 :       17365 :           m = gfc_match ("% ");
     585                 :       17365 :           if (m != MATCH_YES)
     586                 :             :             {
     587                 :          15 :               free (use_list);
     588                 :          15 :               return m;
     589                 :             :             }
     590                 :             :         }
     591                 :             :     }
     592                 :             : 
     593                 :       20247 :   use_list->where = gfc_current_locus;
     594                 :             : 
     595                 :       20247 :   m = gfc_match_name (name);
     596                 :       20247 :   if (m != MATCH_YES)
     597                 :             :     {
     598                 :          12 :       free (use_list);
     599                 :          12 :       return m;
     600                 :             :     }
     601                 :             : 
     602                 :       20235 :   use_list->module_name = gfc_get_string ("%s", name);
     603                 :             : 
     604                 :       20235 :   if (gfc_match_eos () == MATCH_YES)
     605                 :       13013 :     goto done;
     606                 :             : 
     607                 :        7222 :   if (gfc_match_char (',') != MATCH_YES)
     608                 :           0 :     goto syntax;
     609                 :             : 
     610                 :        7222 :   if (gfc_match (" only :") == MATCH_YES)
     611                 :        6982 :     use_list->only_flag = true;
     612                 :             : 
     613                 :        7222 :   if (gfc_match_eos () == MATCH_YES)
     614                 :           1 :     goto done;
     615                 :             : 
     616                 :       10895 :   for (;;)
     617                 :             :     {
     618                 :             :       /* Get a new rename struct and add it to the rename list.  */
     619                 :       10895 :       new_use = gfc_get_use_rename ();
     620                 :       10895 :       new_use->where = gfc_current_locus;
     621                 :       10895 :       new_use->found = 0;
     622                 :             : 
     623                 :       10895 :       if (use_list->rename == NULL)
     624                 :        7221 :         use_list->rename = new_use;
     625                 :             :       else
     626                 :        3674 :         tail->next = new_use;
     627                 :       10895 :       tail = new_use;
     628                 :             : 
     629                 :             :       /* See what kind of interface we're dealing with.  Assume it is
     630                 :             :          not an operator.  */
     631                 :       10895 :       new_use->op = INTRINSIC_NONE;
     632                 :       10895 :       if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
     633                 :           0 :         goto cleanup;
     634                 :             : 
     635                 :       10895 :       switch (type)
     636                 :             :         {
     637                 :           1 :         case INTERFACE_NAMELESS:
     638                 :           1 :           gfc_error ("Missing generic specification in USE statement at %C");
     639                 :           1 :           goto cleanup;
     640                 :             : 
     641                 :       10783 :         case INTERFACE_USER_OP:
     642                 :       10783 :         case INTERFACE_GENERIC:
     643                 :       10783 :         case INTERFACE_DTIO:
     644                 :       10783 :           loc = gfc_current_locus;
     645                 :             : 
     646                 :       10783 :           m = gfc_match (" =>");
     647                 :             : 
     648                 :          79 :           if (type == INTERFACE_USER_OP && m == MATCH_YES
     649                 :       10829 :               && (!gfc_notify_std(GFC_STD_F2003, "Renaming "
     650                 :             :                                   "operators in USE statements at %C")))
     651                 :           2 :             goto cleanup;
     652                 :             : 
     653                 :       10781 :           if (type == INTERFACE_USER_OP)
     654                 :          77 :             new_use->op = INTRINSIC_USER;
     655                 :             : 
     656                 :       10781 :           if (use_list->only_flag)
     657                 :             :             {
     658                 :       10434 :               if (m != MATCH_YES)
     659                 :       10114 :                 strcpy (new_use->use_name, name);
     660                 :             :               else
     661                 :             :                 {
     662                 :         320 :                   strcpy (new_use->local_name, name);
     663                 :         320 :                   m = gfc_match_generic_spec (&type2, new_use->use_name, &op);
     664                 :         320 :                   if (type != type2)
     665                 :           1 :                     goto syntax;
     666                 :         319 :                   if (m == MATCH_NO)
     667                 :           0 :                     goto syntax;
     668                 :         319 :                   if (m == MATCH_ERROR)
     669                 :           0 :                     goto cleanup;
     670                 :             :                 }
     671                 :             :             }
     672                 :             :           else
     673                 :             :             {
     674                 :         347 :               if (m != MATCH_YES)
     675                 :           0 :                 goto syntax;
     676                 :         347 :               strcpy (new_use->local_name, name);
     677                 :             : 
     678                 :         347 :               m = gfc_match_generic_spec (&type2, new_use->use_name, &op);
     679                 :         347 :               if (type != type2)
     680                 :           2 :                 goto syntax;
     681                 :         345 :               if (m == MATCH_NO)
     682                 :           0 :                 goto syntax;
     683                 :         345 :               if (m == MATCH_ERROR)
     684                 :           0 :                 goto cleanup;
     685                 :             :             }
     686                 :             : 
     687                 :       10778 :           st = gfc_find_symtree (gfc_current_ns->sym_root, name);
     688                 :       10778 :           if (st && type != INTERFACE_USER_OP
     689                 :          13 :               && (st->n.sym->module != use_list->module_name
     690                 :           3 :                   || strcmp (st->n.sym->name, new_use->use_name) != 0))
     691                 :             :             {
     692                 :          10 :               if (m == MATCH_YES)
     693                 :           7 :                 gfc_error ("Symbol %qs at %L conflicts with the rename symbol "
     694                 :             :                            "at %L", name, &st->n.sym->declared_at, &loc);
     695                 :             :               else
     696                 :           3 :                 gfc_error ("Symbol %qs at %L conflicts with the symbol "
     697                 :             :                            "at %L", name, &st->n.sym->declared_at, &loc);
     698                 :          10 :               goto cleanup;
     699                 :             :             }
     700                 :             : 
     701                 :       10768 :           if (strcmp (new_use->use_name, use_list->module_name) == 0
     702                 :       10766 :               || strcmp (new_use->local_name, use_list->module_name) == 0)
     703                 :             :             {
     704                 :           3 :               gfc_error ("The name %qs at %C has already been used as "
     705                 :             :                          "an external module name", use_list->module_name);
     706                 :           3 :               goto cleanup;
     707                 :             :             }
     708                 :             :           break;
     709                 :             : 
     710                 :         111 :         case INTERFACE_INTRINSIC_OP:
     711                 :         111 :           new_use->op = op;
     712                 :         111 :           break;
     713                 :             : 
     714                 :           0 :         default:
     715                 :           0 :           gcc_unreachable ();
     716                 :             :         }
     717                 :             : 
     718                 :       10876 :       if (gfc_match_eos () == MATCH_YES)
     719                 :             :         break;
     720                 :        3676 :       if (gfc_match_char (',') != MATCH_YES)
     721                 :           2 :         goto syntax;
     722                 :             :     }
     723                 :             : 
     724                 :        7200 : done:
     725                 :       20214 :   if (module_list)
     726                 :             :     {
     727                 :             :       gfc_use_list *last = module_list;
     728                 :        3795 :       while (last->next)
     729                 :             :         last = last->next;
     730                 :        2966 :       last->next = use_list;
     731                 :             :     }
     732                 :             :   else
     733                 :       17248 :     module_list = use_list;
     734                 :             : 
     735                 :             :   return MATCH_YES;
     736                 :             : 
     737                 :           5 : syntax:
     738                 :           5 :   gfc_syntax_error (ST_USE);
     739                 :             : 
     740                 :          22 : cleanup:
     741                 :          22 :   free_rename (use_list->rename);
     742                 :          22 :   free (use_list);
     743                 :          22 :   return MATCH_ERROR;
     744                 :             : }
     745                 :             : 
     746                 :             : 
     747                 :             : /* Match a SUBMODULE statement.
     748                 :             : 
     749                 :             :    According to F2008:11.2.3.2, "The submodule identifier is the
     750                 :             :    ordered pair whose first element is the ancestor module name and
     751                 :             :    whose second element is the submodule name. 'Submodule_name' is
     752                 :             :    used for the submodule filename and uses '@' as a separator, whilst
     753                 :             :    the name of the symbol for the module uses '.' as a separator.
     754                 :             :    The reasons for these choices are:
     755                 :             :    (i) To follow another leading brand in the submodule filenames;
     756                 :             :    (ii) Since '.' is not particularly visible in the filenames; and
     757                 :             :    (iii) The linker does not permit '@' in mnemonics.  */
     758                 :             : 
     759                 :             : match
     760                 :         196 : gfc_match_submodule (void)
     761                 :             : {
     762                 :         196 :   match m;
     763                 :         196 :   char name[GFC_MAX_SYMBOL_LEN + 1];
     764                 :         196 :   gfc_use_list *use_list;
     765                 :         196 :   bool seen_colon = false;
     766                 :             : 
     767                 :         196 :   if (!gfc_notify_std (GFC_STD_F2008, "SUBMODULE declaration at %C"))
     768                 :             :     return MATCH_ERROR;
     769                 :             : 
     770                 :         195 :   if (gfc_current_state () != COMP_NONE)
     771                 :             :     {
     772                 :           3 :       gfc_error ("SUBMODULE declaration at %C cannot appear within "
     773                 :             :                  "another scoping unit");
     774                 :           3 :       return MATCH_ERROR;
     775                 :             :     }
     776                 :             : 
     777                 :         192 :   gfc_new_block = NULL;
     778                 :         192 :   gcc_assert (module_list == NULL);
     779                 :             : 
     780                 :         192 :   if (gfc_match_char ('(') != MATCH_YES)
     781                 :           0 :     goto syntax;
     782                 :             : 
     783                 :         217 :   while (1)
     784                 :             :     {
     785                 :         217 :       m = gfc_match (" %n", name);
     786                 :         217 :       if (m != MATCH_YES)
     787                 :           0 :         goto syntax;
     788                 :             : 
     789                 :         217 :       use_list = gfc_get_use_list ();
     790                 :         217 :       use_list->where = gfc_current_locus;
     791                 :             : 
     792                 :         217 :       if (module_list)
     793                 :             :         {
     794                 :             :           gfc_use_list *last = module_list;
     795                 :          25 :           while (last->next)
     796                 :             :             last = last->next;
     797                 :          25 :           last->next = use_list;
     798                 :          25 :           use_list->module_name
     799                 :          25 :                 = gfc_get_string ("%s.%s", module_list->module_name, name);
     800                 :          25 :           use_list->submodule_name
     801                 :          25 :                 = gfc_get_string ("%s@%s", module_list->module_name, name);
     802                 :             :         }
     803                 :             :       else
     804                 :             :         {
     805                 :         192 :           module_list = use_list;
     806                 :         192 :           use_list->module_name = gfc_get_string ("%s", name);
     807                 :         192 :           use_list->submodule_name = use_list->module_name;
     808                 :             :         }
     809                 :             : 
     810                 :         217 :       if (gfc_match_char (')') == MATCH_YES)
     811                 :             :         break;
     812                 :             : 
     813                 :          52 :       if (gfc_match_char (':') != MATCH_YES
     814                 :          26 :           || seen_colon)
     815                 :           1 :         goto syntax;
     816                 :             : 
     817                 :             :       seen_colon = true;
     818                 :             :     }
     819                 :             : 
     820                 :         191 :   m = gfc_match (" %s%t", &gfc_new_block);
     821                 :         191 :   if (m != MATCH_YES)
     822                 :           0 :     goto syntax;
     823                 :             : 
     824                 :         191 :   submodule_name = gfc_get_string ("%s@%s", module_list->module_name,
     825                 :             :                                    gfc_new_block->name);
     826                 :             : 
     827                 :         191 :   gfc_new_block->name = gfc_get_string ("%s.%s",
     828                 :             :                                         module_list->module_name,
     829                 :             :                                         gfc_new_block->name);
     830                 :             : 
     831                 :         191 :   if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
     832                 :             :                        gfc_new_block->name, NULL))
     833                 :             :     return MATCH_ERROR;
     834                 :             : 
     835                 :             :   /* Just retain the ultimate .(s)mod file for reading, since it
     836                 :             :      contains all the information in its ancestors.  */
     837                 :         191 :   use_list = module_list;
     838                 :         215 :   for (; module_list->next; use_list = module_list)
     839                 :             :     {
     840                 :          24 :       module_list = use_list->next;
     841                 :          24 :       free (use_list);
     842                 :             :     }
     843                 :             : 
     844                 :             :   return MATCH_YES;
     845                 :             : 
     846                 :           1 : syntax:
     847                 :           1 :   gfc_error ("Syntax error in SUBMODULE statement at %C");
     848                 :           1 :   return MATCH_ERROR;
     849                 :             : }
     850                 :             : 
     851                 :             : 
     852                 :             : /* Given a name and a number, inst, return the inst name
     853                 :             :    under which to load this symbol. Returns NULL if this
     854                 :             :    symbol shouldn't be loaded. If inst is zero, returns
     855                 :             :    the number of instances of this name. If interface is
     856                 :             :    true, a user-defined operator is sought, otherwise only
     857                 :             :    non-operators are sought.  */
     858                 :             : 
     859                 :             : static const char *
     860                 :      800566 : find_use_name_n (const char *name, int *inst, bool interface)
     861                 :             : {
     862                 :      800566 :   gfc_use_rename *u;
     863                 :      800566 :   const char *low_name = NULL;
     864                 :      800566 :   int i;
     865                 :             : 
     866                 :             :   /* For derived types.  */
     867                 :      800566 :   if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
     868                 :       24454 :     low_name = gfc_dt_lower_string (name);
     869                 :             : 
     870                 :      800566 :   i = 0;
     871                 :      925325 :   for (u = gfc_rename_list; u; u = u->next)
     872                 :             :     {
     873                 :      128716 :       if ((!low_name && strcmp (u->use_name, name) != 0)
     874                 :        3212 :           || (low_name && strcmp (u->use_name, low_name) != 0)
     875                 :        7954 :           || (u->op == INTRINSIC_USER && !interface)
     876                 :        7952 :           || (u->op != INTRINSIC_USER &&  interface))
     877                 :      120764 :         continue;
     878                 :        7952 :       if (++i == *inst)
     879                 :             :         break;
     880                 :             :     }
     881                 :             : 
     882                 :      800566 :   if (!*inst)
     883                 :             :     {
     884                 :      400212 :       *inst = i;
     885                 :      400212 :       return NULL;
     886                 :             :     }
     887                 :             : 
     888                 :      400354 :   if (u == NULL)
     889                 :      443220 :     return only_flag ? NULL : name;
     890                 :             : 
     891                 :        3957 :   u->found = 1;
     892                 :             : 
     893                 :        3957 :   if (low_name)
     894                 :             :     {
     895                 :         639 :       if (u->local_name[0] == '\0')
     896                 :             :         return name;
     897                 :          96 :       return gfc_dt_upper_string (u->local_name);
     898                 :             :     }
     899                 :             : 
     900                 :        3318 :   return (u->local_name[0] != '\0') ? u->local_name : name;
     901                 :             : }
     902                 :             : 
     903                 :             : 
     904                 :             : /* Given a name, return the name under which to load this symbol.
     905                 :             :    Returns NULL if this symbol shouldn't be loaded.  */
     906                 :             : 
     907                 :             : static const char *
     908                 :          86 : find_use_name (const char *name, bool interface)
     909                 :             : {
     910                 :          86 :   int i = 1;
     911                 :          50 :   return find_use_name_n (name, &i, interface);
     912                 :             : }
     913                 :             : 
     914                 :             : 
     915                 :             : /* Given a real name, return the number of use names associated with it.  */
     916                 :             : 
     917                 :             : static int
     918                 :      400212 : number_use_names (const char *name, bool interface)
     919                 :             : {
     920                 :      400212 :   int i = 0;
     921                 :           0 :   find_use_name_n (name, &i, interface);
     922                 :      400212 :   return i;
     923                 :             : }
     924                 :             : 
     925                 :             : 
     926                 :             : /* Try to find the operator in the current list.  */
     927                 :             : 
     928                 :             : static gfc_use_rename *
     929                 :       63420 : find_use_operator (gfc_intrinsic_op op)
     930                 :             : {
     931                 :       63420 :   gfc_use_rename *u;
     932                 :             : 
     933                 :      156735 :   for (u = gfc_rename_list; u; u = u->next)
     934                 :       93517 :     if (u->op == op)
     935                 :           0 :       return u;
     936                 :             : 
     937                 :             :   return NULL;
     938                 :             : }
     939                 :             : 
     940                 :             : 
     941                 :             : /*****************************************************************/
     942                 :             : 
     943                 :             : /* The next couple of subroutines maintain a tree used to avoid a
     944                 :             :    brute-force search for a combination of true name and module name.
     945                 :             :    While symtree names, the name that a particular symbol is known by
     946                 :             :    can changed with USE statements, we still have to keep track of the
     947                 :             :    true names to generate the correct reference, and also avoid
     948                 :             :    loading the same real symbol twice in a program unit.
     949                 :             : 
     950                 :             :    When we start reading, the true name tree is built and maintained
     951                 :             :    as symbols are read.  The tree is searched as we load new symbols
     952                 :             :    to see if it already exists someplace in the namespace.  */
     953                 :             : 
     954                 :             : typedef struct true_name
     955                 :             : {
     956                 :             :   BBT_HEADER (true_name);
     957                 :             :   const char *name;
     958                 :             :   gfc_symbol *sym;
     959                 :             : }
     960                 :             : true_name;
     961                 :             : 
     962                 :             : static true_name *true_name_root;
     963                 :             : 
     964                 :             : 
     965                 :             : /* Compare two true_name structures.  */
     966                 :             : 
     967                 :             : static int
     968                 :     2798707 : compare_true_names (void *_t1, void *_t2)
     969                 :             : {
     970                 :     2798707 :   true_name *t1, *t2;
     971                 :     2798707 :   int c;
     972                 :             : 
     973                 :     2798707 :   t1 = (true_name *) _t1;
     974                 :     2798707 :   t2 = (true_name *) _t2;
     975                 :             : 
     976                 :     2798707 :   c = ((t1->sym->module > t2->sym->module)
     977                 :     2798707 :        - (t1->sym->module < t2->sym->module));
     978                 :     2798707 :   if (c != 0)
     979                 :             :     return c;
     980                 :             : 
     981                 :      921628 :   return strcmp (t1->name, t2->name);
     982                 :             : }
     983                 :             : 
     984                 :             : 
     985                 :             : /* Given a true name, search the true name tree to see if it exists
     986                 :             :    within the main namespace.  */
     987                 :             : 
     988                 :             : static gfc_symbol *
     989                 :     1031249 : find_true_name (const char *name, const char *module)
     990                 :             : {
     991                 :     1031249 :   true_name t, *p;
     992                 :     1031249 :   gfc_symbol sym;
     993                 :     1031249 :   int c;
     994                 :             : 
     995                 :     1031249 :   t.name = gfc_get_string ("%s", name);
     996                 :     1031249 :   if (module != NULL)
     997                 :     1013166 :     sym.module = gfc_get_string ("%s", module);
     998                 :             :   else
     999                 :       18083 :     sym.module = NULL;
    1000                 :     1031249 :   t.sym = &sym;
    1001                 :             : 
    1002                 :     1031249 :   p = true_name_root;
    1003                 :     3417480 :   while (p != NULL)
    1004                 :             :     {
    1005                 :     2433975 :       c = compare_true_names ((void *) (&t), (void *) p);
    1006                 :     2433975 :       if (c == 0)
    1007                 :       47744 :         return p->sym;
    1008                 :             : 
    1009                 :     2386231 :       p = (c < 0) ? p->left : p->right;
    1010                 :             :     }
    1011                 :             : 
    1012                 :             :   return NULL;
    1013                 :             : }
    1014                 :             : 
    1015                 :             : 
    1016                 :             : /* Given a gfc_symbol pointer that is not in the true name tree, add it.  */
    1017                 :             : 
    1018                 :             : static void
    1019                 :       92325 : add_true_name (gfc_symbol *sym)
    1020                 :             : {
    1021                 :       92325 :   true_name *t;
    1022                 :             : 
    1023                 :       92325 :   t = XCNEW (true_name);
    1024                 :       92325 :   t->sym = sym;
    1025                 :       92325 :   if (gfc_fl_struct (sym->attr.flavor))
    1026                 :        5332 :     t->name = gfc_dt_upper_string (sym->name);
    1027                 :             :   else
    1028                 :       86993 :     t->name = sym->name;
    1029                 :             : 
    1030                 :       92325 :   gfc_insert_bbt (&true_name_root, t, compare_true_names);
    1031                 :       92325 : }
    1032                 :             : 
    1033                 :             : 
    1034                 :             : /* Recursive function to build the initial true name tree by
    1035                 :             :    recursively traversing the current namespace.  */
    1036                 :             : 
    1037                 :             : static void
    1038                 :      197918 : build_tnt (gfc_symtree *st)
    1039                 :             : {
    1040                 :      197918 :   const char *name;
    1041                 :      197918 :   if (st == NULL)
    1042                 :             :     return;
    1043                 :             : 
    1044                 :       93013 :   build_tnt (st->left);
    1045                 :       93013 :   build_tnt (st->right);
    1046                 :             : 
    1047                 :       93013 :   if (gfc_fl_struct (st->n.sym->attr.flavor))
    1048                 :        5749 :     name = gfc_dt_upper_string (st->n.sym->name);
    1049                 :             :   else
    1050                 :       87264 :     name = st->n.sym->name;
    1051                 :             : 
    1052                 :       93013 :   if (find_true_name (name, st->n.sym->module) != NULL)
    1053                 :             :     return;
    1054                 :             : 
    1055                 :       92325 :   add_true_name (st->n.sym);
    1056                 :             : }
    1057                 :             : 
    1058                 :             : 
    1059                 :             : /* Initialize the true name tree with the current namespace.  */
    1060                 :             : 
    1061                 :             : static void
    1062                 :       11892 : init_true_name_tree (void)
    1063                 :             : {
    1064                 :       11892 :   true_name_root = NULL;
    1065                 :       11892 :   build_tnt (gfc_current_ns->sym_root);
    1066                 :       11892 : }
    1067                 :             : 
    1068                 :             : 
    1069                 :             : /* Recursively free a true name tree node.  */
    1070                 :             : 
    1071                 :             : static void
    1072                 :      196542 : free_true_name (true_name *t)
    1073                 :             : {
    1074                 :      196542 :   if (t == NULL)
    1075                 :             :     return;
    1076                 :       92325 :   free_true_name (t->left);
    1077                 :       92325 :   free_true_name (t->right);
    1078                 :             : 
    1079                 :       92325 :   free (t);
    1080                 :             : }
    1081                 :             : 
    1082                 :             : 
    1083                 :             : /*****************************************************************/
    1084                 :             : 
    1085                 :             : /* Module reading and writing.  */
    1086                 :             : 
    1087                 :             : /* The following are versions similar to the ones in scanner.cc, but
    1088                 :             :    for dealing with compressed module files.  */
    1089                 :             : 
    1090                 :             : static gzFile
    1091                 :        8221 : gzopen_included_file_1 (const char *name, gfc_directorylist *list,
    1092                 :             :                      bool module, bool system)
    1093                 :             : {
    1094                 :        8221 :   char *fullname;
    1095                 :        8221 :   gfc_directorylist *p;
    1096                 :        8221 :   gzFile f;
    1097                 :             : 
    1098                 :       28059 :   for (p = list; p; p = p->next)
    1099                 :             :     {
    1100                 :       21486 :       if (module && !p->use_for_modules)
    1101                 :        3319 :        continue;
    1102                 :             : 
    1103                 :       18167 :       fullname = (char *) alloca(strlen (p->path) + strlen (name) + 2);
    1104                 :       18167 :       strcpy (fullname, p->path);
    1105                 :       18167 :       strcat (fullname, "/");
    1106                 :       18167 :       strcat (fullname, name);
    1107                 :             : 
    1108                 :       18167 :       f = gzopen (fullname, "r");
    1109                 :       18167 :       if (f != NULL)
    1110                 :             :        {
    1111                 :        1648 :          if (gfc_cpp_makedep ())
    1112                 :           0 :            gfc_cpp_add_dep (fullname, system);
    1113                 :             : 
    1114                 :        1648 :          free (module_fullpath);
    1115                 :        1648 :          module_fullpath = xstrdup (fullname);
    1116                 :        1648 :          return f;
    1117                 :             :        }
    1118                 :             :     }
    1119                 :             : 
    1120                 :             :   return NULL;
    1121                 :             : }
    1122                 :             : 
    1123                 :             : static gzFile
    1124                 :       17695 : gzopen_included_file (const char *name, bool include_cwd, bool module)
    1125                 :             : {
    1126                 :       17695 :   gzFile f = NULL;
    1127                 :             : 
    1128                 :       17695 :   if (IS_ABSOLUTE_PATH (name) || include_cwd)
    1129                 :             :     {
    1130                 :       17695 :       f = gzopen (name, "r");
    1131                 :       17695 :       if (f)
    1132                 :             :         {
    1133                 :       10244 :           if (gfc_cpp_makedep ())
    1134                 :           0 :             gfc_cpp_add_dep (name, false);
    1135                 :             : 
    1136                 :       10244 :           free (module_fullpath);
    1137                 :       10244 :           module_fullpath = xstrdup (name);
    1138                 :             :         }
    1139                 :             :     }
    1140                 :             : 
    1141                 :       10244 :   if (!f)
    1142                 :        7451 :     f = gzopen_included_file_1 (name, include_dirs, module, false);
    1143                 :             : 
    1144                 :       17695 :   return f;
    1145                 :             : }
    1146                 :             : 
    1147                 :             : static gzFile
    1148                 :         770 : gzopen_intrinsic_module (const char* name)
    1149                 :             : {
    1150                 :         770 :   gzFile f = NULL;
    1151                 :             : 
    1152                 :         770 :   if (IS_ABSOLUTE_PATH (name))
    1153                 :             :     {
    1154                 :           0 :       f = gzopen (name, "r");
    1155                 :           0 :       if (f)
    1156                 :             :         {
    1157                 :           0 :           if (gfc_cpp_makedep ())
    1158                 :           0 :             gfc_cpp_add_dep (name, true);
    1159                 :             : 
    1160                 :           0 :           free (module_fullpath);
    1161                 :           0 :           module_fullpath = xstrdup (name);
    1162                 :             :         }
    1163                 :             :     }
    1164                 :             : 
    1165                 :           0 :   if (!f)
    1166                 :         770 :     f = gzopen_included_file_1 (name, intrinsic_modules_dirs, true, true);
    1167                 :             : 
    1168                 :         770 :   return f;
    1169                 :             : }
    1170                 :             : 
    1171                 :             : 
    1172                 :             : enum atom_type
    1173                 :             : {
    1174                 :             :   ATOM_NAME, ATOM_LPAREN, ATOM_RPAREN, ATOM_INTEGER, ATOM_STRING
    1175                 :             : };
    1176                 :             : 
    1177                 :             : static atom_type last_atom;
    1178                 :             : 
    1179                 :             : 
    1180                 :             : /* The name buffer must be at least as long as a symbol name.  Right
    1181                 :             :    now it's not clear how we're going to store numeric constants--
    1182                 :             :    probably as a hexadecimal string, since this will allow the exact
    1183                 :             :    number to be preserved (this can't be done by a decimal
    1184                 :             :    representation).  Worry about that later.  TODO!  */
    1185                 :             : 
    1186                 :             : #define MAX_ATOM_SIZE 100
    1187                 :             : 
    1188                 :             : static HOST_WIDE_INT atom_int;
    1189                 :             : static char *atom_string, atom_name[MAX_ATOM_SIZE];
    1190                 :             : 
    1191                 :             : 
    1192                 :             : /* Report problems with a module.  Error reporting is not very
    1193                 :             :    elaborate, since this sorts of errors shouldn't really happen.
    1194                 :             :    This subroutine never returns.  */
    1195                 :             : 
    1196                 :             : static void bad_module (const char *) ATTRIBUTE_NORETURN;
    1197                 :             : 
    1198                 :             : static void
    1199                 :           0 : bad_module (const char *msgid)
    1200                 :             : {
    1201                 :           0 :   XDELETEVEC (module_content);
    1202                 :           0 :   module_content = NULL;
    1203                 :             : 
    1204                 :           0 :   switch (iomode)
    1205                 :             :     {
    1206                 :           0 :     case IO_INPUT:
    1207                 :           0 :       gfc_fatal_error ("Reading module %qs at line %d column %d: %s",
    1208                 :             :                        module_fullpath, module_line, module_column, msgid);
    1209                 :           0 :       break;
    1210                 :           0 :     case IO_OUTPUT:
    1211                 :           0 :       gfc_fatal_error ("Writing module %qs at line %d column %d: %s",
    1212                 :             :                        module_name, module_line, module_column, msgid);
    1213                 :           0 :       break;
    1214                 :           0 :     default:
    1215                 :           0 :       gfc_fatal_error ("Module %qs at line %d column %d: %s",
    1216                 :             :                        module_name, module_line, module_column, msgid);
    1217                 :             :       break;
    1218                 :             :     }
    1219                 :             : }
    1220                 :             : 
    1221                 :             : 
    1222                 :             : /* Set the module's input pointer.  */
    1223                 :             : 
    1224                 :             : static void
    1225                 :      797684 : set_module_locus (module_locus *m)
    1226                 :             : {
    1227                 :      797684 :   module_column = m->column;
    1228                 :      797684 :   module_line = m->line;
    1229                 :      797684 :   module_pos = m->pos;
    1230                 :           0 : }
    1231                 :             : 
    1232                 :             : 
    1233                 :             : /* Get the module's input pointer so that we can restore it later.  */
    1234                 :             : 
    1235                 :             : static void
    1236                 :      973932 : get_module_locus (module_locus *m)
    1237                 :             : {
    1238                 :      973932 :   m->column = module_column;
    1239                 :      973932 :   m->line = module_line;
    1240                 :      973932 :   m->pos = module_pos;
    1241                 :           0 : }
    1242                 :             : 
    1243                 :             : /* Peek at the next character in the module.  */
    1244                 :             : 
    1245                 :             : static int
    1246                 :         510 : module_peek_char (void)
    1247                 :             : {
    1248                 :         510 :   return module_content[module_pos];
    1249                 :             : }
    1250                 :             : 
    1251                 :             : /* Get the next character in the module, updating our reckoning of
    1252                 :             :    where we are.  */
    1253                 :             : 
    1254                 :             : static int
    1255                 :   412736120 : module_char (void)
    1256                 :             : {
    1257                 :   412736120 :   const char c = module_content[module_pos++];
    1258                 :   412736120 :   if (c == '\0')
    1259                 :           0 :     bad_module ("Unexpected EOF");
    1260                 :             : 
    1261                 :   412736120 :   prev_module_line = module_line;
    1262                 :   412736120 :   prev_module_column = module_column;
    1263                 :             : 
    1264                 :   412736120 :   if (c == '\n')
    1265                 :             :     {
    1266                 :     8748270 :       module_line++;
    1267                 :     8748270 :       module_column = 0;
    1268                 :             :     }
    1269                 :             : 
    1270                 :   412736120 :   module_column++;
    1271                 :   412736120 :   return c;
    1272                 :             : }
    1273                 :             : 
    1274                 :             : /* Unget a character while remembering the line and column.  Works for
    1275                 :             :    a single character only.  */
    1276                 :             : 
    1277                 :             : static void
    1278                 :    60247905 : module_unget_char (void)
    1279                 :             : {
    1280                 :    60247905 :   module_line = prev_module_line;
    1281                 :    60247905 :   module_column = prev_module_column;
    1282                 :    60247905 :   module_pos--;
    1283                 :           0 : }
    1284                 :             : 
    1285                 :             : /* Parse a string constant.  The delimiter is guaranteed to be a
    1286                 :             :    single quote.  */
    1287                 :             : 
    1288                 :             : static void
    1289                 :     4172606 : parse_string (void)
    1290                 :             : {
    1291                 :     4172606 :   int c;
    1292                 :     4172606 :   size_t cursz = 30;
    1293                 :     4172606 :   size_t len = 0;
    1294                 :             : 
    1295                 :     4172606 :   atom_string = XNEWVEC (char, cursz);
    1296                 :             : 
    1297                 :    60666638 :   for ( ; ; )
    1298                 :             :     {
    1299                 :    32419622 :       c = module_char ();
    1300                 :             : 
    1301                 :    32419622 :       if (c == '\'')
    1302                 :             :         {
    1303                 :     4172606 :           int c2 = module_char ();
    1304                 :     4172606 :           if (c2 != '\'')
    1305                 :             :             {
    1306                 :     4172606 :               module_unget_char ();
    1307                 :     4172606 :               break;
    1308                 :             :             }
    1309                 :             :         }
    1310                 :             : 
    1311                 :    28247016 :       if (len >= cursz)
    1312                 :             :         {
    1313                 :       46925 :           cursz *= 2;
    1314                 :       46925 :           atom_string = XRESIZEVEC (char, atom_string, cursz);
    1315                 :             :         }
    1316                 :    28247016 :       atom_string[len] = c;
    1317                 :    28247016 :       len++;
    1318                 :    28247016 :     }
    1319                 :             : 
    1320                 :     4172606 :   atom_string = XRESIZEVEC (char, atom_string, len + 1);
    1321                 :     4172606 :   atom_string[len] = '\0';      /* C-style string for debug purposes.  */
    1322                 :     4172606 : }
    1323                 :             : 
    1324                 :             : 
    1325                 :             : /* Parse an integer. Should fit in a HOST_WIDE_INT.  */
    1326                 :             : 
    1327                 :             : static void
    1328                 :    27093584 : parse_integer (int c)
    1329                 :             : {
    1330                 :    27093584 :   int sign = 1;
    1331                 :             : 
    1332                 :    27093584 :   atom_int = 0;
    1333                 :    27093584 :   switch (c)
    1334                 :             :     {
    1335                 :             :     case ('-'):
    1336                 :    27093584 :       sign = -1;
    1337                 :             :     case ('+'):
    1338                 :             :       break;
    1339                 :    27093074 :     default:
    1340                 :    27093074 :       atom_int = c - '0';
    1341                 :    27093074 :       break;
    1342                 :             :     }
    1343                 :             : 
    1344                 :    41053756 :   for (;;)
    1345                 :             :     {
    1346                 :    34073670 :       c = module_char ();
    1347                 :    34073670 :       if (!ISDIGIT (c))
    1348                 :             :         {
    1349                 :    27093584 :           module_unget_char ();
    1350                 :    27093584 :           break;
    1351                 :             :         }
    1352                 :             : 
    1353                 :     6980086 :       atom_int = 10 * atom_int + c - '0';
    1354                 :             :     }
    1355                 :             : 
    1356                 :    27093584 :   atom_int *= sign; 
    1357                 :    27093584 : }
    1358                 :             : 
    1359                 :             : 
    1360                 :             : /* Parse a name.  */
    1361                 :             : 
    1362                 :             : static void
    1363                 :    20143465 : parse_name (int c)
    1364                 :             : {
    1365                 :    20143465 :   char *p;
    1366                 :    20143465 :   int len;
    1367                 :             : 
    1368                 :    20143465 :   p = atom_name;
    1369                 :             : 
    1370                 :    20143465 :   *p++ = c;
    1371                 :    20143465 :   len = 1;
    1372                 :             : 
    1373                 :   170518943 :   for (;;)
    1374                 :             :     {
    1375                 :   170518943 :       c = module_char ();
    1376                 :   170518943 :       if (!ISALNUM (c) && c != '_' && c != '-')
    1377                 :             :         {
    1378                 :    20143465 :           module_unget_char ();
    1379                 :    20143465 :           break;
    1380                 :             :         }
    1381                 :             : 
    1382                 :   150375478 :       *p++ = c;
    1383                 :   150375478 :       if (++len > GFC_MAX_SYMBOL_LEN)
    1384                 :           0 :         bad_module ("Name too long");
    1385                 :             :     }
    1386                 :             : 
    1387                 :    20143465 :   *p = '\0';
    1388                 :             : 
    1389                 :    20143465 : }
    1390                 :             : 
    1391                 :             : 
    1392                 :             : /* Read the next atom in the module's input stream.  */
    1393                 :             : 
    1394                 :             : static atom_type
    1395                 :    96048541 : parse_atom (void)
    1396                 :             : {
    1397                 :   160546483 :   int c;
    1398                 :             : 
    1399                 :   160546483 :   do
    1400                 :             :     {
    1401                 :   160546483 :       c = module_char ();
    1402                 :             :     }
    1403                 :   160546483 :   while (c == ' ' || c == '\r' || c == '\n');
    1404                 :             : 
    1405                 :    96048541 :   switch (c)
    1406                 :             :     {
    1407                 :             :     case '(':
    1408                 :             :       return ATOM_LPAREN;
    1409                 :             : 
    1410                 :    22337271 :     case ')':
    1411                 :    22337271 :       return ATOM_RPAREN;
    1412                 :             : 
    1413                 :     4172606 :     case '\'':
    1414                 :     4172606 :       parse_string ();
    1415                 :     4172606 :       return ATOM_STRING;
    1416                 :             : 
    1417                 :    27093074 :     case '0':
    1418                 :    27093074 :     case '1':
    1419                 :    27093074 :     case '2':
    1420                 :    27093074 :     case '3':
    1421                 :    27093074 :     case '4':
    1422                 :    27093074 :     case '5':
    1423                 :    27093074 :     case '6':
    1424                 :    27093074 :     case '7':
    1425                 :    27093074 :     case '8':
    1426                 :    27093074 :     case '9':
    1427                 :    27093074 :       parse_integer (c);
    1428                 :    27093074 :       return ATOM_INTEGER;
    1429                 :             : 
    1430                 :         510 :     case '+':
    1431                 :         510 :     case '-':
    1432                 :         510 :       if (ISDIGIT (module_peek_char ()))
    1433                 :             :         {
    1434                 :         510 :           parse_integer (c);
    1435                 :         510 :           return ATOM_INTEGER;
    1436                 :             :         }
    1437                 :             :       else
    1438                 :           0 :         bad_module ("Bad name");
    1439                 :             : 
    1440                 :    20107789 :     case 'a':
    1441                 :    20107789 :     case 'b':
    1442                 :    20107789 :     case 'c':
    1443                 :    20107789 :     case 'd':
    1444                 :    20107789 :     case 'e':
    1445                 :    20107789 :     case 'f':
    1446                 :    20107789 :     case 'g':
    1447                 :    20107789 :     case 'h':
    1448                 :    20107789 :     case 'i':
    1449                 :    20107789 :     case 'j':
    1450                 :    20107789 :     case 'k':
    1451                 :    20107789 :     case 'l':
    1452                 :    20107789 :     case 'm':
    1453                 :    20107789 :     case 'n':
    1454                 :    20107789 :     case 'o':
    1455                 :    20107789 :     case 'p':
    1456                 :    20107789 :     case 'q':
    1457                 :    20107789 :     case 'r':
    1458                 :    20107789 :     case 's':
    1459                 :    20107789 :     case 't':
    1460                 :    20107789 :     case 'u':
    1461                 :    20107789 :     case 'v':
    1462                 :    20107789 :     case 'w':
    1463                 :    20107789 :     case 'x':
    1464                 :    20107789 :     case 'y':
    1465                 :    20107789 :     case 'z':
    1466                 :    20107789 :     case 'A':
    1467                 :    20107789 :     case 'B':
    1468                 :    20107789 :     case 'C':
    1469                 :    20107789 :     case 'D':
    1470                 :    20107789 :     case 'E':
    1471                 :    20107789 :     case 'F':
    1472                 :    20107789 :     case 'G':
    1473                 :    20107789 :     case 'H':
    1474                 :    20107789 :     case 'I':
    1475                 :    20107789 :     case 'J':
    1476                 :    20107789 :     case 'K':
    1477                 :    20107789 :     case 'L':
    1478                 :    20107789 :     case 'M':
    1479                 :    20107789 :     case 'N':
    1480                 :    20107789 :     case 'O':
    1481                 :    20107789 :     case 'P':
    1482                 :    20107789 :     case 'Q':
    1483                 :    20107789 :     case 'R':
    1484                 :    20107789 :     case 'S':
    1485                 :    20107789 :     case 'T':
    1486                 :    20107789 :     case 'U':
    1487                 :    20107789 :     case 'V':
    1488                 :    20107789 :     case 'W':
    1489                 :    20107789 :     case 'X':
    1490                 :    20107789 :     case 'Y':
    1491                 :    20107789 :     case 'Z':
    1492                 :    20107789 :       parse_name (c);
    1493                 :    20107789 :       return ATOM_NAME;
    1494                 :             : 
    1495                 :           0 :     default:
    1496                 :           0 :       bad_module ("Bad name");
    1497                 :             :     }
    1498                 :             : 
    1499                 :             :   /* Not reached.  */
    1500                 :             : }
    1501                 :             : 
    1502                 :             : 
    1503                 :             : /* Peek at the next atom on the input.  */
    1504                 :             : 
    1505                 :             : static atom_type
    1506                 :     8838250 : peek_atom (void)
    1507                 :             : {
    1508                 :    10573060 :   int c;
    1509                 :             : 
    1510                 :    10573060 :   do
    1511                 :             :     {
    1512                 :    10573060 :       c = module_char ();
    1513                 :             :     }
    1514                 :    10573060 :   while (c == ' ' || c == '\r' || c == '\n');
    1515                 :             : 
    1516                 :     8838250 :   switch (c)
    1517                 :             :     {
    1518                 :      240918 :     case '(':
    1519                 :      240918 :       module_unget_char ();
    1520                 :      240918 :       return ATOM_LPAREN;
    1521                 :             : 
    1522                 :     6778856 :     case ')':
    1523                 :     6778856 :       module_unget_char ();
    1524                 :     6778856 :       return ATOM_RPAREN;
    1525                 :             : 
    1526                 :      353293 :     case '\'':
    1527                 :      353293 :       module_unget_char ();
    1528                 :      353293 :       return ATOM_STRING;
    1529                 :             : 
    1530                 :     1464560 :     case '0':
    1531                 :     1464560 :     case '1':
    1532                 :     1464560 :     case '2':
    1533                 :     1464560 :     case '3':
    1534                 :     1464560 :     case '4':
    1535                 :     1464560 :     case '5':
    1536                 :     1464560 :     case '6':
    1537                 :     1464560 :     case '7':
    1538                 :     1464560 :     case '8':
    1539                 :     1464560 :     case '9':
    1540                 :     1464560 :       module_unget_char ();
    1541                 :     1464560 :       return ATOM_INTEGER;
    1542                 :             : 
    1543                 :           0 :     case '+':
    1544                 :           0 :     case '-':
    1545                 :           0 :       if (ISDIGIT (module_peek_char ()))
    1546                 :             :         {
    1547                 :           0 :           module_unget_char ();
    1548                 :           0 :           return ATOM_INTEGER;
    1549                 :             :         }
    1550                 :             :       else
    1551                 :           0 :         bad_module ("Bad name");
    1552                 :             : 
    1553                 :         623 :     case 'a':
    1554                 :         623 :     case 'b':
    1555                 :         623 :     case 'c':
    1556                 :         623 :     case 'd':
    1557                 :         623 :     case 'e':
    1558                 :         623 :     case 'f':
    1559                 :         623 :     case 'g':
    1560                 :         623 :     case 'h':
    1561                 :         623 :     case 'i':
    1562                 :         623 :     case 'j':
    1563                 :         623 :     case 'k':
    1564                 :         623 :     case 'l':
    1565                 :         623 :     case 'm':
    1566                 :         623 :     case 'n':
    1567                 :         623 :     case 'o':
    1568                 :         623 :     case 'p':
    1569                 :         623 :     case 'q':
    1570                 :         623 :     case 'r':
    1571                 :         623 :     case 's':
    1572                 :         623 :     case 't':
    1573                 :         623 :     case 'u':
    1574                 :         623 :     case 'v':
    1575                 :         623 :     case 'w':
    1576                 :         623 :     case 'x':
    1577                 :         623 :     case 'y':
    1578                 :         623 :     case 'z':
    1579                 :         623 :     case 'A':
    1580                 :         623 :     case 'B':
    1581                 :         623 :     case 'C':
    1582                 :         623 :     case 'D':
    1583                 :         623 :     case 'E':
    1584                 :         623 :     case 'F':
    1585                 :         623 :     case 'G':
    1586                 :         623 :     case 'H':
    1587                 :         623 :     case 'I':
    1588                 :         623 :     case 'J':
    1589                 :         623 :     case 'K':
    1590                 :         623 :     case 'L':
    1591                 :         623 :     case 'M':
    1592                 :         623 :     case 'N':
    1593                 :         623 :     case 'O':
    1594                 :         623 :     case 'P':
    1595                 :         623 :     case 'Q':
    1596                 :         623 :     case 'R':
    1597                 :         623 :     case 'S':
    1598                 :         623 :     case 'T':
    1599                 :         623 :     case 'U':
    1600                 :         623 :     case 'V':
    1601                 :         623 :     case 'W':
    1602                 :         623 :     case 'X':
    1603                 :         623 :     case 'Y':
    1604                 :         623 :     case 'Z':
    1605                 :         623 :       module_unget_char ();
    1606                 :         623 :       return ATOM_NAME;
    1607                 :             : 
    1608                 :           0 :     default:
    1609                 :           0 :       bad_module ("Bad name");
    1610                 :             :     }
    1611                 :             : }
    1612                 :             : 
    1613                 :             : 
    1614                 :             : /* Read the next atom from the input, requiring that it be a
    1615                 :             :    particular kind.  */
    1616                 :             : 
    1617                 :             : static void
    1618                 :    43212718 : require_atom (atom_type type)
    1619                 :             : {
    1620                 :    43212718 :   atom_type t;
    1621                 :    43212718 :   const char *p;
    1622                 :    43212718 :   int column, line;
    1623                 :             : 
    1624                 :    43212718 :   column = module_column;
    1625                 :    43212718 :   line = module_line;
    1626                 :             : 
    1627                 :    43212718 :   t = parse_atom ();
    1628                 :    43212718 :   if (t != type)
    1629                 :             :     {
    1630                 :           0 :       switch (type)
    1631                 :             :         {
    1632                 :           0 :         case ATOM_NAME:
    1633                 :           0 :           p = _("Expected name");
    1634                 :           0 :           break;
    1635                 :           0 :         case ATOM_LPAREN:
    1636                 :           0 :           p = _("Expected left parenthesis");
    1637                 :           0 :           break;
    1638                 :           0 :         case ATOM_RPAREN:
    1639                 :           0 :           p = _("Expected right parenthesis");
    1640                 :           0 :           break;
    1641                 :           0 :         case ATOM_INTEGER:
    1642                 :           0 :           p = _("Expected integer");
    1643                 :           0 :           break;
    1644                 :           0 :         case ATOM_STRING:
    1645                 :           0 :           p = _("Expected string");
    1646                 :           0 :           break;
    1647                 :           0 :         default:
    1648                 :           0 :           gfc_internal_error ("require_atom(): bad atom type required");
    1649                 :             :         }
    1650                 :             : 
    1651                 :           0 :       module_column = column;
    1652                 :           0 :       module_line = line;
    1653                 :           0 :       bad_module (p);
    1654                 :             :     }
    1655                 :    43212718 : }
    1656                 :             : 
    1657                 :             : 
    1658                 :             : /* Given a pointer to an mstring array, require that the current input
    1659                 :             :    be one of the strings in the array.  We return the enum value.  */
    1660                 :             : 
    1661                 :             : static int
    1662                 :     9060552 : find_enum (const mstring *m)
    1663                 :             : {
    1664                 :     9060552 :   int i;
    1665                 :             : 
    1666                 :     9060552 :   i = gfc_string2code (m, atom_name);
    1667                 :     9060552 :   if (i >= 0)
    1668                 :     9060552 :     return i;
    1669                 :             : 
    1670                 :           0 :   bad_module ("find_enum(): Enum not found");
    1671                 :             : 
    1672                 :             :   /* Not reached.  */
    1673                 :             : }
    1674                 :             : 
    1675                 :             : 
    1676                 :             : /* Read a string. The caller is responsible for freeing.  */
    1677                 :             : 
    1678                 :             : static char*
    1679                 :     2814914 : read_string (void)
    1680                 :             : {
    1681                 :     2814914 :   char* p;
    1682                 :           0 :   require_atom (ATOM_STRING);
    1683                 :     2814914 :   p = atom_string;
    1684                 :     2814914 :   atom_string = NULL;
    1685                 :     2814914 :   return p;
    1686                 :             : }
    1687                 :             : 
    1688                 :             : 
    1689                 :             : /**************** Module output subroutines ***************************/
    1690                 :             : 
    1691                 :             : /* Output a character to a module file.  */
    1692                 :             : 
    1693                 :             : static void
    1694                 :    56044332 : write_char (char out)
    1695                 :             : {
    1696                 :    56044332 :   if (gzputc (module_fp, out) == EOF)
    1697                 :           0 :     gfc_fatal_error ("Error writing modules file: %s", xstrerror (errno));
    1698                 :             : 
    1699                 :    56044332 :   if (out != '\n')
    1700                 :    55018743 :     module_column++;
    1701                 :             :   else
    1702                 :             :     {
    1703                 :     1025589 :       module_column = 1;
    1704                 :     1025589 :       module_line++;
    1705                 :             :     }
    1706                 :    56044332 : }
    1707                 :             : 
    1708                 :             : 
    1709                 :             : /* Write an atom to a module.  The line wrapping isn't perfect, but it
    1710                 :             :    should work most of the time.  This isn't that big of a deal, since
    1711                 :             :    the file really isn't meant to be read by people anyway.  */
    1712                 :             : 
    1713                 :             : static void
    1714                 :    14933070 : write_atom (atom_type atom, const void *v)
    1715                 :             : {
    1716                 :    14933070 :   char buffer[32];
    1717                 :             : 
    1718                 :             :   /* Workaround -Wmaybe-uninitialized false positive during
    1719                 :             :      profiledbootstrap by initializing them.  */
    1720                 :    14933070 :   int len;
    1721                 :    14933070 :   HOST_WIDE_INT i = 0;
    1722                 :    14933070 :   const char *p;
    1723                 :             : 
    1724                 :    14933070 :   switch (atom)
    1725                 :             :     {
    1726                 :             :     case ATOM_STRING:
    1727                 :             :     case ATOM_NAME:
    1728                 :             :       p = (const char *) v;
    1729                 :             :       break;
    1730                 :             : 
    1731                 :             :     case ATOM_LPAREN:
    1732                 :             :       p = "(";
    1733                 :             :       break;
    1734                 :             : 
    1735                 :             :     case ATOM_RPAREN:
    1736                 :             :       p = ")";
    1737                 :             :       break;
    1738                 :             : 
    1739                 :     4042962 :     case ATOM_INTEGER:
    1740                 :     4042962 :       i = *((const HOST_WIDE_INT *) v);
    1741                 :             : 
    1742                 :     4042962 :       snprintf (buffer, sizeof (buffer), HOST_WIDE_INT_PRINT_DEC, i);
    1743                 :     4042962 :       p = buffer;
    1744                 :     4042962 :       break;
    1745                 :             : 
    1746                 :           0 :     default:
    1747                 :           0 :       gfc_internal_error ("write_atom(): Trying to write dab atom");
    1748                 :             : 
    1749                 :             :     }
    1750                 :             : 
    1751                 :    14933070 :   if(p == NULL || *p == '\0')
    1752                 :             :      len = 0;
    1753                 :             :   else
    1754                 :    14626136 :   len = strlen (p);
    1755                 :             : 
    1756                 :    14933070 :   if (atom != ATOM_RPAREN)
    1757                 :             :     {
    1758                 :    11502216 :       if (module_column + len > 72)
    1759                 :      694917 :         write_char ('\n');
    1760                 :             :       else
    1761                 :             :         {
    1762                 :             : 
    1763                 :    10807299 :           if (last_atom != ATOM_LPAREN && module_column != 1)
    1764                 :     9389056 :             write_char (' ');
    1765                 :             :         }
    1766                 :             :     }
    1767                 :             : 
    1768                 :    11502216 :   if (atom == ATOM_STRING)
    1769                 :      925898 :     write_char ('\'');
    1770                 :             : 
    1771                 :    58710961 :   while (p != NULL && *p)
    1772                 :             :     {
    1773                 :    43777891 :       if (atom == ATOM_STRING && *p == '\'')
    1774                 :           0 :         write_char ('\'');
    1775                 :    43777891 :       write_char (*p++);
    1776                 :             :     }
    1777                 :             : 
    1778                 :    14933070 :   if (atom == ATOM_STRING)
    1779                 :      925898 :     write_char ('\'');
    1780                 :             : 
    1781                 :    14933070 :   last_atom = atom;
    1782                 :    14933070 : }
    1783                 :             : 
    1784                 :             : 
    1785                 :             : 
    1786                 :             : /***************** Mid-level I/O subroutines *****************/
    1787                 :             : 
    1788                 :             : /* These subroutines let their caller read or write atoms without
    1789                 :             :    caring about which of the two is actually happening.  This lets a
    1790                 :             :    subroutine concentrate on the actual format of the data being
    1791                 :             :    written.  */
    1792                 :             : 
    1793                 :             : static void mio_expr (gfc_expr **);
    1794                 :             : pointer_info *mio_symbol_ref (gfc_symbol **);
    1795                 :             : pointer_info *mio_interface_rest (gfc_interface **);
    1796                 :             : static void mio_symtree_ref (gfc_symtree **);
    1797                 :             : 
    1798                 :             : /* Read or write an enumerated value.  On writing, we return the input
    1799                 :             :    value for the convenience of callers.  We avoid using an integer
    1800                 :             :    pointer because enums are sometimes inside bitfields.  */
    1801                 :             : 
    1802                 :             : static int
    1803                 :    10229701 : mio_name (int t, const mstring *m)
    1804                 :             : {
    1805                 :    10229701 :   if (iomode == IO_OUTPUT)
    1806                 :     3101994 :     write_atom (ATOM_NAME, gfc_code2string (m, t));
    1807                 :             :   else
    1808                 :             :     {
    1809                 :     7127707 :       require_atom (ATOM_NAME);
    1810                 :     7127707 :       t = find_enum (m);
    1811                 :             :     }
    1812                 :             : 
    1813                 :    10229701 :   return t;
    1814                 :             : }
    1815                 :             : 
    1816                 :             : /* Specialization of mio_name.  */
    1817                 :             : 
    1818                 :             : #define DECL_MIO_NAME(TYPE) \
    1819                 :             :  static inline TYPE \
    1820                 :             :  MIO_NAME(TYPE) (TYPE t, const mstring *m) \
    1821                 :             :  { \
    1822                 :             :    return (TYPE) mio_name ((int) t, m); \
    1823                 :             :  }
    1824                 :             : #define MIO_NAME(TYPE) mio_name_##TYPE
    1825                 :             : 
    1826                 :             : static void
    1827                 :    13503371 : mio_lparen (void)
    1828                 :             : {
    1829                 :    13503371 :   if (iomode == IO_OUTPUT)
    1830                 :     3430854 :     write_atom (ATOM_LPAREN, NULL);
    1831                 :             :   else
    1832                 :    10072517 :     require_atom (ATOM_LPAREN);
    1833                 :    13503371 : }
    1834                 :             : 
    1835                 :             : 
    1836                 :             : static void
    1837                 :    12380742 : mio_rparen (void)
    1838                 :             : {
    1839                 :    12380742 :   if (iomode == IO_OUTPUT)
    1840                 :     3430854 :     write_atom (ATOM_RPAREN, NULL);
    1841                 :             :   else
    1842                 :     8949888 :     require_atom (ATOM_RPAREN);
    1843                 :    12380742 : }
    1844                 :             : 
    1845                 :             : 
    1846                 :             : static void
    1847                 :    10039154 : mio_integer (int *ip)
    1848                 :             : {
    1849                 :    10039154 :   if (iomode == IO_OUTPUT)
    1850                 :             :     {
    1851                 :     2492374 :       HOST_WIDE_INT hwi = *ip;
    1852                 :     2492374 :       write_atom (ATOM_INTEGER, &hwi);
    1853                 :             :     }
    1854                 :             :   else
    1855                 :             :     {
    1856                 :     7546780 :       require_atom (ATOM_INTEGER);
    1857                 :     7546780 :       *ip = atom_int;
    1858                 :             :     }
    1859                 :    10039154 : }
    1860                 :             : 
    1861                 :             : static void
    1862                 :      333163 : mio_hwi (HOST_WIDE_INT *hwi)
    1863                 :             : {
    1864                 :      333163 :   if (iomode == IO_OUTPUT)
    1865                 :      198379 :     write_atom (ATOM_INTEGER, hwi);
    1866                 :             :   else
    1867                 :             :     {
    1868                 :      134784 :       require_atom (ATOM_INTEGER);
    1869                 :      134784 :       *hwi = atom_int;
    1870                 :             :     }
    1871                 :      333163 : }
    1872                 :             : 
    1873                 :             : 
    1874                 :             : /* Read or write a gfc_intrinsic_op value.  */
    1875                 :             : 
    1876                 :             : static void
    1877                 :        1225 : mio_intrinsic_op (gfc_intrinsic_op* op)
    1878                 :             : {
    1879                 :             :   /* FIXME: Would be nicer to do this via the operators symbolic name.  */
    1880                 :        1225 :   if (iomode == IO_OUTPUT)
    1881                 :             :     {
    1882                 :         653 :       HOST_WIDE_INT converted = (HOST_WIDE_INT) *op;
    1883                 :         653 :       write_atom (ATOM_INTEGER, &converted);
    1884                 :             :     }
    1885                 :             :   else
    1886                 :             :     {
    1887                 :         572 :       require_atom (ATOM_INTEGER);
    1888                 :         572 :       *op = (gfc_intrinsic_op) atom_int;
    1889                 :             :     }
    1890                 :        1225 : }
    1891                 :             : 
    1892                 :             : 
    1893                 :             : /* Read or write a character pointer that points to a string on the heap.  */
    1894                 :             : 
    1895                 :             : static const char *
    1896                 :        7523 : mio_allocated_string (const char *s)
    1897                 :             : {
    1898                 :        7523 :   if (iomode == IO_OUTPUT)
    1899                 :             :     {
    1900                 :        7523 :       write_atom (ATOM_STRING, s);
    1901                 :        7523 :       return s;
    1902                 :             :     }
    1903                 :             :   else
    1904                 :             :     {
    1905                 :           0 :       require_atom (ATOM_STRING);
    1906                 :           0 :       return atom_string;
    1907                 :             :     }
    1908                 :             : }
    1909                 :             : 
    1910                 :             : 
    1911                 :             : /* Functions for quoting and unquoting strings.  */
    1912                 :             : 
    1913                 :             : static char *
    1914                 :        5028 : quote_string (const gfc_char_t *s, const size_t slength)
    1915                 :             : {
    1916                 :        5028 :   const gfc_char_t *p;
    1917                 :        5028 :   char *res, *q;
    1918                 :        5028 :   size_t len = 0, i;
    1919                 :             : 
    1920                 :             :   /* Calculate the length we'll need: a backslash takes two ("\\"),
    1921                 :             :      non-printable characters take 10 ("\Uxxxxxxxx") and others take 1.  */
    1922                 :       19295 :   for (p = s, i = 0; i < slength; p++, i++)
    1923                 :             :     {
    1924                 :       14267 :       if (*p == '\\')
    1925                 :           1 :         len += 2;
    1926                 :       14266 :       else if (!gfc_wide_is_printable (*p))
    1927                 :        4096 :         len += 10;
    1928                 :             :       else
    1929                 :       10170 :         len++;
    1930                 :             :     }
    1931                 :             : 
    1932                 :        5028 :   q = res = XCNEWVEC (char, len + 1);
    1933                 :       24323 :   for (p = s, i = 0; i < slength; p++, i++)
    1934                 :             :     {
    1935                 :       14267 :       if (*p == '\\')
    1936                 :           1 :         *q++ = '\\', *q++ = '\\';
    1937                 :       14266 :       else if (!gfc_wide_is_printable (*p))
    1938                 :             :         {
    1939                 :        4096 :           sprintf (q, "\\U%08" HOST_WIDE_INT_PRINT "x",
    1940                 :        4096 :                    (unsigned HOST_WIDE_INT) *p);
    1941                 :        4096 :           q += 10;
    1942                 :             :         }
    1943                 :             :       else
    1944                 :       10170 :         *q++ = (unsigned char) *p;
    1945                 :             :     }
    1946                 :             : 
    1947                 :        5028 :   res[len] = '\0';
    1948                 :        5028 :   return res;
    1949                 :             : }
    1950                 :             : 
    1951                 :             : static gfc_char_t *
    1952                 :        2520 : unquote_string (const char *s)
    1953                 :             : {
    1954                 :        2520 :   size_t len, i;
    1955                 :        2520 :   const char *p;
    1956                 :        2520 :   gfc_char_t *res;
    1957                 :             : 
    1958                 :       13750 :   for (p = s, len = 0; *p; p++, len++)
    1959                 :             :     {
    1960                 :       11230 :       if (*p != '\\')
    1961                 :        9599 :         continue;
    1962                 :             : 
    1963                 :        1631 :       if (p[1] == '\\')
    1964                 :           0 :         p++;
    1965                 :        1631 :       else if (p[1] == 'U')
    1966                 :        1631 :         p += 9; /* That is a "\U????????".  */
    1967                 :             :       else
    1968                 :           0 :         gfc_internal_error ("unquote_string(): got bad string");
    1969                 :             :     }
    1970                 :             : 
    1971                 :        2520 :   res = gfc_get_wide_string (len + 1);
    1972                 :       13750 :   for (i = 0, p = s; i < len; i++, p++)
    1973                 :             :     {
    1974                 :       11230 :       gcc_assert (*p);
    1975                 :             : 
    1976                 :       11230 :       if (*p != '\\')
    1977                 :        9599 :         res[i] = (unsigned char) *p;
    1978                 :        1631 :       else if (p[1] == '\\')
    1979                 :             :         {
    1980                 :           0 :           res[i] = (unsigned char) '\\';
    1981                 :           0 :           p++;
    1982                 :             :         }
    1983                 :             :       else
    1984                 :             :         {
    1985                 :             :           /* We read the 8-digits hexadecimal constant that follows.  */
    1986                 :        1631 :           int j;
    1987                 :        1631 :           unsigned n;
    1988                 :        1631 :           gfc_char_t c = 0;
    1989                 :             : 
    1990                 :        1631 :           gcc_assert (p[1] == 'U');
    1991                 :       14679 :           for (j = 0; j < 8; j++)
    1992                 :             :             {
    1993                 :       13048 :               c = c << 4;
    1994                 :       13048 :               gcc_assert (sscanf (&p[j+2], "%01x", &n) == 1);
    1995                 :       13048 :               c += n;
    1996                 :             :             }
    1997                 :             : 
    1998                 :        1631 :           res[i] = c;
    1999                 :        1631 :           p += 9;
    2000                 :             :         }
    2001                 :             :     }
    2002                 :             : 
    2003                 :        2520 :   res[len] = '\0';
    2004                 :        2520 :   return res;
    2005                 :             : }
    2006                 :             : 
    2007                 :             : 
    2008                 :             : /* Read or write a character pointer that points to a wide string on the
    2009                 :             :    heap, performing quoting/unquoting of nonprintable characters using the
    2010                 :             :    form \U???????? (where each ? is a hexadecimal digit).
    2011                 :             :    Length is the length of the string, only known and used in output mode.  */
    2012                 :             : 
    2013                 :             : static const gfc_char_t *
    2014                 :        7548 : mio_allocated_wide_string (const gfc_char_t *s, const size_t length)
    2015                 :             : {
    2016                 :        7548 :   if (iomode == IO_OUTPUT)
    2017                 :             :     {
    2018                 :        5028 :       char *quoted = quote_string (s, length);
    2019                 :        5028 :       write_atom (ATOM_STRING, quoted);
    2020                 :        5028 :       free (quoted);
    2021                 :        5028 :       return s;
    2022                 :             :     }
    2023                 :             :   else
    2024                 :             :     {
    2025                 :        2520 :       gfc_char_t *unquoted;
    2026                 :             : 
    2027                 :        2520 :       require_atom (ATOM_STRING);
    2028                 :        2520 :       unquoted = unquote_string (atom_string);
    2029                 :        2520 :       free (atom_string);
    2030                 :        2520 :       return unquoted;
    2031                 :             :     }
    2032                 :             : }
    2033                 :             : 
    2034                 :             : 
    2035                 :             : /* Read or write a string that is in static memory.  */
    2036                 :             : 
    2037                 :             : static void
    2038                 :      847717 : mio_pool_string (const char **stringp)
    2039                 :             : {
    2040                 :             :   /* TODO: one could write the string only once, and refer to it via a
    2041                 :             :      fixup pointer.  */
    2042                 :             : 
    2043                 :             :   /* As a special case we have to deal with a NULL string.  This
    2044                 :             :      happens for the 'module' member of 'gfc_symbol's that are not in a
    2045                 :             :      module.  We read / write these as the empty string.  */
    2046                 :      847717 :   if (iomode == IO_OUTPUT)
    2047                 :             :     {
    2048                 :      653591 :       const char *p = *stringp == NULL ? "" : *stringp;
    2049                 :      653591 :       write_atom (ATOM_STRING, p);
    2050                 :             :     }
    2051                 :             :   else
    2052                 :             :     {
    2053                 :      194126 :       require_atom (ATOM_STRING);
    2054                 :      388252 :       *stringp = (atom_string[0] == '\0'
    2055                 :      194126 :                   ? NULL : gfc_get_string ("%s", atom_string));
    2056                 :      194126 :       free (atom_string);
    2057                 :             :     }
    2058                 :      847717 : }
    2059                 :             : 
    2060                 :             : 
    2061                 :             : /* Read or write a string that is inside of some already-allocated
    2062                 :             :    structure.  */
    2063                 :             : 
    2064                 :             : static void
    2065                 :      448806 : mio_internal_string (char *string)
    2066                 :             : {
    2067                 :      448806 :   if (iomode == IO_OUTPUT)
    2068                 :           0 :     write_atom (ATOM_STRING, string);
    2069                 :             :   else
    2070                 :             :     {
    2071                 :      448806 :       require_atom (ATOM_STRING);
    2072                 :      448806 :       strcpy (string, atom_string);
    2073                 :      448806 :       free (atom_string);
    2074                 :             :     }
    2075                 :      448806 : }
    2076                 :             : 
    2077                 :             : 
    2078                 :             : enum ab_attribute
    2079                 :             : { AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
    2080                 :             :   AB_POINTER, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA,
    2081                 :             :   AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE,
    2082                 :             :   AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
    2083                 :             :   AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE,
    2084                 :             :   AB_ALLOC_COMP, AB_POINTER_COMP, AB_PROC_POINTER_COMP, AB_PRIVATE_COMP,
    2085                 :             :   AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP, AB_EVENT_COMP,
    2086                 :             :   AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
    2087                 :             :   AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
    2088                 :             :   AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
    2089                 :             :   AB_IMPLICIT_PURE, AB_ARTIFICIAL, AB_UNLIMITED_POLY, AB_OMP_DECLARE_TARGET,
    2090                 :             :   AB_ARRAY_OUTER_DEPENDENCY, AB_MODULE_PROCEDURE, AB_OACC_DECLARE_CREATE,
    2091                 :             :   AB_OACC_DECLARE_COPYIN, AB_OACC_DECLARE_DEVICEPTR,
    2092                 :             :   AB_OACC_DECLARE_DEVICE_RESIDENT, AB_OACC_DECLARE_LINK,
    2093                 :             :   AB_OMP_DECLARE_TARGET_LINK, AB_PDT_KIND, AB_PDT_LEN, AB_PDT_TYPE,
    2094                 :             :   AB_PDT_TEMPLATE, AB_PDT_ARRAY, AB_PDT_STRING,
    2095                 :             :   AB_OACC_ROUTINE_LOP_GANG, AB_OACC_ROUTINE_LOP_WORKER,
    2096                 :             :   AB_OACC_ROUTINE_LOP_VECTOR, AB_OACC_ROUTINE_LOP_SEQ,
    2097                 :             :   AB_OACC_ROUTINE_NOHOST,
    2098                 :             :   AB_OMP_REQ_REVERSE_OFFLOAD, AB_OMP_REQ_UNIFIED_ADDRESS,
    2099                 :             :   AB_OMP_REQ_UNIFIED_SHARED_MEMORY, AB_OMP_REQ_DYNAMIC_ALLOCATORS,
    2100                 :             :   AB_OMP_REQ_MEM_ORDER_SEQ_CST, AB_OMP_REQ_MEM_ORDER_ACQ_REL,
    2101                 :             :   AB_OMP_REQ_MEM_ORDER_ACQUIRE, AB_OMP_REQ_MEM_ORDER_RELEASE,
    2102                 :             :   AB_OMP_REQ_MEM_ORDER_RELAXED, AB_OMP_DEVICE_TYPE_NOHOST,
    2103                 :             :   AB_OMP_DEVICE_TYPE_HOST, AB_OMP_DEVICE_TYPE_ANY
    2104                 :             : };
    2105                 :             : 
    2106                 :             : static const mstring attr_bits[] =
    2107                 :             : {
    2108                 :             :     minit ("ALLOCATABLE", AB_ALLOCATABLE),
    2109                 :             :     minit ("ARTIFICIAL", AB_ARTIFICIAL),
    2110                 :             :     minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS),
    2111                 :             :     minit ("DIMENSION", AB_DIMENSION),
    2112                 :             :     minit ("CODIMENSION", AB_CODIMENSION),
    2113                 :             :     minit ("CONTIGUOUS", AB_CONTIGUOUS),
    2114                 :             :     minit ("EXTERNAL", AB_EXTERNAL),
    2115                 :             :     minit ("INTRINSIC", AB_INTRINSIC),
    2116                 :             :     minit ("OPTIONAL", AB_OPTIONAL),
    2117                 :             :     minit ("POINTER", AB_POINTER),
    2118                 :             :     minit ("VOLATILE", AB_VOLATILE),
    2119                 :             :     minit ("TARGET", AB_TARGET),
    2120                 :             :     minit ("THREADPRIVATE", AB_THREADPRIVATE),
    2121                 :             :     minit ("DUMMY", AB_DUMMY),
    2122                 :             :     minit ("RESULT", AB_RESULT),
    2123                 :             :     minit ("DATA", AB_DATA),
    2124                 :             :     minit ("IN_NAMELIST", AB_IN_NAMELIST),
    2125                 :             :     minit ("IN_COMMON", AB_IN_COMMON),
    2126                 :             :     minit ("FUNCTION", AB_FUNCTION),
    2127                 :             :     minit ("SUBROUTINE", AB_SUBROUTINE),
    2128                 :             :     minit ("SEQUENCE", AB_SEQUENCE),
    2129                 :             :     minit ("ELEMENTAL", AB_ELEMENTAL),
    2130                 :             :     minit ("PURE", AB_PURE),
    2131                 :             :     minit ("RECURSIVE", AB_RECURSIVE),
    2132                 :             :     minit ("GENERIC", AB_GENERIC),
    2133                 :             :     minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
    2134                 :             :     minit ("CRAY_POINTER", AB_CRAY_POINTER),
    2135                 :             :     minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
    2136                 :             :     minit ("IS_BIND_C", AB_IS_BIND_C),
    2137                 :             :     minit ("IS_C_INTEROP", AB_IS_C_INTEROP),
    2138                 :             :     minit ("IS_ISO_C", AB_IS_ISO_C),
    2139                 :             :     minit ("VALUE", AB_VALUE),
    2140                 :             :     minit ("ALLOC_COMP", AB_ALLOC_COMP),
    2141                 :             :     minit ("COARRAY_COMP", AB_COARRAY_COMP),
    2142                 :             :     minit ("LOCK_COMP", AB_LOCK_COMP),
    2143                 :             :     minit ("EVENT_COMP", AB_EVENT_COMP),
    2144                 :             :     minit ("POINTER_COMP", AB_POINTER_COMP),
    2145                 :             :     minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP),
    2146                 :             :     minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
    2147                 :             :     minit ("ZERO_COMP", AB_ZERO_COMP),
    2148                 :             :     minit ("PROTECTED", AB_PROTECTED),
    2149                 :             :     minit ("ABSTRACT", AB_ABSTRACT),
    2150                 :             :     minit ("IS_CLASS", AB_IS_CLASS),
    2151                 :             :     minit ("PROCEDURE", AB_PROCEDURE),
    2152                 :             :     minit ("PROC_POINTER", AB_PROC_POINTER),
    2153                 :             :     minit ("VTYPE", AB_VTYPE),
    2154                 :             :     minit ("VTAB", AB_VTAB),
    2155                 :             :     minit ("CLASS_POINTER", AB_CLASS_POINTER),
    2156                 :             :     minit ("IMPLICIT_PURE", AB_IMPLICIT_PURE),
    2157                 :             :     minit ("UNLIMITED_POLY", AB_UNLIMITED_POLY),
    2158                 :             :     minit ("OMP_DECLARE_TARGET", AB_OMP_DECLARE_TARGET),
    2159                 :             :     minit ("ARRAY_OUTER_DEPENDENCY", AB_ARRAY_OUTER_DEPENDENCY),
    2160                 :             :     minit ("MODULE_PROCEDURE", AB_MODULE_PROCEDURE),
    2161                 :             :     minit ("OACC_DECLARE_CREATE", AB_OACC_DECLARE_CREATE),
    2162                 :             :     minit ("OACC_DECLARE_COPYIN", AB_OACC_DECLARE_COPYIN),
    2163                 :             :     minit ("OACC_DECLARE_DEVICEPTR", AB_OACC_DECLARE_DEVICEPTR),
    2164                 :             :     minit ("OACC_DECLARE_DEVICE_RESIDENT", AB_OACC_DECLARE_DEVICE_RESIDENT),
    2165                 :             :     minit ("OACC_DECLARE_LINK", AB_OACC_DECLARE_LINK),
    2166                 :             :     minit ("OMP_DECLARE_TARGET_LINK", AB_OMP_DECLARE_TARGET_LINK),
    2167                 :             :     minit ("PDT_KIND", AB_PDT_KIND),
    2168                 :             :     minit ("PDT_LEN", AB_PDT_LEN),
    2169                 :             :     minit ("PDT_TYPE", AB_PDT_TYPE),
    2170                 :             :     minit ("PDT_TEMPLATE", AB_PDT_TEMPLATE),
    2171                 :             :     minit ("PDT_ARRAY", AB_PDT_ARRAY),
    2172                 :             :     minit ("PDT_STRING", AB_PDT_STRING),
    2173                 :             :     minit ("OACC_ROUTINE_LOP_GANG", AB_OACC_ROUTINE_LOP_GANG),
    2174                 :             :     minit ("OACC_ROUTINE_LOP_WORKER", AB_OACC_ROUTINE_LOP_WORKER),
    2175                 :             :     minit ("OACC_ROUTINE_LOP_VECTOR", AB_OACC_ROUTINE_LOP_VECTOR),
    2176                 :             :     minit ("OACC_ROUTINE_LOP_SEQ", AB_OACC_ROUTINE_LOP_SEQ),
    2177                 :             :     minit ("OACC_ROUTINE_NOHOST", AB_OACC_ROUTINE_NOHOST),
    2178                 :             :     minit ("OMP_REQ_REVERSE_OFFLOAD", AB_OMP_REQ_REVERSE_OFFLOAD),
    2179                 :             :     minit ("OMP_REQ_UNIFIED_ADDRESS", AB_OMP_REQ_UNIFIED_ADDRESS),
    2180                 :             :     minit ("OMP_REQ_UNIFIED_SHARED_MEMORY", AB_OMP_REQ_UNIFIED_SHARED_MEMORY),
    2181                 :             :     minit ("OMP_REQ_DYNAMIC_ALLOCATORS", AB_OMP_REQ_DYNAMIC_ALLOCATORS),
    2182                 :             :     minit ("OMP_REQ_MEM_ORDER_SEQ_CST", AB_OMP_REQ_MEM_ORDER_SEQ_CST),
    2183                 :             :     minit ("OMP_REQ_MEM_ORDER_ACQ_REL", AB_OMP_REQ_MEM_ORDER_ACQ_REL),
    2184                 :             :     minit ("OMP_REQ_MEM_ORDER_ACQUIRE", AB_OMP_REQ_MEM_ORDER_ACQUIRE),
    2185                 :             :     minit ("OMP_REQ_MEM_ORDER_RELAXED", AB_OMP_REQ_MEM_ORDER_RELAXED),
    2186                 :             :     minit ("OMP_REQ_MEM_ORDER_RELEASE", AB_OMP_REQ_MEM_ORDER_RELEASE),
    2187                 :             :     minit ("OMP_DEVICE_TYPE_HOST", AB_OMP_DEVICE_TYPE_HOST),
    2188                 :             :     minit ("OMP_DEVICE_TYPE_NOHOST", AB_OMP_DEVICE_TYPE_NOHOST),
    2189                 :             :     minit ("OMP_DEVICE_TYPE_ANYHOST", AB_OMP_DEVICE_TYPE_ANY),
    2190                 :             :     minit (NULL, -1)
    2191                 :             : };
    2192                 :             : 
    2193                 :             : /* For binding attributes.  */
    2194                 :             : static const mstring binding_passing[] =
    2195                 :             : {
    2196                 :             :     minit ("PASS", 0),
    2197                 :             :     minit ("NOPASS", 1),
    2198                 :             :     minit (NULL, -1)
    2199                 :             : };
    2200                 :             : static const mstring binding_overriding[] =
    2201                 :             : {
    2202                 :             :     minit ("OVERRIDABLE", 0),
    2203                 :             :     minit ("NON_OVERRIDABLE", 1),
    2204                 :             :     minit ("DEFERRED", 2),
    2205                 :             :     minit (NULL, -1)
    2206                 :             : };
    2207                 :             : static const mstring binding_generic[] =
    2208                 :             : {
    2209                 :             :     minit ("SPECIFIC", 0),
    2210                 :             :     minit ("GENERIC", 1),
    2211                 :             :     minit (NULL, -1)
    2212                 :             : };
    2213                 :             : static const mstring binding_ppc[] =
    2214                 :             : {
    2215                 :             :     minit ("NO_PPC", 0),
    2216                 :             :     minit ("PPC", 1),
    2217                 :             :     minit (NULL, -1)
    2218                 :             : };
    2219                 :             : 
    2220                 :             : /* Specialization of mio_name.  */
    2221                 :      524812 : DECL_MIO_NAME (ab_attribute)
    2222                 :        3386 : DECL_MIO_NAME (ar_type)
    2223                 :      134378 : DECL_MIO_NAME (array_type)
    2224                 :     5876076 : DECL_MIO_NAME (bt)
    2225                 :       85652 : DECL_MIO_NAME (expr_t)
    2226                 :      511412 : DECL_MIO_NAME (gfc_access)
    2227                 :        1444 : DECL_MIO_NAME (gfc_intrinsic_op)
    2228                 :     1181264 : DECL_MIO_NAME (ifsrc)
    2229                 :     1181264 : DECL_MIO_NAME (save_state)
    2230                 :     1181264 : DECL_MIO_NAME (procedure_type)
    2231                 :        4126 : DECL_MIO_NAME (ref_type)
    2232                 :     1181264 : DECL_MIO_NAME (sym_flavor)
    2233                 :     1181264 : DECL_MIO_NAME (sym_intent)
    2234                 :           0 : DECL_MIO_NAME (inquiry_type)
    2235                 :             : #undef DECL_MIO_NAME
    2236                 :             : 
    2237                 :             : /* Verify OACC_ROUTINE_LOP_NONE.  */
    2238                 :             : 
    2239                 :             : static void
    2240                 :          94 : verify_OACC_ROUTINE_LOP_NONE (enum oacc_routine_lop lop)
    2241                 :             : {
    2242                 :           0 :   if (lop != OACC_ROUTINE_LOP_NONE)
    2243                 :           0 :     bad_module ("Unsupported: multiple OpenACC 'routine' levels of parallelism");
    2244                 :           0 : }
    2245                 :             : 
    2246                 :             : /* Symbol attributes are stored in list with the first three elements
    2247                 :             :    being the enumerated fields, while the remaining elements (if any)
    2248                 :             :    indicate the individual attribute bits.  The access field is not
    2249                 :             :    saved-- it controls what symbols are exported when a module is
    2250                 :             :    written.  */
    2251                 :             : 
    2252                 :             : static void
    2253                 :     1181264 : mio_symbol_attribute (symbol_attribute *attr)
    2254                 :             : {
    2255                 :     1181264 :   atom_type t;
    2256                 :     1181264 :   unsigned ext_attr,extension_level;
    2257                 :             : 
    2258                 :     1181264 :   mio_lparen ();
    2259                 :             : 
    2260                 :     1181264 :   attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors);
    2261                 :     1181264 :   attr->intent = MIO_NAME (sym_intent) (attr->intent, intents);
    2262                 :     1181264 :   attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
    2263                 :     1181264 :   attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
    2264                 :     1181264 :   attr->save = MIO_NAME (save_state) (attr->save, save_status);
    2265                 :             : 
    2266                 :     1181264 :   ext_attr = attr->ext_attr;
    2267                 :     1181264 :   mio_integer ((int *) &ext_attr);
    2268                 :     1181264 :   attr->ext_attr = ext_attr;
    2269                 :             : 
    2270                 :     1181264 :   extension_level = attr->extension;
    2271                 :     1181264 :   mio_integer ((int *) &extension_level);
    2272                 :     1181264 :   attr->extension = extension_level;
    2273                 :             : 
    2274                 :     1181264 :   if (iomode == IO_OUTPUT)
    2275                 :             :     {
    2276                 :      287012 :       if (attr->allocatable)
    2277                 :        3830 :         MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
    2278                 :      287012 :       if (attr->artificial)
    2279                 :       56848 :         MIO_NAME (ab_attribute) (AB_ARTIFICIAL, attr_bits);
    2280                 :      287012 :       if (attr->asynchronous)
    2281                 :           0 :         MIO_NAME (ab_attribute) (AB_ASYNCHRONOUS, attr_bits);
    2282                 :      287012 :       if (attr->dimension)
    2283                 :       15532 :         MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
    2284                 :      287012 :       if (attr->codimension)
    2285                 :          57 :         MIO_NAME (ab_attribute) (AB_CODIMENSION, attr_bits);
    2286                 :      287012 :       if (attr->contiguous)
    2287                 :        2525 :         MIO_NAME (ab_attribute) (AB_CONTIGUOUS, attr_bits);
    2288                 :      287012 :       if (attr->external)
    2289                 :       12455 :         MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
    2290                 :      287012 :       if (attr->intrinsic)
    2291                 :        3965 :         MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits);
    2292                 :      287012 :       if (attr->optional)
    2293                 :        3016 :         MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits);
    2294                 :      287012 :       if (attr->pointer)
    2295                 :       27230 :         MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
    2296                 :      287012 :       if (attr->class_pointer)
    2297                 :         422 :         MIO_NAME (ab_attribute) (AB_CLASS_POINTER, attr_bits);
    2298                 :      287012 :       if (attr->is_protected)
    2299                 :          61 :         MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits);
    2300                 :      287012 :       if (attr->value)
    2301                 :        8242 :         MIO_NAME (ab_attribute) (AB_VALUE, attr_bits);
    2302                 :      287012 :       if (attr->volatile_)
    2303                 :          39 :         MIO_NAME (ab_attribute) (AB_VOLATILE, attr_bits);
    2304                 :      287012 :       if (attr->target)
    2305                 :       16594 :         MIO_NAME (ab_attribute) (AB_TARGET, attr_bits);
    2306                 :      287012 :       if (attr->threadprivate)
    2307                 :          42 :         MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits);
    2308                 :      287012 :       if (attr->dummy)
    2309                 :       66768 :         MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits);
    2310                 :      287012 :       if (attr->result)
    2311                 :        3879 :         MIO_NAME (ab_attribute) (AB_RESULT, attr_bits);
    2312                 :             :       /* We deliberately don't preserve the "entry" flag.  */
    2313                 :             : 
    2314                 :      287012 :       if (attr->data)
    2315                 :          19 :         MIO_NAME (ab_attribute) (AB_DATA, attr_bits);
    2316                 :      287012 :       if (attr->in_namelist)
    2317                 :          76 :         MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits);
    2318                 :      287012 :       if (attr->in_common)
    2319                 :         383 :         MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits);
    2320                 :             : 
    2321                 :      287012 :       if (attr->function)
    2322                 :       28024 :         MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits);
    2323                 :      287012 :       if (attr->subroutine)
    2324                 :       42221 :         MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits);
    2325                 :      287012 :       if (attr->generic)
    2326                 :        7873 :         MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits);
    2327                 :      287012 :       if (attr->abstract)
    2328                 :        2507 :         MIO_NAME (ab_attribute) (AB_ABSTRACT, attr_bits);
    2329                 :             : 
    2330                 :      287012 :       if (attr->sequence)
    2331                 :         125 :         MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits);
    2332                 :      287012 :       if (attr->elemental)
    2333                 :       21629 :         MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
    2334                 :      287012 :       if (attr->pure)
    2335                 :       23967 :         MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
    2336                 :      287012 :       if (attr->implicit_pure)
    2337                 :        3661 :         MIO_NAME (ab_attribute) (AB_IMPLICIT_PURE, attr_bits);
    2338                 :      287012 :       if (attr->unlimited_polymorphic)
    2339                 :         276 :         MIO_NAME (ab_attribute) (AB_UNLIMITED_POLY, attr_bits);
    2340                 :      287012 :       if (attr->recursive)
    2341                 :        1980 :         MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
    2342                 :      287012 :       if (attr->always_explicit)
    2343                 :       31810 :         MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
    2344                 :      287012 :       if (attr->cray_pointer)
    2345                 :          13 :         MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits);
    2346                 :      287012 :       if (attr->cray_pointee)
    2347                 :          13 :         MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits);
    2348                 :      287012 :       if (attr->is_bind_c)
    2349                 :        5624 :         MIO_NAME(ab_attribute) (AB_IS_BIND_C, attr_bits);
    2350                 :      287012 :       if (attr->is_c_interop)
    2351                 :       26380 :         MIO_NAME(ab_attribute) (AB_IS_C_INTEROP, attr_bits);
    2352                 :      287012 :       if (attr->is_iso_c)
    2353                 :       23252 :         MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits);
    2354                 :      287012 :       if (attr->alloc_comp)
    2355                 :        2215 :         MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
    2356                 :      287012 :       if (attr->pointer_comp)
    2357                 :         853 :         MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits);
    2358                 :      287012 :       if (attr->proc_pointer_comp)
    2359                 :         235 :         MIO_NAME (ab_attribute) (AB_PROC_POINTER_COMP, attr_bits);
    2360                 :      287012 :       if (attr->private_comp)
    2361                 :        2931 :         MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
    2362                 :      287012 :       if (attr->coarray_comp)
    2363                 :          26 :         MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits);
    2364                 :      287012 :       if (attr->lock_comp)
    2365                 :           3 :         MIO_NAME (ab_attribute) (AB_LOCK_COMP, attr_bits);
    2366                 :      287012 :       if (attr->event_comp)
    2367                 :           0 :         MIO_NAME (ab_attribute) (AB_EVENT_COMP, attr_bits);
    2368                 :      287012 :       if (attr->zero_comp)
    2369                 :        1904 :         MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
    2370                 :      287012 :       if (attr->is_class)
    2371                 :        3988 :         MIO_NAME (ab_attribute) (AB_IS_CLASS, attr_bits);
    2372                 :      287012 :       if (attr->procedure)
    2373                 :        4798 :         MIO_NAME (ab_attribute) (AB_PROCEDURE, attr_bits);
    2374                 :      287012 :       if (attr->proc_pointer)
    2375                 :       31395 :         MIO_NAME (ab_attribute) (AB_PROC_POINTER, attr_bits);
    2376                 :      287012 :       if (attr->vtype)
    2377                 :        8977 :         MIO_NAME (ab_attribute) (AB_VTYPE, attr_bits);
    2378                 :      287012 :       if (attr->vtab)
    2379                 :        8462 :         MIO_NAME (ab_attribute) (AB_VTAB, attr_bits);
    2380                 :      287012 :       if (attr->omp_declare_target)
    2381                 :         447 :         MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET, attr_bits);
    2382                 :      287012 :       if (attr->array_outer_dependency)
    2383                 :       15234 :         MIO_NAME (ab_attribute) (AB_ARRAY_OUTER_DEPENDENCY, attr_bits);
    2384                 :      287012 :       if (attr->module_procedure)
    2385                 :        1211 :         MIO_NAME (ab_attribute) (AB_MODULE_PROCEDURE, attr_bits);
    2386                 :      287012 :       if (attr->oacc_declare_create)
    2387                 :          39 :         MIO_NAME (ab_attribute) (AB_OACC_DECLARE_CREATE, attr_bits);
    2388                 :      287012 :       if (attr->oacc_declare_copyin)
    2389                 :           3 :         MIO_NAME (ab_attribute) (AB_OACC_DECLARE_COPYIN, attr_bits);
    2390                 :      287012 :       if (attr->oacc_declare_deviceptr)
    2391                 :           1 :         MIO_NAME (ab_attribute) (AB_OACC_DECLARE_DEVICEPTR, attr_bits);
    2392                 :      287012 :       if (attr->oacc_declare_device_resident)
    2393                 :          31 :         MIO_NAME (ab_attribute) (AB_OACC_DECLARE_DEVICE_RESIDENT, attr_bits);
    2394                 :      287012 :       if (attr->oacc_declare_link)
    2395                 :           1 :         MIO_NAME (ab_attribute) (AB_OACC_DECLARE_LINK, attr_bits);
    2396                 :      287012 :       if (attr->omp_declare_target_link)
    2397                 :          18 :         MIO_NAME (ab_attribute) (AB_OMP_DECLARE_TARGET_LINK, attr_bits);
    2398                 :      287012 :       if (attr->pdt_kind)
    2399                 :         136 :         MIO_NAME (ab_attribute) (AB_PDT_KIND, attr_bits);
    2400                 :      287012 :       if (attr->pdt_len)
    2401                 :         205 :         MIO_NAME (ab_attribute) (AB_PDT_LEN, attr_bits);
    2402                 :      287012 :       if (attr->pdt_type)
    2403                 :          62 :         MIO_NAME (ab_attribute) (AB_PDT_TYPE, attr_bits);
    2404                 :      287012 :       if (attr->pdt_template)
    2405                 :          82 :         MIO_NAME (ab_attribute) (AB_PDT_TEMPLATE, attr_bits);
    2406                 :      287012 :       if (attr->pdt_array)
    2407                 :          19 :         MIO_NAME (ab_attribute) (AB_PDT_ARRAY, attr_bits);
    2408                 :      287012 :       if (attr->pdt_string)
    2409                 :           2 :         MIO_NAME (ab_attribute) (AB_PDT_STRING, attr_bits);
    2410                 :      287012 :       switch (attr->oacc_routine_lop)
    2411                 :             :         {
    2412                 :             :         case OACC_ROUTINE_LOP_NONE:
    2413                 :             :           /* This is the default anyway, and for maintaining compatibility with
    2414                 :             :              the current MOD_VERSION, we're not emitting anything in that
    2415                 :             :              case.  */
    2416                 :             :           break;
    2417                 :          12 :         case OACC_ROUTINE_LOP_GANG:
    2418                 :          12 :           MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_GANG, attr_bits);
    2419                 :          12 :           break;
    2420                 :          10 :         case OACC_ROUTINE_LOP_WORKER:
    2421                 :          10 :           MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_WORKER, attr_bits);
    2422                 :          10 :           break;
    2423                 :           8 :         case OACC_ROUTINE_LOP_VECTOR:
    2424                 :           8 :           MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_VECTOR, attr_bits);
    2425                 :           8 :           break;
    2426                 :          79 :         case OACC_ROUTINE_LOP_SEQ:
    2427                 :          79 :           MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_LOP_SEQ, attr_bits);
    2428                 :          79 :           break;
    2429                 :           0 :         case OACC_ROUTINE_LOP_ERROR:
    2430                 :             :           /* ... intentionally omitted here; it's only used internally.  */
    2431                 :           0 :         default:
    2432                 :           0 :           gcc_unreachable ();
    2433                 :             :         }
    2434                 :      287012 :       if (attr->oacc_routine_nohost)
    2435                 :          21 :         MIO_NAME (ab_attribute) (AB_OACC_ROUTINE_NOHOST, attr_bits);
    2436                 :             : 
    2437                 :      287012 :       if (attr->flavor == FL_MODULE && gfc_current_ns->omp_requires)
    2438                 :             :         {
    2439                 :          28 :           if (gfc_current_ns->omp_requires & OMP_REQ_REVERSE_OFFLOAD)
    2440                 :          15 :             MIO_NAME (ab_attribute) (AB_OMP_REQ_REVERSE_OFFLOAD, attr_bits);
    2441                 :          28 :           if (gfc_current_ns->omp_requires & OMP_REQ_UNIFIED_ADDRESS)
    2442                 :           1 :             MIO_NAME (ab_attribute) (AB_OMP_REQ_UNIFIED_ADDRESS, attr_bits);
    2443                 :          28 :           if (gfc_current_ns->omp_requires & OMP_REQ_UNIFIED_SHARED_MEMORY)
    2444                 :           3 :             MIO_NAME (ab_attribute) (AB_OMP_REQ_UNIFIED_SHARED_MEMORY, attr_bits);
    2445                 :          28 :           if (gfc_current_ns->omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS)
    2446                 :           2 :             MIO_NAME (ab_attribute) (AB_OMP_REQ_DYNAMIC_ALLOCATORS, attr_bits);
    2447                 :          28 :           if ((gfc_current_ns->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
    2448                 :             :               == OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST)
    2449                 :           3 :             MIO_NAME (ab_attribute) (AB_OMP_REQ_MEM_ORDER_SEQ_CST, attr_bits);
    2450                 :          28 :           if ((gfc_current_ns->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
    2451                 :             :               == OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL)
    2452                 :           3 :             MIO_NAME (ab_attribute) (AB_OMP_REQ_MEM_ORDER_ACQ_REL, attr_bits);
    2453                 :          28 :           if ((gfc_current_ns->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
    2454                 :             :               == OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE)
    2455                 :           0 :             MIO_NAME (ab_attribute) (AB_OMP_REQ_MEM_ORDER_ACQUIRE, attr_bits);
    2456                 :          28 :           if ((gfc_current_ns->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
    2457                 :             :               == OMP_REQ_ATOMIC_MEM_ORDER_RELAXED)
    2458                 :           3 :             MIO_NAME (ab_attribute) (AB_OMP_REQ_MEM_ORDER_RELAXED, attr_bits);
    2459                 :          28 :           if ((gfc_current_ns->omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
    2460                 :             :               == OMP_REQ_ATOMIC_MEM_ORDER_RELEASE)
    2461                 :           0 :             MIO_NAME (ab_attribute) (AB_OMP_REQ_MEM_ORDER_RELEASE, attr_bits);
    2462                 :             :         }
    2463                 :      287012 :       switch (attr->omp_device_type)
    2464                 :             :         {
    2465                 :             :         case OMP_DEVICE_TYPE_UNSET:
    2466                 :             :           break;
    2467                 :          12 :         case OMP_DEVICE_TYPE_HOST:
    2468                 :          12 :           MIO_NAME (ab_attribute) (AB_OMP_DEVICE_TYPE_HOST, attr_bits);
    2469                 :          12 :           break;
    2470                 :          12 :         case OMP_DEVICE_TYPE_NOHOST:
    2471                 :          12 :           MIO_NAME (ab_attribute) (AB_OMP_DEVICE_TYPE_NOHOST, attr_bits);
    2472                 :          12 :           break;
    2473                 :          12 :         case OMP_DEVICE_TYPE_ANY:
    2474                 :          12 :           MIO_NAME (ab_attribute) (AB_OMP_DEVICE_TYPE_ANY, attr_bits);
    2475                 :          12 :           break;
    2476                 :           0 :         default:
    2477                 :           0 :           gcc_unreachable ();
    2478                 :             :         }
    2479                 :      287012 :       mio_rparen ();
    2480                 :             :     }
    2481                 :             :   else
    2482                 :             :     {
    2483                 :     2625130 :       for (;;)
    2484                 :             :         {
    2485                 :     2625130 :           t = parse_atom ();
    2486                 :     2625130 :           if (t == ATOM_RPAREN)
    2487                 :             :             break;
    2488                 :     1730878 :           if (t != ATOM_NAME)
    2489                 :           0 :             bad_module ("Expected attribute bit name");
    2490                 :             : 
    2491                 :     1730878 :           switch ((ab_attribute) find_enum (attr_bits))
    2492                 :             :             {
    2493                 :        3750 :             case AB_ALLOCATABLE:
    2494                 :        3750 :               attr->allocatable = 1;
    2495                 :        3750 :               break;
    2496                 :       79137 :             case AB_ARTIFICIAL:
    2497                 :       79137 :               attr->artificial = 1;
    2498                 :       79137 :               break;
    2499                 :           0 :             case AB_ASYNCHRONOUS:
    2500                 :           0 :               attr->asynchronous = 1;
    2501                 :           0 :               break;
    2502                 :       51549 :             case AB_DIMENSION:
    2503                 :       51549 :               attr->dimension = 1;
    2504                 :       51549 :               break;
    2505                 :          66 :             case AB_CODIMENSION:
    2506                 :          66 :               attr->codimension = 1;
    2507                 :          66 :               break;
    2508                 :        6514 :             case AB_CONTIGUOUS:
    2509                 :        6514 :               attr->contiguous = 1;
    2510                 :        6514 :               break;
    2511                 :      150919 :             case AB_EXTERNAL:
    2512                 :      150919 :               attr->external = 1;
    2513                 :      150919 :               break;
    2514                 :        2409 :             case AB_INTRINSIC:
    2515                 :        2409 :               attr->intrinsic = 1;
    2516                 :        2409 :               break;
    2517                 :        4932 :             case AB_OPTIONAL:
    2518                 :        4932 :               attr->optional = 1;
    2519                 :        4932 :               break;
    2520                 :       33885 :             case AB_POINTER:
    2521                 :       33885 :               attr->pointer = 1;
    2522                 :       33885 :               break;
    2523                 :         355 :             case AB_CLASS_POINTER:
    2524                 :         355 :               attr->class_pointer = 1;
    2525                 :         355 :               break;
    2526                 :          55 :             case AB_PROTECTED:
    2527                 :          55 :               attr->is_protected = 1;
    2528                 :          55 :               break;
    2529                 :       52941 :             case AB_VALUE:
    2530                 :       52941 :               attr->value = 1;
    2531                 :       52941 :               break;
    2532                 :          45 :             case AB_VOLATILE:
    2533                 :          45 :               attr->volatile_ = 1;
    2534                 :          45 :               break;
    2535                 :       23470 :             case AB_TARGET:
    2536                 :       23470 :               attr->target = 1;
    2537                 :       23470 :               break;
    2538                 :          52 :             case AB_THREADPRIVATE:
    2539                 :          52 :               attr->threadprivate = 1;
    2540                 :          52 :               break;
    2541                 :      331800 :             case AB_DUMMY:
    2542                 :      331800 :               attr->dummy = 1;
    2543                 :      331800 :               break;
    2544                 :       26844 :             case AB_RESULT:
    2545                 :       26844 :               attr->result = 1;
    2546                 :       26844 :               break;
    2547                 :          19 :             case AB_DATA:
    2548                 :          19 :               attr->data = 1;
    2549                 :          19 :               break;
    2550                 :          81 :             case AB_IN_NAMELIST:
    2551                 :          81 :               attr->in_namelist = 1;
    2552                 :          81 :               break;
    2553                 :         301 :             case AB_IN_COMMON:
    2554                 :         301 :               attr->in_common = 1;
    2555                 :         301 :               break;
    2556                 :      149524 :             case AB_FUNCTION:
    2557                 :      149524 :               attr->function = 1;
    2558                 :      149524 :               break;
    2559                 :       95766 :             case AB_SUBROUTINE:
    2560                 :       95766 :               attr->subroutine = 1;
    2561                 :       95766 :               break;
    2562                 :       20411 :             case AB_GENERIC:
    2563                 :       20411 :               attr->generic = 1;
    2564                 :       20411 :               break;
    2565                 :        1922 :             case AB_ABSTRACT:
    2566                 :        1922 :               attr->abstract = 1;
    2567                 :        1922 :               break;
    2568                 :         137 :             case AB_SEQUENCE:
    2569                 :         137 :               attr->sequence = 1;
    2570                 :         137 :               break;
    2571                 :       91776 :             case AB_ELEMENTAL:
    2572                 :       91776 :               attr->elemental = 1;
    2573                 :       91776 :               break;
    2574                 :      113149 :             case AB_PURE:
    2575                 :      113149 :               attr->pure = 1;
    2576                 :      113149 :               break;
    2577                 :        3743 :             case AB_IMPLICIT_PURE:
    2578                 :        3743 :               attr->implicit_pure = 1;
    2579                 :        3743 :               break;
    2580                 :         249 :             case AB_UNLIMITED_POLY:
    2581                 :         249 :               attr->unlimited_polymorphic = 1;
    2582                 :         249 :               break;
    2583                 :        1947 :             case AB_RECURSIVE:
    2584                 :        1947 :               attr->recursive = 1;
    2585                 :        1947 :               break;
    2586                 :      135927 :             case AB_ALWAYS_EXPLICIT:
    2587                 :      135927 :               attr->always_explicit = 1;
    2588                 :      135927 :               break;
    2589                 :          13 :             case AB_CRAY_POINTER:
    2590                 :          13 :               attr->cray_pointer = 1;
    2591                 :          13 :               break;
    2592                 :          13 :             case AB_CRAY_POINTEE:
    2593                 :          13 :               attr->cray_pointee = 1;
    2594                 :          13 :               break;
    2595                 :       29186 :             case AB_IS_BIND_C:
    2596                 :       29186 :               attr->is_bind_c = 1;
    2597                 :       29186 :               break;
    2598                 :       42288 :             case AB_IS_C_INTEROP:
    2599                 :       42288 :               attr->is_c_interop = 1;
    2600                 :       42288 :               break;
    2601                 :       13717 :             case AB_IS_ISO_C:
    2602                 :       13717 :               attr->is_iso_c = 1;
    2603                 :       13717 :               break;
    2604                 :        2105 :             case AB_ALLOC_COMP:
    2605                 :        2105 :               attr->alloc_comp = 1;
    2606                 :        2105 :               break;
    2607                 :          18 :             case AB_COARRAY_COMP:
    2608                 :          18 :               attr->coarray_comp = 1;
    2609                 :          18 :               break;
    2610                 :           4 :             case AB_LOCK_COMP:
    2611                 :           4 :               attr->lock_comp = 1;
    2612                 :           4 :               break;
    2613                 :           0 :             case AB_EVENT_COMP:
    2614                 :           0 :               attr->event_comp = 1;
    2615                 :           0 :               break;
    2616                 :         795 :             case AB_POINTER_COMP:
    2617                 :         795 :               attr->pointer_comp = 1;
    2618                 :         795 :               break;
    2619                 :         220 :             case AB_PROC_POINTER_COMP:
    2620                 :         220 :               attr->proc_pointer_comp = 1;
    2621                 :         220 :               break;
    2622                 :       16049 :             case AB_PRIVATE_COMP:
    2623                 :       16049 :               attr->private_comp = 1;
    2624                 :       16049 :               break;
    2625                 :        1617 :             case AB_ZERO_COMP:
    2626                 :        1617 :               attr->zero_comp = 1;
    2627                 :        1617 :               break;
    2628                 :        3589 :             case AB_IS_CLASS:
    2629                 :        3589 :               attr->is_class = 1;
    2630                 :        3589 :               break;
    2631                 :        4389 :             case AB_PROCEDURE:
    2632                 :        4389 :               attr->procedure = 1;
    2633                 :        4389 :               break;
    2634                 :       42485 :             case AB_PROC_POINTER:
    2635                 :       42485 :               attr->proc_pointer = 1;
    2636                 :       42485 :               break;
    2637                 :       12789 :             case AB_VTYPE:
    2638                 :       12789 :               attr->vtype = 1;
    2639                 :       12789 :               break;
    2640                 :       12493 :             case AB_VTAB:
    2641                 :       12493 :               attr->vtab = 1;
    2642                 :       12493 :               break;
    2643                 :         511 :             case AB_OMP_DECLARE_TARGET:
    2644                 :         511 :               attr->omp_declare_target = 1;
    2645                 :         511 :               break;
    2646                 :           9 :             case AB_OMP_DECLARE_TARGET_LINK:
    2647                 :           9 :               attr->omp_declare_target_link = 1;
    2648                 :           9 :               break;
    2649                 :      163323 :             case AB_ARRAY_OUTER_DEPENDENCY:
    2650                 :      163323 :               attr->array_outer_dependency =1;
    2651                 :      163323 :               break;
    2652                 :         845 :             case AB_MODULE_PROCEDURE:
    2653                 :         845 :               attr->module_procedure =1;
    2654                 :         845 :               break;
    2655                 :         110 :             case AB_OACC_DECLARE_CREATE:
    2656                 :         110 :               attr->oacc_declare_create = 1;
    2657                 :         110 :               break;
    2658                 :           2 :             case AB_OACC_DECLARE_COPYIN:
    2659                 :           2 :               attr->oacc_declare_copyin = 1;
    2660                 :           2 :               break;
    2661                 :           0 :             case AB_OACC_DECLARE_DEVICEPTR:
    2662                 :           0 :               attr->oacc_declare_deviceptr = 1;
    2663                 :           0 :               break;
    2664                 :          32 :             case AB_OACC_DECLARE_DEVICE_RESIDENT:
    2665                 :          32 :               attr->oacc_declare_device_resident = 1;
    2666                 :          32 :               break;
    2667                 :           2 :             case AB_OACC_DECLARE_LINK:
    2668                 :           2 :               attr->oacc_declare_link = 1;
    2669                 :           2 :               break;
    2670                 :         108 :             case AB_PDT_KIND:
    2671                 :         108 :               attr->pdt_kind = 1;
    2672                 :         108 :               break;
    2673                 :         183 :             case AB_PDT_LEN:
    2674                 :         183 :               attr->pdt_len = 1;
    2675                 :         183 :               break;
    2676                 :          50 :             case AB_PDT_TYPE:
    2677                 :          50 :               attr->pdt_type = 1;
    2678                 :          50 :               break;
    2679                 :          71 :             case AB_PDT_TEMPLATE:
    2680                 :          71 :               attr->pdt_template = 1;
    2681                 :          71 :               break;
    2682                 :          19 :             case AB_PDT_ARRAY:
    2683                 :          19 :               attr->pdt_array = 1;
    2684                 :          19 :               break;
    2685                 :           0 :             case AB_PDT_STRING:
    2686                 :           0 :               attr->pdt_string = 1;
    2687                 :           0 :               break;
    2688                 :           8 :             case AB_OACC_ROUTINE_LOP_GANG:
    2689                 :           8 :               verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop);
    2690                 :           8 :               attr->oacc_routine_lop = OACC_ROUTINE_LOP_GANG;
    2691                 :           8 :               break;
    2692                 :           8 :             case AB_OACC_ROUTINE_LOP_WORKER:
    2693                 :           8 :               verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop);
    2694                 :           8 :               attr->oacc_routine_lop = OACC_ROUTINE_LOP_WORKER;
    2695                 :           8 :               break;
    2696                 :           8 :             case AB_OACC_ROUTINE_LOP_VECTOR:
    2697                 :           8 :               verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop);
    2698                 :           8 :               attr->oacc_routine_lop = OACC_ROUTINE_LOP_VECTOR;
    2699                 :           8 :               break;
    2700                 :          70 :             case AB_OACC_ROUTINE_LOP_SEQ:
    2701                 :          70 :               verify_OACC_ROUTINE_LOP_NONE (attr->oacc_routine_lop);
    2702                 :          70 :               attr->oacc_routine_lop = OACC_ROUTINE_LOP_SEQ;
    2703                 :          70 :               break;
    2704                 :          20 :             case AB_OACC_ROUTINE_NOHOST:
    2705                 :          20 :               attr->oacc_routine_nohost = 1;
    2706                 :          20 :               break;
    2707                 :          24 :             case AB_OMP_REQ_REVERSE_OFFLOAD:
    2708                 :          24 :               gfc_omp_requires_add_clause (OMP_REQ_REVERSE_OFFLOAD,
    2709                 :             :                                            "reverse_offload",
    2710                 :             :                                            &gfc_current_locus,
    2711                 :             :                                            module_name);
    2712                 :          24 :               break;
    2713                 :           0 :             case AB_OMP_REQ_UNIFIED_ADDRESS:
    2714                 :           0 :               gfc_omp_requires_add_clause (OMP_REQ_UNIFIED_ADDRESS,
    2715                 :             :                                            "unified_address",
    2716                 :             :                                            &gfc_current_locus,
    2717                 :             :                                            module_name);
    2718                 :           0 :               break;
    2719                 :           0 :             case AB_OMP_REQ_UNIFIED_SHARED_MEMORY:
    2720                 :           0 :               gfc_omp_requires_add_clause (OMP_REQ_UNIFIED_SHARED_MEMORY,
    2721                 :             :                                            "unified_shared_memory",
    2722                 :             :                                            &gfc_current_locus,
    2723                 :             :                                            module_name);
    2724                 :           0 :               break;
    2725                 :           0 :             case AB_OMP_REQ_DYNAMIC_ALLOCATORS:
    2726                 :           0 :               gfc_omp_requires_add_clause (OMP_REQ_DYNAMIC_ALLOCATORS,
    2727                 :             :                                            "dynamic_allocators",
    2728                 :             :                                            &gfc_current_locus,
    2729                 :             :                                            module_name);
    2730                 :           0 :               break;
    2731                 :           2 :             case AB_OMP_REQ_MEM_ORDER_SEQ_CST:
    2732                 :           2 :               gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST,
    2733                 :             :                                            "seq_cst", &gfc_current_locus,
    2734                 :             :                                            module_name);
    2735                 :           2 :               break;
    2736                 :           2 :             case AB_OMP_REQ_MEM_ORDER_ACQ_REL:
    2737                 :           2 :               gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL,
    2738                 :             :                                            "acq_rel", &gfc_current_locus,
    2739                 :             :                                            module_name);
    2740                 :           2 :               break;
    2741                 :           0 :             case AB_OMP_REQ_MEM_ORDER_ACQUIRE:
    2742                 :           0 :               gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_ACQUIRE,
    2743                 :             :                                            "acquires", &gfc_current_locus,
    2744                 :             :                                            module_name);
    2745                 :           0 :               break;
    2746                 :           2 :             case AB_OMP_REQ_MEM_ORDER_RELAXED:
    2747                 :           2 :               gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_RELAXED,
    2748                 :             :                                            "relaxed", &gfc_current_locus,
    2749                 :             :                                            module_name);
    2750                 :           2 :               break;
    2751                 :           0 :             case AB_OMP_REQ_MEM_ORDER_RELEASE:
    2752                 :           0 :               gfc_omp_requires_add_clause (OMP_REQ_ATOMIC_MEM_ORDER_RELEASE,
    2753                 :             :                                            "release", &gfc_current_locus,
    2754                 :             :                                            module_name);
    2755                 :           0 :               break;
    2756                 :           8 :             case AB_OMP_DEVICE_TYPE_HOST:
    2757                 :           8 :               attr->omp_device_type = OMP_DEVICE_TYPE_HOST;
    2758                 :           8 :               break;
    2759                 :           8 :             case AB_OMP_DEVICE_TYPE_NOHOST:
    2760                 :           8 :               attr->omp_device_type = OMP_DEVICE_TYPE_NOHOST;
    2761                 :           8 :               break;
    2762                 :           8 :             case AB_OMP_DEVICE_TYPE_ANY:
    2763                 :           8 :               attr->omp_device_type = OMP_DEVICE_TYPE_ANY;
    2764                 :           8 :               break;
    2765                 :             :             }
    2766                 :             :         }
    2767                 :             :     }
    2768                 :     1181264 : }
    2769                 :             : 
    2770                 :             : 
    2771                 :             : static const mstring bt_types[] = {
    2772                 :             :     minit ("INTEGER", BT_INTEGER),
    2773                 :             :     minit ("REAL", BT_REAL),
    2774                 :             :     minit ("COMPLEX", BT_COMPLEX),
    2775                 :             :     minit ("LOGICAL", BT_LOGICAL),
    2776                 :             :     minit ("CHARACTER", BT_CHARACTER),
    2777                 :             :     minit ("UNION", BT_UNION),
    2778                 :             :     minit ("DERIVED", BT_DERIVED),
    2779                 :             :     minit ("CLASS", BT_CLASS),
    2780                 :             :     minit ("PROCEDURE", BT_PROCEDURE),
    2781                 :             :     minit ("UNKNOWN", BT_UNKNOWN),
    2782                 :             :     minit ("VOID", BT_VOID),
    2783                 :             :     minit ("ASSUMED", BT_ASSUMED),
    2784                 :             :     minit (NULL, -1)
    2785                 :             : };
    2786                 :             : 
    2787                 :             : 
    2788                 :             : static void
    2789                 :       29923 : mio_charlen (gfc_charlen **clp)
    2790                 :             : {
    2791                 :       29923 :   gfc_charlen *cl;
    2792                 :             : 
    2793                 :       29923 :   mio_lparen ();
    2794                 :             : 
    2795                 :       29923 :   if (iomode == IO_OUTPUT)
    2796                 :             :     {
    2797                 :       15919 :       cl = *clp;
    2798                 :       15919 :       if (cl != NULL)
    2799                 :       15769 :         mio_expr (&cl->length);
    2800                 :             :     }
    2801                 :             :   else
    2802                 :             :     {
    2803                 :       14004 :       if (peek_atom () != ATOM_RPAREN)
    2804                 :             :         {
    2805                 :       13854 :           cl = gfc_new_charlen (gfc_current_ns, NULL);
    2806                 :       13854 :           mio_expr (&cl->length);
    2807                 :       13854 :           *clp = cl;
    2808                 :             :         }
    2809                 :             :     }
    2810                 :             : 
    2811                 :       29923 :   mio_rparen ();
    2812                 :       29923 : }
    2813                 :             : 
    2814                 :             : 
    2815                 :             : /* See if a name is a generated name.  */
    2816                 :             : 
    2817                 :             : static int
    2818                 :      554662 : check_unique_name (const char *name)
    2819                 :             : {
    2820                 :      554662 :   return *name == '@';
    2821                 :             : }
    2822                 :             : 
    2823                 :             : 
    2824                 :             : static void
    2825                 :     1469019 : mio_typespec (gfc_typespec *ts)
    2826                 :             : {
    2827                 :     1469019 :   mio_lparen ();
    2828                 :             : 
    2829                 :     1469019 :   ts->type = MIO_NAME (bt) (ts->type, bt_types);
    2830                 :             : 
    2831                 :     1469019 :   if (!gfc_bt_struct (ts->type) && ts->type != BT_CLASS)
    2832                 :     1216515 :     mio_integer (&ts->kind);
    2833                 :             :   else
    2834                 :      252504 :     mio_symbol_ref (&ts->u.derived);
    2835                 :             : 
    2836                 :     1469019 :   mio_symbol_ref (&ts->interface);
    2837                 :             : 
    2838                 :             :   /* Add info for C interop and is_iso_c.  */
    2839                 :     1469019 :   mio_integer (&ts->is_c_interop);
    2840                 :     1469019 :   mio_integer (&ts->is_iso_c);
    2841                 :             : 
    2842                 :             :   /* If the typespec is for an identifier either from iso_c_binding, or
    2843                 :             :      a constant that was initialized to an identifier from it, use the
    2844                 :             :      f90_type.  Otherwise, use the ts->type, since it shouldn't matter.  */
    2845                 :     1469019 :   if (ts->is_iso_c)
    2846                 :       86267 :     ts->f90_type = MIO_NAME (bt) (ts->f90_type, bt_types);
    2847                 :             :   else
    2848                 :     1382752 :     ts->f90_type = MIO_NAME (bt) (ts->type, bt_types);
    2849                 :             : 
    2850                 :     1469019 :   if (ts->type != BT_CHARACTER)
    2851                 :             :     {
    2852                 :             :       /* ts->u.cl is only valid for BT_CHARACTER.  */
    2853                 :     1439102 :       mio_lparen ();
    2854                 :     1439102 :       mio_rparen ();
    2855                 :             :     }
    2856                 :             :   else
    2857                 :       29917 :     mio_charlen (&ts->u.cl);
    2858                 :             : 
    2859                 :             :   /* So as not to disturb the existing API, use an ATOM_NAME to
    2860                 :             :      transmit deferred characteristic for characters (F2003).  */
    2861                 :     1469019 :   if (iomode == IO_OUTPUT)
    2862                 :             :     {
    2863                 :      372738 :       if (ts->type == BT_CHARACTER && ts->deferred)
    2864                 :         424 :         write_atom (ATOM_NAME, "DEFERRED_CL");
    2865                 :             :     }
    2866                 :     1096281 :   else if (peek_atom () != ATOM_RPAREN)
    2867                 :             :     {
    2868                 :         398 :       if (parse_atom () != ATOM_NAME)
    2869                 :           0 :         bad_module ("Expected string");
    2870                 :         398 :       ts->deferred = 1;
    2871                 :             :     }
    2872                 :             : 
    2873                 :     1469019 :   mio_rparen ();
    2874                 :     1469019 : }
    2875                 :             : 
    2876                 :             : 
    2877                 :             : static const mstring array_spec_types[] = {
    2878                 :             :     minit ("EXPLICIT", AS_EXPLICIT),
    2879                 :             :     minit ("ASSUMED_RANK", AS_ASSUMED_RANK),
    2880                 :             :     minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
    2881                 :             :     minit ("DEFERRED", AS_DEFERRED),
    2882                 :             :     minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
    2883                 :             :     minit (NULL, -1)
    2884                 :             : };
    2885                 :             : 
    2886                 :             : 
    2887                 :             : static void
    2888                 :     1181244 : mio_array_spec (gfc_array_spec **asp)
    2889                 :             : {
    2890                 :     1181244 :   gfc_array_spec *as;
    2891                 :     1181244 :   int i;
    2892                 :             : 
    2893                 :     1181244 :   mio_lparen ();
    2894                 :             : 
    2895                 :     1181244 :   if (iomode == IO_OUTPUT)
    2896                 :             :     {
    2897                 :      287012 :       int rank;
    2898                 :             : 
    2899                 :      287012 :       if (*asp == NULL)
    2900                 :      271433 :         goto done;
    2901                 :       15579 :       as = *asp;
    2902                 :             : 
    2903                 :             :       /* mio_integer expects nonnegative values.  */
    2904                 :       15579 :       rank = as->rank > 0 ? as->rank : 0;
    2905                 :       15579 :       mio_integer (&rank);
    2906                 :             :     }
    2907                 :             :   else
    2908                 :             :     {
    2909                 :      894232 :       if (peek_atom () == ATOM_RPAREN)
    2910                 :             :         {
    2911                 :      842622 :           *asp = NULL;
    2912                 :      842622 :           goto done;
    2913                 :             :         }
    2914                 :             : 
    2915                 :       51610 :       *asp = as = gfc_get_array_spec ();
    2916                 :       51610 :       mio_integer (&as->rank);
    2917                 :             :     }
    2918                 :             : 
    2919                 :       67189 :   mio_integer (&as->corank);
    2920                 :       67189 :   as->type = MIO_NAME (array_type) (as->type, array_spec_types);
    2921                 :             : 
    2922                 :       67189 :   if (iomode == IO_INPUT && as->type == AS_ASSUMED_RANK)
    2923                 :       18889 :     as->rank = -1;
    2924                 :       67189 :   if (iomode == IO_INPUT && as->corank)
    2925                 :         111 :     as->cotype = (as->type == AS_DEFERRED) ? AS_DEFERRED : AS_EXPLICIT;
    2926                 :             : 
    2927                 :       67189 :   if (as->rank + as->corank > 0)
    2928                 :       94487 :     for (i = 0; i < as->rank + as->corank; i++)
    2929                 :             :       {
    2930                 :       49525 :         mio_expr (&as->lower[i]);
    2931                 :       49525 :         mio_expr (&as->upper[i]);
    2932                 :             :       }
    2933                 :             : 
    2934                 :       22227 : done:
    2935                 :     1181244 :   mio_rparen ();
    2936                 :     1181244 : }
    2937                 :             : 
    2938                 :             : 
    2939                 :             : /* Given a pointer to an array reference structure (which lives in a
    2940                 :             :    gfc_ref structure), find the corresponding array specification
    2941                 :             :    structure.  Storing the pointer in the ref structure doesn't quite
    2942                 :             :    work when loading from a module. Generating code for an array
    2943                 :             :    reference also needs more information than just the array spec.  */
    2944                 :             : 
    2945                 :             : static const mstring array_ref_types[] = {
    2946                 :             :     minit ("FULL", AR_FULL),
    2947                 :             :     minit ("ELEMENT", AR_ELEMENT),
    2948                 :             :     minit ("SECTION", AR_SECTION),
    2949                 :             :     minit (NULL, -1)
    2950                 :             : };
    2951                 :             : 
    2952                 :             : 
    2953                 :             : static void
    2954                 :        1693 : mio_array_ref (gfc_array_ref *ar)
    2955                 :             : {
    2956                 :        1693 :   int i;
    2957                 :             : 
    2958                 :        1693 :   mio_lparen ();
    2959                 :        1693 :   ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types);
    2960                 :        1693 :   mio_integer (&ar->dimen);
    2961                 :             : 
    2962                 :        1693 :   switch (ar->type)
    2963                 :             :     {
    2964                 :             :     case AR_FULL:
    2965                 :             :       break;
    2966                 :             : 
    2967                 :             :     case AR_ELEMENT:
    2968                 :         812 :       for (i = 0; i < ar->dimen; i++)
    2969                 :         408 :         mio_expr (&ar->start[i]);
    2970                 :             : 
    2971                 :             :       break;
    2972                 :             : 
    2973                 :             :     case AR_SECTION:
    2974                 :           0 :       for (i = 0; i < ar->dimen; i++)
    2975                 :             :         {
    2976                 :           0 :           mio_expr (&ar->start[i]);
    2977                 :           0 :           mio_expr (&ar->end[i]);
    2978                 :           0 :           mio_expr (&ar->stride[i]);
    2979                 :             :         }
    2980                 :             : 
    2981                 :             :       break;
    2982                 :             : 
    2983                 :           0 :     case AR_UNKNOWN:
    2984                 :           0 :       gfc_internal_error ("mio_array_ref(): Unknown array ref");
    2985                 :             :     }
    2986                 :             : 
    2987                 :             :   /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
    2988                 :             :      we can't call mio_integer directly.  Instead loop over each element
    2989                 :             :      and cast it to/from an integer.  */
    2990                 :        1693 :   if (iomode == IO_OUTPUT)
    2991                 :             :     {
    2992                 :        1902 :       for (i = 0; i < ar->dimen; i++)
    2993                 :             :         {
    2994                 :        1062 :           HOST_WIDE_INT tmp = (HOST_WIDE_INT)ar->dimen_type[i];
    2995                 :        1062 :           write_atom (ATOM_INTEGER, &tmp);
    2996                 :             :         }
    2997                 :             :     }
    2998                 :             :   else
    2999                 :             :     {
    3000                 :        1960 :       for (i = 0; i < ar->dimen; i++)
    3001                 :             :         {
    3002                 :        1107 :           require_atom (ATOM_INTEGER);
    3003                 :        1107 :           ar->dimen_type[i] = (enum gfc_array_ref_dimen_type) atom_int;
    3004                 :             :         }
    3005                 :             :     }
    3006                 :             : 
    3007                 :        1693 :   if (iomode == IO_INPUT)
    3008                 :             :     {
    3009                 :         853 :       ar->where = gfc_current_locus;
    3010                 :             : 
    3011                 :        1960 :       for (i = 0; i < ar->dimen; i++)
    3012                 :        1107 :         ar->c_where[i] = gfc_current_locus;
    3013                 :             :     }
    3014                 :             : 
    3015                 :        1693 :   mio_rparen ();
    3016                 :        1693 : }
    3017                 :             : 
    3018                 :             : 
    3019                 :             : /* Saves or restores a pointer.  The pointer is converted back and
    3020                 :             :    forth from an integer.  We return the pointer_info pointer so that
    3021                 :             :    the caller can take additional action based on the pointer type.  */
    3022                 :             : 
    3023                 :             : static pointer_info *
    3024                 :     5374258 : mio_pointer_ref (void *gp)
    3025                 :             : {
    3026                 :     5374258 :   pointer_info *p;
    3027                 :             : 
    3028                 :     5374258 :   if (iomode == IO_OUTPUT)
    3029                 :             :     {
    3030                 :     1350494 :       p = get_pointer (*((char **) gp));
    3031                 :     1350494 :       HOST_WIDE_INT hwi = p->integer;
    3032                 :     1350494 :       write_atom (ATOM_INTEGER, &hwi);
    3033                 :             :     }
    3034                 :             :   else
    3035                 :             :     {
    3036                 :     4023764 :       require_atom (ATOM_INTEGER);
    3037                 :     4023764 :       p = add_fixup (atom_int, gp);
    3038                 :             :     }
    3039                 :             : 
    3040                 :     5374258 :   return p;
    3041                 :             : }
    3042                 :             : 
    3043                 :             : 
    3044                 :             : /* Save and load references to components that occur within
    3045                 :             :    expressions.  We have to describe these references by a number and
    3046                 :             :    by name.  The number is necessary for forward references during
    3047                 :             :    reading, and the name is necessary if the symbol already exists in
    3048                 :             :    the namespace and is not loaded again.  */
    3049                 :             : 
    3050                 :             : static void
    3051                 :         364 : mio_component_ref (gfc_component **cp)
    3052                 :             : {
    3053                 :         364 :   pointer_info *p;
    3054                 :             : 
    3055                 :         364 :   p = mio_pointer_ref (cp);
    3056                 :         364 :   if (p->type == P_UNKNOWN)
    3057                 :          57 :     p->type = P_COMPONENT;
    3058                 :         364 : }
    3059                 :             : 
    3060                 :             : 
    3061                 :             : static void mio_namespace_ref (gfc_namespace **nsp);
    3062                 :             : static void mio_formal_arglist (gfc_formal_arglist **formal);
    3063                 :             : static void mio_typebound_proc (gfc_typebound_proc** proc);
    3064                 :             : static void mio_actual_arglist (gfc_actual_arglist **ap, bool pdt);
    3065                 :             : 
    3066                 :             : static void
    3067                 :      219734 : mio_component (gfc_component *c, int vtype)
    3068                 :             : {
    3069                 :      219734 :   pointer_info *p;
    3070                 :             : 
    3071                 :      219734 :   mio_lparen ();
    3072                 :             : 
    3073                 :      219734 :   if (iomode == IO_OUTPUT)
    3074                 :             :     {
    3075                 :       87470 :       p = get_pointer (c);
    3076                 :       87470 :       mio_hwi (&p->integer);
    3077                 :             :     }
    3078                 :             :   else
    3079                 :             :     {
    3080                 :      132264 :       HOST_WIDE_INT n;
    3081                 :      132264 :       mio_hwi (&n);
    3082                 :      132264 :       p = get_integer (n);
    3083                 :      132264 :       associate_integer_pointer (p, c);
    3084                 :             :     }
    3085                 :             : 
    3086                 :      219734 :   if (p->type == P_UNKNOWN)
    3087                 :      219704 :     p->type = P_COMPONENT;
    3088                 :             : 
    3089                 :      219734 :   mio_pool_string (&c->name);
    3090                 :      219734 :   mio_typespec (&c->ts);
    3091                 :      219734 :   mio_array_spec (&c->as);
    3092                 :             : 
    3093                 :             :   /* PDT templates store the expression for the kind of a component here.  */
    3094                 :      219734 :   mio_expr (&c->kind_expr);
    3095                 :             : 
    3096                 :             :   /* PDT types store the component specification list here. */
    3097                 :      219734 :   mio_actual_arglist (&c->param_list, true);
    3098                 :             : 
    3099                 :      219734 :   mio_symbol_attribute (&c->attr);
    3100                 :      219734 :   if (c->ts.type == BT_CLASS)
    3101                 :        1935 :     c->attr.class_ok = 1;
    3102                 :      219734 :   c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types);
    3103                 :             : 
    3104                 :      219734 :   if (!vtype || strcmp (c->name, "_final") == 0
    3105                 :      138453 :       || strcmp (c->name, "_hash") == 0)
    3106                 :      103047 :     mio_expr (&c->initializer);
    3107                 :             : 
    3108                 :      219734 :   if (c->attr.proc_pointer)
    3109                 :       73563 :     mio_typebound_proc (&c->tb);
    3110                 :             : 
    3111                 :      219734 :   c->loc = gfc_current_locus;
    3112                 :             : 
    3113                 :      219734 :   mio_rparen ();
    3114                 :      219734 : }
    3115                 :             : 
    3116                 :             : 
    3117                 :             : static void
    3118                 :      961510 : mio_component_list (gfc_component **cp, int vtype)
    3119                 :             : {
    3120                 :      961510 :   gfc_component *c, *tail;
    3121                 :             : 
    3122                 :      961510 :   mio_lparen ();
    3123                 :             : 
    3124                 :      961510 :   if (iomode == IO_OUTPUT)
    3125                 :             :     {
    3126                 :      287012 :       for (c = *cp; c; c = c->next)
    3127                 :       87470 :         mio_component (c, vtype);
    3128                 :             :     }
    3129                 :             :   else
    3130                 :             :     {
    3131                 :      761968 :       *cp = NULL;
    3132                 :      761968 :       tail = NULL;
    3133                 :             : 
    3134                 :      894232 :       for (;;)
    3135                 :             :         {
    3136                 :      894232 :           if (peek_atom () == ATOM_RPAREN)
    3137                 :             :             break;
    3138                 :             : 
    3139                 :      132264 :           c = gfc_get_component ();
    3140                 :      132264 :           mio_component (c, vtype);
    3141                 :             : 
    3142                 :      132264 :           if (tail == NULL)
    3143                 :       40518 :             *cp = c;
    3144                 :             :           else
    3145                 :       91746 :             tail->next = c;
    3146                 :             : 
    3147                 :             :           tail = c;
    3148                 :             :         }
    3149                 :             :     }
    3150                 :             : 
    3151                 :      961510 :   mio_rparen ();
    3152                 :      961510 : }
    3153                 :             : 
    3154                 :             : 
    3155                 :             : static void
    3156                 :        5847 : mio_actual_arg (gfc_actual_arglist *a, bool pdt)
    3157                 :             : {
    3158                 :        5847 :   mio_lparen ();
    3159                 :        5847 :   mio_pool_string (&a->name);
    3160                 :        5847 :   mio_expr (&a->expr);
    3161                 :        5847 :   if (pdt)
    3162                 :         432 :     mio_integer ((int *)&a->spec_type);
    3163                 :        5847 :   mio_rparen ();
    3164                 :        5847 : }
    3165                 :             : 
    3166                 :             : 
    3167                 :             : static void
    3168                 :     1471129 : mio_actual_arglist (gfc_actual_arglist **ap, bool pdt)
    3169                 :             : {
    3170                 :     1471129 :   gfc_actual_arglist *a, *tail;
    3171                 :             : 
    3172                 :     1471129 :   mio_lparen ();
    3173                 :             : 
    3174                 :     1471129 :   if (iomode == IO_OUTPUT)
    3175                 :             :     {
    3176                 :      376765 :       for (a = *ap; a; a = a->next)
    3177                 :        2957 :         mio_actual_arg (a, pdt);
    3178                 :             : 
    3179                 :             :     }
    3180                 :             :   else
    3181                 :             :     {
    3182                 :             :       tail = NULL;
    3183                 :             : 
    3184                 :     1103101 :       for (;;)
    3185                 :             :         {
    3186                 :     1100211 :           if (peek_atom () != ATOM_LPAREN)
    3187                 :             :             break;
    3188                 :             : 
    3189                 :        2890 :           a = gfc_get_actual_arglist ();
    3190                 :             : 
    3191                 :        2890 :           if (tail == NULL)
    3192                 :        1237 :             *ap = a;
    3193                 :             :           else
    3194                 :        1653 :             tail->next = a;
    3195                 :             : 
    3196                 :        2890 :           tail = a;
    3197                 :        2890 :           mio_actual_arg (a, pdt);
    3198                 :             :         }
    3199                 :             :     }
    3200                 :             : 
    3201                 :     1471129 :   mio_rparen ();
    3202                 :     1471129 : }
    3203                 :             : 
    3204                 :             : 
    3205                 :             : /* Read and write formal argument lists.  */
    3206                 :             : 
    3207                 :             : static void
    3208                 :      961510 : mio_formal_arglist (gfc_formal_arglist **formal)
    3209                 :             : {
    3210                 :      961510 :   gfc_formal_arglist *f, *tail;
    3211                 :             : 
    3212                 :      961510 :   mio_lparen ();
    3213                 :             : 
    3214                 :      961510 :   if (iomode == IO_OUTPUT)
    3215                 :             :     {
    3216                 :      266521 :       for (f = *formal; f; f = f->next)
    3217                 :       66979 :         mio_symbol_ref (&f->sym);
    3218                 :             :     }
    3219                 :             :   else
    3220                 :             :     {
    3221                 :      761968 :       *formal = tail = NULL;
    3222                 :             : 
    3223                 :     1093884 :       while (peek_atom () != ATOM_RPAREN)
    3224                 :             :         {
    3225                 :      331916 :           f = gfc_get_formal_arglist ();
    3226                 :      331916 :           mio_symbol_ref (&f->sym);
    3227                 :             : 
    3228                 :      331916 :           if (*formal == NULL)
    3229                 :      177598 :             *formal = f;
    3230                 :             :           else
    3231                 :      154318 :             tail->next = f;
    3232                 :             : 
    3233                 :             :           tail = f;
    3234                 :             :         }
    3235                 :             :     }
    3236                 :             : 
    3237                 :      961510 :   mio_rparen ();
    3238                 :      961510 : }
    3239                 :             : 
    3240                 :             : 
    3241                 :             : /* Save or restore a reference to a symbol node.  */
    3242                 :             : 
    3243                 :             : pointer_info *
    3244                 :     4212842 : mio_symbol_ref (gfc_symbol **symp)
    3245                 :             : {
    3246                 :     4212842 :   pointer_info *p;
    3247                 :             : 
    3248                 :     4212842 :   p = mio_pointer_ref (symp);
    3249                 :     4212842 :   if (p->type == P_UNKNOWN)
    3250                 :      113441 :     p->type = P_SYMBOL;
    3251                 :             : 
    3252                 :     4212842 :   if (iomode == IO_OUTPUT)
    3253                 :             :     {
    3254                 :      951179 :       if (p->u.wsym.state == UNREFERENCED)
    3255                 :      127867 :         p->u.wsym.state = NEEDS_WRITE;
    3256                 :             :     }
    3257                 :             :   else
    3258                 :             :     {
    3259                 :     3261663 :       if (p->u.rsym.state == UNUSED)
    3260                 :      503652 :         p->u.rsym.state = NEEDED;
    3261                 :             :     }
    3262                 :     4212842 :   return p;
    3263                 :             : }
    3264                 :             : 
    3265                 :             : 
    3266                 :             : /* Save or restore a reference to a symtree node.  */
    3267                 :             : 
    3268                 :             : static void
    3269                 :       22882 : mio_symtree_ref (gfc_symtree **stp)
    3270                 :             : {
    3271                 :       22882 :   pointer_info *p;
    3272                 :       22882 :   fixup_t *f;
    3273                 :             : 
    3274                 :       22882 :   if (iomode == IO_OUTPUT)
    3275                 :       11907 :     mio_symbol_ref (&(*stp)->n.sym);
    3276                 :             :   else
    3277                 :             :     {
    3278                 :       10975 :       require_atom (ATOM_INTEGER);
    3279                 :       10975 :       p = get_integer (atom_int);
    3280                 :             : 
    3281                 :             :       /* An unused equivalence member; make a symbol and a symtree
    3282                 :             :          for it.  */
    3283                 :       10975 :       if (in_load_equiv && p->u.rsym.symtree == NULL)
    3284                 :             :         {
    3285                 :             :           /* Since this is not used, it must have a unique name.  */
    3286                 :          87 :           p->u.rsym.symtree = gfc_get_unique_symtree (gfc_current_ns);
    3287                 :             : 
    3288                 :             :           /* Make the symbol.  */
    3289                 :          87 :           if (p->u.rsym.sym == NULL)
    3290                 :             :             {
    3291                 :          75 :               p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name,
    3292                 :             :                                               gfc_current_ns);
    3293                 :          75 :               p->u.rsym.sym->module = gfc_get_string ("%s", p->u.rsym.module);
    3294                 :             :             }
    3295                 :             : 
    3296                 :          87 :           p->u.rsym.symtree->n.sym = p->u.rsym.sym;
    3297                 :          87 :           p->u.rsym.symtree->n.sym->refs++;
    3298                 :          87 :           p->u.rsym.referenced = 1;
    3299                 :             : 
    3300                 :             :           /* If the symbol is PRIVATE and in COMMON, load_commons will
    3301                 :             :              generate a fixup symbol, which must be associated.  */
    3302                 :          87 :           if (p->fixup)
    3303                 :           2 :             resolve_fixups (p->fixup, p->u.rsym.sym);
    3304                 :          87 :           p->fixup = NULL;
    3305                 :             :         }
    3306                 :             : 
    3307                 :       10975 :       if (p->type == P_UNKNOWN)
    3308                 :           0 :         p->type = P_SYMBOL;
    3309                 :             : 
    3310                 :       10975 :       if (p->u.rsym.state == UNUSED)
    3311                 :        2124 :         p->u.rsym.state = NEEDED;
    3312                 :             : 
    3313                 :       10975 :       if (p->u.rsym.symtree != NULL)
    3314                 :             :         {
    3315                 :        3000 :           *stp = p->u.rsym.symtree;
    3316                 :             :         }
    3317                 :             :       else
    3318                 :             :         {
    3319                 :        7975 :           f = XCNEW (fixup_t);
    3320                 :             : 
    3321                 :        7975 :           f->next = p->u.rsym.stfixup;
    3322                 :        7975 :           p->u.rsym.stfixup = f;
    3323                 :             : 
    3324                 :        7975 :           f->pointer = (void **) stp;
    3325                 :             :         }
    3326                 :             :     }
    3327                 :       22882 : }
    3328                 :             : 
    3329                 :             : 
    3330                 :             : static void
    3331                 :       30108 : mio_iterator (gfc_iterator **ip)
    3332                 :             : {
    3333                 :       30108 :   gfc_iterator *iter;
    3334                 :             : 
    3335                 :       30108 :   mio_lparen ();
    3336                 :             : 
    3337                 :       30108 :   if (iomode == IO_OUTPUT)
    3338                 :             :     {
    3339                 :        8456 :       if (*ip == NULL)
    3340                 :        8450 :         goto done;
    3341                 :             :     }
    3342                 :             :   else
    3343                 :             :     {
    3344                 :       21652 :       if (peek_atom () == ATOM_RPAREN)
    3345                 :             :         {
    3346                 :       21646 :           *ip = NULL;
    3347                 :       21646 :           goto done;
    3348                 :             :         }
    3349                 :             : 
    3350                 :           6 :       *ip = gfc_get_iterator ();
    3351                 :             :     }
    3352                 :             : 
    3353                 :          12 :   iter = *ip;
    3354                 :             : 
    3355                 :          12 :   mio_expr (&iter->var);
    3356                 :          12 :   mio_expr (&iter->start);
    3357                 :          12 :   mio_expr (&iter->end);
    3358                 :          12 :   mio_expr (&iter->step);
    3359                 :             : 
    3360                 :       30108 : done:
    3361                 :       30108 :   mio_rparen ();
    3362                 :       30108 : }
    3363                 :             : 
    3364                 :             : 
    3365                 :             : static void
    3366                 :       18037 : mio_constructor (gfc_constructor_base *cp)
    3367                 :             : {
    3368                 :       18037 :   gfc_constructor *c;
    3369                 :             : 
    3370                 :       18037 :   mio_lparen ();
    3371                 :             : 
    3372                 :       18037 :   if (iomode == IO_OUTPUT)
    3373                 :             :     {
    3374                 :       11863 :       for (c = gfc_constructor_first (*cp); c; c = gfc_constructor_next (c))
    3375                 :             :         {
    3376                 :        8456 :           mio_lparen ();
    3377                 :        8456 :           mio_expr (&c->expr);
    3378                 :        8456 :           mio_iterator (&c->iterator);
    3379                 :        8456 :           mio_rparen ();
    3380                 :             :         }
    3381                 :             :     }
    3382                 :             :   else
    3383                 :             :     {
    3384                 :       36282 :       while (peek_atom () != ATOM_RPAREN)
    3385                 :             :         {
    3386                 :       21652 :           c = gfc_constructor_append_expr (cp, NULL, NULL);
    3387                 :             : 
    3388                 :       21652 :           mio_lparen ();
    3389                 :       21652 :           mio_expr (&c->expr);
    3390                 :       21652 :           mio_iterator (&c->iterator);
    3391                 :       21652 :           mio_rparen ();
    3392                 :             :         }
    3393                 :             :     }
    3394                 :             : 
    3395                 :       18037 :   mio_rparen ();
    3396                 :       18037 : }
    3397                 :             : 
    3398                 :             : 
    3399                 :             : static const mstring ref_types[] = {
    3400                 :             :     minit ("ARRAY", REF_ARRAY),
    3401                 :             :     minit ("COMPONENT", REF_COMPONENT),
    3402                 :             :     minit ("SUBSTRING", REF_SUBSTRING),
    3403                 :             :     minit ("INQUIRY", REF_INQUIRY),
    3404                 :             :     minit (NULL, -1)
    3405                 :             : };
    3406                 :             : 
    3407                 :             : static const mstring inquiry_types[] = {
    3408                 :             :     minit ("RE", INQUIRY_RE),
    3409                 :             :     minit ("IM", INQUIRY_IM),
    3410                 :             :     minit ("KIND", INQUIRY_KIND),
    3411                 :             :     minit ("LEN", INQUIRY_LEN),
    3412                 :             :     minit (NULL, -1)
    3413                 :             : };
    3414                 :             : 
    3415                 :             : 
    3416                 :             : static void
    3417                 :        2063 : mio_ref (gfc_ref **rp)
    3418                 :             : {
    3419                 :        2063 :   gfc_ref *r;
    3420                 :             : 
    3421                 :        2063 :   mio_lparen ();
    3422                 :             : 
    3423                 :        2063 :   r = *rp;
    3424                 :        2063 :   r->type = MIO_NAME (ref_type) (r->type, ref_types);
    3425                 :             : 
    3426                 :        2063 :   switch (r->type)
    3427                 :             :     {
    3428                 :        1693 :     case REF_ARRAY:
    3429                 :        1693 :       mio_array_ref (&r->u.ar);
    3430                 :        1693 :       break;
    3431                 :             : 
    3432                 :         364 :     case REF_COMPONENT:
    3433                 :         364 :       mio_symbol_ref (&r->u.c.sym);
    3434                 :         364 :       mio_component_ref (&r->u.c.component);
    3435                 :         364 :       break;
    3436                 :             : 
    3437                 :           6 :     case REF_SUBSTRING:
    3438                 :           6 :       mio_expr (&r->u.ss.start);
    3439                 :           6 :       mio_expr (&r->u.ss.end);
    3440                 :           6 :       mio_charlen (&r->u.ss.length);
    3441                 :           6 :       break;
    3442                 :             : 
    3443                 :           0 :     case REF_INQUIRY:
    3444                 :           0 :       r->u.i = MIO_NAME (inquiry_type) (r->u.i, inquiry_types);
    3445                 :           0 :       break;
    3446                 :             :     }
    3447                 :             : 
    3448                 :        2063 :   mio_rparen ();
    3449                 :        2063 : }
    3450                 :             : 
    3451                 :             : 
    3452                 :             : static void
    3453                 :       11724 : mio_ref_list (gfc_ref **rp)
    3454                 :             : {
    3455                 :       11724 :   gfc_ref *ref, *head, *tail;
    3456                 :             : 
    3457                 :       11724 :   mio_lparen ();
    3458                 :             : 
    3459                 :       11724 :   if (iomode == IO_OUTPUT)
    3460                 :             :     {
    3461                 :        7196 :       for (ref = *rp; ref; ref = ref->next)
    3462                 :        1075 :         mio_ref (&ref);
    3463                 :             :     }
    3464                 :             :   else
    3465                 :             :     {
    3466                 :        5603 :       head = tail = NULL;
    3467                 :             : 
    3468                 :        6591 :       while (peek_atom () != ATOM_RPAREN)
    3469                 :             :         {
    3470                 :         988 :           if (head == NULL)
    3471                 :         923 :             head = tail = gfc_get_ref ();
    3472                 :             :           else
    3473                 :             :             {
    3474                 :          65 :               tail->next = gfc_get_ref ();
    3475                 :          65 :               tail = tail->next;
    3476                 :             :             }
    3477                 :             : 
    3478                 :         988 :           mio_ref (&tail);
    3479                 :             :         }
    3480                 :             : 
    3481                 :        5603 :       *rp = head;
    3482                 :             :     }
    3483                 :             : 
    3484                 :       11724 :   mio_rparen ();
    3485                 :       11724 : }
    3486                 :             : 
    3487                 :             : 
    3488                 :             : /* Read and write an integer value.  */
    3489                 :             : 
    3490                 :             : static void
    3491                 :      226804 : mio_gmp_integer (mpz_t *integer)
    3492                 :             : {
    3493                 :      226804 :   char *p;
    3494                 :             : 
    3495                 :      226804 :   if (iomode == IO_INPUT)
    3496                 :             :     {
    3497                 :      165986 :       if (parse_atom () != ATOM_STRING)
    3498                 :           0 :         bad_module ("Expected integer string");
    3499                 :             : 
    3500                 :      165986 :       mpz_init (*integer);
    3501                 :      165986 :       if (mpz_set_str (*integer, atom_string, 10))
    3502                 :           0 :         bad_module ("Error converting integer");
    3503                 :             : 
    3504                 :      165986 :       free (atom_string);
    3505                 :             :     }
    3506                 :             :   else
    3507                 :             :     {
    3508                 :       60818 :       p = mpz_get_str (NULL, 10, *integer);
    3509                 :       60818 :       write_atom (ATOM_STRING, p);
    3510                 :       60818 :       free (p);
    3511                 :             :     }
    3512                 :      226804 : }
    3513                 :             : 
    3514                 :             : 
    3515                 :             : static void
    3516                 :        1458 : mio_gmp_real (mpfr_t *real)
    3517                 :             : {
    3518                 :        1458 :   mpfr_exp_t exponent;
    3519                 :        1458 :   char *p;
    3520                 :             : 
    3521                 :        1458 :   if (iomode == IO_INPUT)
    3522                 :             :     {
    3523                 :         690 :       if (parse_atom () != ATOM_STRING)
    3524                 :           0 :         bad_module ("Expected real string");
    3525                 :             : 
    3526                 :         690 :       mpfr_init (*real);
    3527                 :         690 :       mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
    3528                 :         690 :       free (atom_string);
    3529                 :             :     }
    3530                 :             :   else
    3531                 :             :     {
    3532                 :         768 :       p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE);
    3533                 :             : 
    3534                 :         768 :       if (mpfr_nan_p (*real) || mpfr_inf_p (*real))
    3535                 :             :         {
    3536                 :          18 :           write_atom (ATOM_STRING, p);
    3537                 :          18 :           free (p);
    3538                 :          18 :           return;
    3539                 :             :         }
    3540                 :             : 
    3541                 :         750 :       atom_string = XCNEWVEC (char, strlen (p) + 20);
    3542                 :             : 
    3543                 :         750 :       sprintf (atom_string, "0.%s@%ld", p, exponent);
    3544                 :             : 
    3545                 :             :       /* Fix negative numbers.  */
    3546                 :         750 :       if (atom_string[2] == '-')
    3547                 :             :         {
    3548                 :          15 :           atom_string[0] = '-';
    3549                 :          15 :           atom_string[1] = '0';
    3550                 :          15 :           atom_string[2] = '.';
    3551                 :             :         }
    3552                 :             : 
    3553                 :         750 :       write_atom (ATOM_STRING, atom_string);
    3554                 :             : 
    3555                 :         750 :       free (atom_string);
    3556                 :         750 :       free (p);
    3557                 :             :     }
    3558                 :             : }
    3559                 :             : 
    3560                 :             : 
    3561                 :             : /* Save and restore the shape of an array constructor.  */
    3562                 :             : 
    3563                 :             : static void
    3564                 :       18037 : mio_shape (mpz_t **pshape, int rank)
    3565                 :             : {
    3566                 :       18037 :   mpz_t *shape;
    3567                 :       18037 :   atom_type t;
    3568                 :       18037 :   int n;
    3569                 :             : 
    3570                 :             :   /* A NULL shape is represented by ().  */
    3571                 :       18037 :   mio_lparen ();
    3572                 :             : 
    3573                 :       18037 :   if (iomode == IO_OUTPUT)
    3574                 :             :     {
    3575                 :        3407 :       shape = *pshape;
    3576                 :        3407 :       if (!shape)
    3577                 :             :         {
    3578                 :        2839 :           mio_rparen ();
    3579                 :        2839 :           return;
    3580                 :             :         }
    3581                 :             :     }
    3582                 :             :   else
    3583                 :             :     {
    3584                 :       14630 :       t = peek_atom ();
    3585                 :       14630 :       if (t == ATOM_RPAREN)
    3586                 :             :         {
    3587                 :       13391 :           *pshape = NULL;
    3588                 :       13391 :           mio_rparen ();
    3589                 :       13391 :           return;
    3590                 :             :         }
    3591                 :             : 
    3592                 :        1239 :       shape = gfc_get_shape (rank);
    3593                 :        1239 :       *pshape = shape;
    3594                 :             :     }
    3595                 :             : 
    3596                 :        3741 :   for (n = 0; n < rank; n++)
    3597                 :        1934 :     mio_gmp_integer (&shape[n]);
    3598                 :             : 
    3599                 :        1807 :   mio_rparen ();
    3600                 :             : }
    3601                 :             : 
    3602                 :             : 
    3603                 :             : static const mstring expr_types[] = {
    3604                 :             :     minit ("OP", EXPR_OP),
    3605                 :             :     minit ("FUNCTION", EXPR_FUNCTION),
    3606                 :             :     minit ("CONSTANT", EXPR_CONSTANT),
    3607                 :             :     minit ("VARIABLE", EXPR_VARIABLE),
    3608                 :             :     minit ("SUBSTRING", EXPR_SUBSTRING),
    3609                 :             :     minit ("STRUCTURE", EXPR_STRUCTURE),
    3610                 :             :     minit ("ARRAY", EXPR_ARRAY),
    3611                 :             :     minit ("NULL", EXPR_NULL),
    3612                 :             :     minit ("COMPCALL", EXPR_COMPCALL),
    3613                 :             :     minit (NULL, -1)
    3614                 :             : };
    3615                 :             : 
    3616                 :             : /* INTRINSIC_ASSIGN is missing because it is used as an index for
    3617                 :             :    generic operators, not in expressions.  INTRINSIC_USER is also
    3618                 :             :    replaced by the correct function name by the time we see it.  */
    3619                 :             : 
    3620                 :             : static const mstring intrinsics[] =
    3621                 :             : {
    3622                 :             :     minit ("UPLUS", INTRINSIC_UPLUS),
    3623                 :             :     minit ("UMINUS", INTRINSIC_UMINUS),
    3624                 :             :     minit ("PLUS", INTRINSIC_PLUS),
    3625                 :             :     minit ("MINUS", INTRINSIC_MINUS),
    3626                 :             :     minit ("TIMES", INTRINSIC_TIMES),
    3627                 :             :     minit ("DIVIDE", INTRINSIC_DIVIDE),
    3628                 :             :     minit ("POWER", INTRINSIC_POWER),
    3629                 :             :     minit ("CONCAT", INTRINSIC_CONCAT),
    3630                 :             :     minit ("AND", INTRINSIC_AND),
    3631                 :             :     minit ("OR", INTRINSIC_OR),
    3632                 :             :     minit ("EQV", INTRINSIC_EQV),
    3633                 :             :     minit ("NEQV", INTRINSIC_NEQV),
    3634                 :             :     minit ("EQ_SIGN", INTRINSIC_EQ),
    3635                 :             :     minit ("EQ", INTRINSIC_EQ_OS),
    3636                 :             :     minit ("NE_SIGN", INTRINSIC_NE),
    3637                 :             :     minit ("NE", INTRINSIC_NE_OS),
    3638                 :             :     minit ("GT_SIGN", INTRINSIC_GT),
    3639                 :             :     minit ("GT", INTRINSIC_GT_OS),
    3640                 :             :     minit ("GE_SIGN", INTRINSIC_GE),
    3641                 :             :     minit ("GE", INTRINSIC_GE_OS),
    3642                 :             :     minit ("LT_SIGN", INTRINSIC_LT),
    3643                 :             :     minit ("LT", INTRINSIC_LT_OS),
    3644                 :             :     minit ("LE_SIGN", INTRINSIC_LE),
    3645                 :             :     minit ("LE", INTRINSIC_LE_OS),
    3646                 :             :     minit ("NOT", INTRINSIC_NOT),
    3647                 :             :     minit ("PARENTHESES", INTRINSIC_PARENTHESES),
    3648                 :             :     minit ("USER", INTRINSIC_USER),
    3649                 :             :     minit (NULL, -1)
    3650                 :             : };
    3651                 :             : 
    3652                 :             : 
    3653                 :             : /* Remedy a couple of situations where the gfc_expr's can be defective.  */
    3654                 :             : 
    3655                 :             : static void
    3656                 :      287619 : fix_mio_expr (gfc_expr *e)
    3657                 :             : {
    3658                 :      287619 :   gfc_symtree *ns_st = NULL;
    3659                 :      287619 :   const char *fname;
    3660                 :             : 
    3661                 :      287619 :   if (iomode != IO_OUTPUT)
    3662                 :             :     return;
    3663                 :             : 
    3664                 :       85652 :   if (e->symtree)
    3665                 :             :     {
    3666                 :             :       /* If this is a symtree for a symbol that came from a contained module
    3667                 :             :          namespace, it has a unique name and we should look in the current
    3668                 :             :          namespace to see if the required, non-contained symbol is available
    3669                 :             :          yet. If so, the latter should be written.  */
    3670                 :        8333 :       if (e->symtree->n.sym && check_unique_name (e->symtree->name))
    3671                 :             :         {
    3672                 :         514 :           const char *name = e->symtree->n.sym->name;
    3673                 :         514 :           if (gfc_fl_struct (e->symtree->n.sym->attr.flavor))
    3674                 :           0 :             name = gfc_dt_upper_string (name);
    3675                 :         514 :           ns_st = gfc_find_symtree (gfc_current_ns->sym_root, name);
    3676                 :             :         }
    3677                 :             : 
    3678                 :             :       /* On the other hand, if the existing symbol is the module name or the
    3679                 :             :          new symbol is a dummy argument, do not do the promotion.  */
    3680                 :         514 :       if (ns_st && ns_st->n.sym
    3681                 :          21 :           && ns_st->n.sym->attr.flavor != FL_MODULE
    3682                 :          20 :           && !e->symtree->n.sym->attr.dummy)
    3683                 :          19 :         e->symtree = ns_st;
    3684                 :             :     }
    3685                 :       77319 :   else if (e->expr_type == EXPR_FUNCTION
    3686                 :           2 :            && (e->value.function.name || e->value.function.isym))
    3687                 :             :     {
    3688                 :           2 :       gfc_symbol *sym;
    3689                 :             : 
    3690                 :             :       /* In some circumstances, a function used in an initialization
    3691                 :             :          expression, in one use associated module, can fail to be
    3692                 :             :          coupled to its symtree when used in a specification
    3693                 :             :          expression in another module.  */
    3694                 :           2 :       fname = e->value.function.esym ? e->value.function.esym->name
    3695                 :           2 :                                      : e->value.function.isym->name;
    3696                 :           2 :       e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
    3697                 :             : 
    3698                 :           2 :       if (e->symtree)
    3699                 :           1 :         return;
    3700                 :             : 
    3701                 :             :       /* This is probably a reference to a private procedure from another
    3702                 :             :          module.  To prevent a segfault, make a generic with no specific
    3703                 :             :          instances.  If this module is used, without the required
    3704                 :             :          specific coming from somewhere, the appropriate error message
    3705                 :             :          is issued.  */
    3706                 :           1 :       gfc_get_symbol (fname, gfc_current_ns, &sym);
    3707                 :           1 :       sym->attr.flavor = FL_PROCEDURE;
    3708                 :           1 :       sym->attr.generic = 1;
    3709                 :           1 :       e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
    3710                 :           1 :       gfc_commit_symbol (sym);
    3711                 :             :     }
    3712                 :             : }
    3713                 :             : 
    3714                 :             : 
    3715                 :             : /* Read and write expressions.  The form "()" is allowed to indicate a
    3716                 :             :    NULL expression.  */
    3717                 :             : 
    3718                 :             : static void
    3719                 :      625694 : mio_expr (gfc_expr **ep)
    3720                 :             : {
    3721                 :      625694 :   HOST_WIDE_INT hwi;
    3722                 :      625694 :   gfc_expr *e;
    3723                 :      625694 :   atom_type t;
    3724                 :      625694 :   int flag;
    3725                 :             : 
    3726                 :      625694 :   mio_lparen ();
    3727                 :             : 
    3728                 :      625694 :   if (iomode == IO_OUTPUT)
    3729                 :             :     {
    3730                 :      212523 :       if (*ep == NULL)
    3731                 :             :         {
    3732                 :      126871 :           mio_rparen ();
    3733                 :      464946 :           return;
    3734                 :             :         }
    3735                 :             : 
    3736                 :       85652 :       e = *ep;
    3737                 :       85652 :       MIO_NAME (expr_t) (e->expr_type, expr_types);
    3738                 :             :     }
    3739                 :             :   else
    3740                 :             :     {
    3741                 :      413171 :       t = parse_atom ();
    3742                 :      413171 :       if (t == ATOM_RPAREN)
    3743                 :             :         {
    3744                 :      211204 :           *ep = NULL;
    3745                 :      211204 :           return;
    3746                 :             :         }
    3747                 :             : 
    3748                 :      201967 :       if (t != ATOM_NAME)
    3749                 :           0 :         bad_module ("Expected expression type");
    3750                 :             : 
    3751                 :      201967 :       e = *ep = gfc_get_expr ();
    3752                 :      201967 :       e->where = gfc_current_locus;
    3753                 :      201967 :       e->expr_type = (expr_t) find_enum (expr_types);
    3754                 :             :     }
    3755                 :             : 
    3756                 :      287619 :   mio_typespec (&e->ts);
    3757                 :      287619 :   mio_integer (&e->rank);
    3758                 :             : 
    3759                 :      287619 :   fix_mio_expr (e);
    3760                 :             : 
    3761                 :      287619 :   switch (e->expr_type)
    3762                 :             :     {
    3763                 :        1444 :     case EXPR_OP:
    3764                 :        1444 :       e->value.op.op
    3765                 :        1444 :         = MIO_NAME (gfc_intrinsic_op) (e->value.op.op, intrinsics);
    3766                 :             : 
    3767                 :        1444 :       switch (e->value.op.op)
    3768                 :             :         {
    3769                 :         445 :         case INTRINSIC_UPLUS:
    3770                 :         445 :         case INTRINSIC_UMINUS:
    3771                 :         445 :         case INTRINSIC_NOT:
    3772                 :         445 :         case INTRINSIC_PARENTHESES:
    3773                 :         445 :           mio_expr (&e->value.op.op1);
    3774                 :         445 :           break;
    3775                 :             : 
    3776                 :         929 :         case INTRINSIC_PLUS:
    3777                 :         929 :         case INTRINSIC_MINUS:
    3778                 :         929 :         case INTRINSIC_TIMES:
    3779                 :         929 :         case INTRINSIC_DIVIDE:
    3780                 :         929 :         case INTRINSIC_POWER:
    3781                 :         929 :         case INTRINSIC_CONCAT:
    3782                 :         929 :         case INTRINSIC_AND:
    3783                 :         929 :         case INTRINSIC_OR:
    3784                 :         929 :         case INTRINSIC_EQV:
    3785                 :         929 :         case INTRINSIC_NEQV:
    3786                 :         929 :         case INTRINSIC_EQ:
    3787                 :         929 :         case INTRINSIC_EQ_OS:
    3788                 :         929 :         case INTRINSIC_NE:
    3789                 :         929 :         case INTRINSIC_NE_OS:
    3790                 :         929 :         case INTRINSIC_GT:
    3791                 :         929 :         case INTRINSIC_GT_OS:
    3792                 :         929 :         case INTRINSIC_GE:
    3793                 :         929 :         case INTRINSIC_GE_OS:
    3794                 :         929 :         case INTRINSIC_LT:
    3795                 :         929 :         case INTRINSIC_LT_OS:
    3796                 :         929 :         case INTRINSIC_LE:
    3797                 :         929 :         case INTRINSIC_LE_OS:
    3798                 :         929 :           mio_expr (&e->value.op.op1);
    3799                 :         929 :           mio_expr (&e->value.op.op2);
    3800                 :         929 :           break;
    3801                 :             : 
    3802                 :          70 :         case INTRINSIC_USER:
    3803                 :             :           /* INTRINSIC_USER should not appear in resolved expressions,
    3804                 :             :              though for UDRs we need to stream unresolved ones.  */
    3805                 :          70 :           if (iomode == IO_OUTPUT)
    3806                 :          34 :             write_atom (ATOM_STRING, e->value.op.uop->name);
    3807                 :             :           else
    3808                 :             :             {
    3809                 :          36 :               char *name = read_string ();
    3810                 :          36 :               const char *uop_name = find_use_name (name, true);
    3811                 :          36 :               if (uop_name == NULL)
    3812                 :             :                 {
    3813                 :           0 :                   size_t len = strlen (name);
    3814                 :           0 :                   char *name2 = XCNEWVEC (char, len + 2);
    3815                 :           0 :                   memcpy (name2, name, len);
    3816                 :           0 :                   name2[len] = ' ';
    3817                 :           0 :                   name2[len + 1] = '\0';
    3818                 :           0 :                   free (name);
    3819                 :           0 :                   uop_name = name = name2;
    3820                 :             :                 }
    3821                 :          36 :               e->value.op.uop = gfc_get_uop (uop_name);
    3822                 :          36 :               free (name);
    3823                 :             :             }
    3824                 :          70 :           mio_expr (&e->value.op.op1);
    3825                 :          70 :           mio_expr (&e->value.op.op2);
    3826                 :          70 :           break;
    3827                 :             : 
    3828                 :           0 :         default:
    3829                 :           0 :           bad_module ("Bad operator");
    3830                 :             :         }
    3831                 :             : 
    3832                 :             :       break;
    3833                 :             : 
    3834                 :        2158 :     case EXPR_FUNCTION:
    3835                 :        2158 :       mio_symtree_ref (&e->symtree);
    3836                 :        2158 :       mio_actual_arglist (&e->value.function.actual, false);
    3837                 :             : 
    3838                 :        2158 :       if (iomode == IO_OUTPUT)
    3839                 :             :         {
    3840                 :        1090 :           e->value.function.name
    3841                 :        1090 :             = mio_allocated_string (e->value.function.name);
    3842                 :        1090 :           if (e->value.function.esym)
    3843                 :         126 :             flag = 1;
    3844                 :         964 :           else if (e->ref)
    3845                 :          11 :             flag = 2;
    3846                 :         953 :           else if (e->value.function.isym == NULL)
    3847                 :          44 :             flag = 3;
    3848                 :             :           else
    3849                 :         909 :             flag = 0;
    3850                 :        1090 :           mio_integer (&flag);
    3851                 :        1090 :           switch (flag)
    3852                 :             :             {
    3853                 :         126 :             case 1:
    3854                 :         126 :               mio_symbol_ref (&e->value.function.esym);
    3855                 :         126 :               break;
    3856                 :          11 :             case 2:
    3857                 :          11 :               mio_ref_list (&e->ref);
    3858                 :          11 :               break;
    3859                 :             :             case 3:
    3860                 :             :               break;
    3861                 :         909 :             default:
    3862                 :         909 :               write_atom (ATOM_STRING, e->value.function.isym->name);
    3863                 :             :             }
    3864                 :             :         }
    3865                 :             :       else
    3866                 :             :         {
    3867                 :        1068 :           require_atom (ATOM_STRING);
    3868                 :        1068 :           if (atom_string[0] == '\0')
    3869                 :         560 :             e->value.function.name = NULL;
    3870                 :             :           else
    3871                 :         508 :             e->value.function.name = gfc_get_string ("%s", atom_string);
    3872                 :        1068 :           free (atom_string);
    3873                 :             : 
    3874                 :        1068 :           mio_integer (&flag);
    3875                 :        1068 :           switch (flag)
    3876                 :             :             {
    3877                 :         131 :             case 1:
    3878                 :         131 :               mio_symbol_ref (&e->value.function.esym);
    3879                 :         131 :               break;
    3880                 :           0 :             case 2:
    3881                 :           0 :               mio_ref_list (&e->ref);
    3882                 :           0 :               break;
    3883                 :             :             case 3:
    3884                 :             :               break;
    3885                 :         889 :             default:
    3886                 :         889 :               require_atom (ATOM_STRING);
    3887                 :         889 :               e->value.function.isym = gfc_find_function (atom_string);
    3888                 :         889 :               free (atom_string);
    3889                 :             :             }
    3890                 :             :         }
    3891                 :             : 
    3892                 :             :       break;
    3893                 :             : 
    3894                 :       11713 :     case EXPR_VARIABLE:
    3895                 :       11713 :       mio_symtree_ref (&e->symtree);
    3896                 :       11713 :       mio_ref_list (&e->ref);
    3897                 :       11713 :       break;
    3898                 :             : 
    3899                 :           0 :     case EXPR_SUBSTRING:
    3900                 :           0 :       e->value.character.string
    3901                 :           0 :         = CONST_CAST (gfc_char_t *,
    3902                 :             :                       mio_allocated_wide_string (e->value.character.string,
    3903                 :             :                                                  e->value.character.length));
    3904                 :           0 :       mio_ref_list (&e->ref);
    3905                 :           0 :       break;
    3906                 :             : 
    3907                 :       18037 :     case EXPR_STRUCTURE:
    3908                 :       18037 :     case EXPR_ARRAY:
    3909                 :       18037 :       mio_constructor (&e->value.constructor);
    3910                 :       18037 :       mio_shape (&e->shape, e->rank);
    3911                 :       18037 :       break;
    3912                 :             : 
    3913                 :      233907 :     case EXPR_CONSTANT:
    3914                 :      233907 :       switch (e->ts.type)
    3915                 :             :         {
    3916                 :      224870 :         case BT_INTEGER:
    3917                 :      224870 :           mio_gmp_integer (&e->value.integer);
    3918                 :      224870 :           break;
    3919                 :             : 
    3920                 :        1406 :         case BT_REAL:
    3921                 :        1406 :           gfc_set_model_kind (e->ts.kind);
    3922                 :        1406 :           mio_gmp_real (&e->value.real);
    3923                 :        1406 :           break;
    3924                 :             : 
    3925                 :          26 :         case BT_COMPLEX:
    3926                 :          26 :           gfc_set_model_kind (e->ts.kind);
    3927                 :          26 :           mio_gmp_real (&mpc_realref (e->value.complex));
    3928                 :          26 :           mio_gmp_real (&mpc_imagref (e->value.complex));
    3929                 :          26 :           break;
    3930                 :             : 
    3931                 :          57 :         case BT_LOGICAL:
    3932                 :          57 :           mio_integer (&e->value.logical);
    3933                 :          57 :           break;
    3934                 :             : 
    3935                 :        7548 :         case BT_CHARACTER:
    3936                 :        7548 :           hwi = e->value.character.length;
    3937                 :        7548 :           mio_hwi (&hwi);
    3938                 :        7548 :           e->value.character.length = hwi;
    3939                 :        7548 :           e->value.character.string
    3940                 :        7548 :             = CONST_CAST (gfc_char_t *,
    3941                 :             :                           mio_allocated_wide_string (e->value.character.string,
    3942                 :             :                                                      e->value.character.length));
    3943                 :        7548 :           break;
    3944                 :             : 
    3945                 :           0 :         default:
    3946                 :           0 :           bad_module ("Bad type in constant expression");
    3947                 :             :         }
    3948                 :             : 
    3949                 :             :       break;
    3950                 :             : 
    3951                 :             :     case EXPR_NULL:
    3952                 :             :       break;
    3953                 :             : 
    3954                 :           0 :     case EXPR_COMPCALL:
    3955                 :           0 :     case EXPR_PPC:
    3956                 :           0 :     case EXPR_UNKNOWN:
    3957                 :           0 :       gcc_unreachable ();
    3958                 :      287619 :       break;
    3959                 :             :     }
    3960                 :             : 
    3961                 :             :   /* PDT types store the expression specification list here. */
    3962                 :      287619 :   mio_actual_arglist (&e->param_list, true);
    3963                 :             : 
    3964                 :      287619 :   mio_rparen ();
    3965                 :             : }
    3966                 :             : 
    3967                 :             : 
    3968                 :             : /* Read and write namelists.  */
    3969                 :             : 
    3970                 :             : static void
    3971                 :      961510 : mio_namelist (gfc_symbol *sym)
    3972                 :             : {
    3973                 :      961510 :   gfc_namelist *n, *m;
    3974                 :             : 
    3975                 :      961510 :   mio_lparen ();
    3976                 :             : 
    3977                 :      961510 :   if (iomode == IO_OUTPUT)
    3978                 :             :     {
    3979                 :      199624 :       for (n = sym->namelist; n; n = n->next)
    3980                 :          82 :         mio_symbol_ref (&n->sym);
    3981                 :             :     }
    3982                 :             :   else
    3983                 :             :     {
    3984                 :             :       m = NULL;
    3985                 :      762055 :       while (peek_atom () != ATOM_RPAREN)
    3986                 :             :         {
    3987                 :          87 :           n = gfc_get_namelist ();
    3988                 :          87 :           mio_symbol_ref (&n->sym);
    3989                 :             : 
    3990                 :          87 :           if (sym->namelist == NULL)
    3991                 :          51 :             sym->namelist = n;
    3992                 :             :           else
    3993                 :          36 :             m->next = n;
    3994                 :             : 
    3995                 :             :           m = n;
    3996                 :             :         }
    3997                 :      761968 :       sym->namelist_tail = m;
    3998                 :             :     }
    3999                 :             : 
    4000                 :      961510 :   mio_rparen ();
    4001                 :      961510 : }
    4002                 :             : 
    4003                 :             : 
    4004                 :             : /* Save/restore lists of gfc_interface structures.  When loading an
    4005                 :             :    interface, we are really appending to the existing list of
    4006                 :             :    interfaces.  Checking for duplicate and ambiguous interfaces has to
    4007                 :             :    be done later when all symbols have been loaded.  */
    4008                 :             : 
    4009                 :             : pointer_info *
    4010                 :      569474 : mio_interface_rest (gfc_interface **ip)
    4011                 :             : {
    4012                 :      569474 :   gfc_interface *tail, *p;
    4013                 :      569474 :   pointer_info *pi = NULL;
    4014                 :             : 
    4015                 :      569474 :   if (iomode == IO_OUTPUT)
    4016                 :             :     {
    4017                 :      245359 :       if (ip != NULL)
    4018                 :      239151 :         for (p = *ip; p; p = p->next)
    4019                 :       14496 :           mio_symbol_ref (&p->sym);
    4020                 :             :     }
    4021                 :             :   else
    4022                 :             :     {
    4023                 :      324115 :       if (*ip == NULL)
    4024                 :             :         tail = NULL;
    4025                 :             :       else
    4026                 :             :         {
    4027                 :             :           tail = *ip;
    4028                 :        5087 :           while (tail->next)
    4029                 :             :             tail = tail->next;
    4030                 :             :         }
    4031                 :             : 
    4032                 :      465027 :       for (;;)
    4033                 :             :         {
    4034                 :      465027 :           if (peek_atom () == ATOM_RPAREN)
    4035                 :             :             break;
    4036                 :             : 
    4037                 :      140912 :           p = gfc_get_interface ();
    4038                 :      140912 :           p->where = gfc_current_locus;
    4039                 :      140912 :           pi = mio_symbol_ref (&p->sym);
    4040                 :             : 
    4041                 :      140912 :           if (tail == NULL)
    4042                 :       45912 :             *ip = p;
    4043                 :             :           else
    4044                 :       95000 :             tail->next = p;
    4045                 :             : 
    4046                 :             :           tail = p;
    4047                 :             :         }
    4048                 :             :     }
    4049                 :             : 
    4050                 :      569474 :   mio_rparen ();
    4051                 :      569474 :   return pi;
    4052                 :             : }
    4053                 :             : 
    4054                 :             : 
    4055                 :             : /* Save/restore a nameless operator interface.  */
    4056                 :             : 
    4057                 :             : static void
    4058                 :      513360 : mio_interface (gfc_interface **ip)
    4059                 :             : {
    4060                 :      236034 :   mio_lparen ();
    4061                 :      277326 :   mio_interface_rest (ip);
    4062                 :      236034 : }
    4063                 :             : 
    4064                 :             : 
    4065                 :             : /* Save/restore a named operator interface.  */
    4066                 :             : 
    4067                 :             : static void
    4068                 :        9325 : mio_symbol_interface (const char **name, const char **module,
    4069                 :             :                       gfc_interface **ip)
    4070                 :             : {
    4071                 :        9325 :   mio_lparen ();
    4072                 :        9325 :   mio_pool_string (name);
    4073                 :        9325 :   mio_pool_string (module);
    4074                 :        9325 :   mio_interface_rest (ip);
    4075                 :        9325 : }
    4076                 :             : 
    4077                 :             : 
    4078                 :             : static void
    4079                 :      961510 : mio_namespace_ref (gfc_namespace **nsp)
    4080                 :             : {
    4081                 :      961510 :   gfc_namespace *ns;
    4082                 :      961510 :   pointer_info *p;
    4083                 :             : 
    4084                 :      961510 :   p = mio_pointer_ref (nsp);
    4085                 :             : 
    4086                 :      961510 :   if (p->type == P_UNKNOWN)
    4087                 :      208860 :     p->type = P_NAMESPACE;
    4088                 :             : 
    4089                 :      961510 :   if (iomode == IO_INPUT && p->integer != 0)
    4090                 :             :     {
    4091                 :      184995 :       ns = (gfc_namespace *) p->u.pointer;
    4092                 :      184995 :       if (ns == NULL)
    4093                 :             :         {
    4094                 :      184759 :           ns = gfc_get_namespace (NULL, 0);
    4095                 :      184759 :           associate_integer_pointer (p, ns);
    4096                 :             :         }
    4097                 :             :       else
    4098                 :         236 :         ns->refs++;
    4099                 :             :     }
    4100                 :      961510 : }
    4101                 :             : 
    4102                 :             : 
    4103                 :             : /* Save/restore the f2k_derived namespace of a derived-type symbol.  */
    4104                 :             : 
    4105                 :             : static gfc_namespace* current_f2k_derived;
    4106                 :             : 
    4107                 :             : static void
    4108                 :       84079 : mio_typebound_proc (gfc_typebound_proc** proc)
    4109                 :             : {
    4110                 :       84079 :   int flag;
    4111                 :       84079 :   int overriding_flag;
    4112                 :             : 
    4113                 :       84079 :   if (iomode == IO_INPUT)
    4114                 :             :     {
    4115                 :       47339 :       *proc = gfc_get_typebound_proc (NULL);
    4116                 :       47339 :       (*proc)->where = gfc_current_locus;
    4117                 :             :     }
    4118                 :       84079 :   gcc_assert (*proc);
    4119                 :             : 
    4120                 :       84079 :   mio_lparen ();
    4121                 :             : 
    4122                 :       84079 :   (*proc)->access = MIO_NAME (gfc_access) ((*proc)->access, access_types);
    4123                 :             : 
    4124                 :             :   /* IO the NON_OVERRIDABLE/DEFERRED combination.  */
    4125                 :       84079 :   gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
    4126                 :       84079 :   overriding_flag = ((*proc)->deferred << 1) | (*proc)->non_overridable;
    4127                 :       84079 :   overriding_flag = mio_name (overriding_flag, binding_overriding);
    4128                 :       84079 :   (*proc)->deferred = ((overriding_flag & 2) != 0);
    4129                 :       84079 :   (*proc)->non_overridable = ((overriding_flag & 1) != 0);
    4130                 :       84079 :   gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
    4131                 :             : 
    4132                 :       84079 :   (*proc)->nopass = mio_name ((*proc)->nopass, binding_passing);
    4133                 :       84079 :   (*proc)->is_generic = mio_name ((*proc)->is_generic, binding_generic);
    4134                 :       84079 :   (*proc)->ppc = mio_name((*proc)->ppc, binding_ppc);
    4135                 :             : 
    4136                 :       84079 :   mio_pool_string (&((*proc)->pass_arg));
    4137                 :             : 
    4138                 :       84079 :   flag = (int) (*proc)->pass_arg_num;
    4139                 :       84079 :   mio_integer (&flag);
    4140                 :       84079 :   (*proc)->pass_arg_num = (unsigned) flag;
    4141                 :             : 
    4142                 :       84079 :   if ((*proc)->is_generic)
    4143                 :             :     {
    4144                 :        2463 :       gfc_tbp_generic* g;
    4145                 :        2463 :       int iop;
    4146                 :             : 
    4147                 :        2463 :       mio_lparen ();
    4148                 :             : 
    4149                 :        2463 :       if (iomode == IO_OUTPUT)
    4150                 :        2697 :         for (g = (*proc)->u.generic; g; g = g->next)
    4151                 :             :           {
    4152                 :        1418 :             iop = (int) g->is_operator;
    4153                 :        1418 :             mio_integer (&iop);
    4154                 :        1418 :             mio_allocated_string (g->specific_st->name);
    4155                 :             :           }
    4156                 :             :       else
    4157                 :             :         {
    4158                 :        1184 :           (*proc)->u.generic = NULL;
    4159                 :        2495 :           while (peek_atom () != ATOM_RPAREN)
    4160                 :             :             {
    4161                 :        1311 :               gfc_symtree** sym_root;
    4162                 :             : 
    4163                 :        1311 :               g = gfc_get_tbp_generic ();
    4164                 :        1311 :               g->specific = NULL;
    4165                 :             : 
    4166                 :        1311 :               mio_integer (&iop);
    4167                 :        1311 :               g->is_operator = (bool) iop;
    4168                 :             : 
    4169                 :        1311 :               require_atom (ATOM_STRING);
    4170                 :        1311 :               sym_root = &current_f2k_derived->tb_sym_root;
    4171                 :        1311 :               g->specific_st = gfc_get_tbp_symtree (sym_root, atom_string);
    4172                 :        1311 :               free (atom_string);
    4173                 :             : 
    4174                 :        1311 :               g->next = (*proc)->u.generic;
    4175                 :        1311 :               (*proc)->u.generic = g;
    4176                 :             :             }
    4177                 :             :         }
    4178                 :             : 
    4179                 :        2463 :       mio_rparen ();
    4180                 :             :     }
    4181                 :       81616 :   else if (!(*proc)->ppc)
    4182                 :        8053 :     mio_symtree_ref (&(*proc)->u.specific);
    4183                 :             : 
    4184                 :       84079 :   mio_rparen ();
    4185                 :       84079 : }
    4186                 :             : 
    4187                 :             : /* Walker-callback function for this purpose.  */
    4188                 :             : static void
    4189                 :        9291 : mio_typebound_symtree (gfc_symtree* st)
    4190                 :             : {
    4191                 :        9291 :   if (iomode == IO_OUTPUT && !st->n.tb)
    4192                 :             :     return;
    4193                 :             : 
    4194                 :        9291 :   if (iomode == IO_OUTPUT)
    4195                 :             :     {
    4196                 :        4851 :       mio_lparen ();
    4197                 :        4851 :       mio_allocated_string (st->name);
    4198                 :             :     }
    4199                 :             :   /* For IO_INPUT, the above is done in mio_f2k_derived.  */
    4200                 :             : 
    4201                 :        9291 :   mio_typebound_proc (&st->n.tb);
    4202                 :        9291 :   mio_rparen ();
    4203                 :             : }
    4204                 :             : 
    4205                 :             : /* IO a full symtree (in all depth).  */
    4206                 :             : static void
    4207                 :       53592 : mio_full_typebound_tree (gfc_symtree** root)
    4208                 :             : {
    4209                 :       53592 :   mio_lparen ();
    4210                 :             : 
    4211                 :       53592 :   if (iomode == IO_OUTPUT)
    4212                 :       22926 :     gfc_traverse_symtree (*root, &mio_typebound_symtree);
    4213                 :             :   else
    4214                 :             :     {
    4215                 :       35106 :       while (peek_atom () == ATOM_LPAREN)
    4216                 :             :         {
    4217                 :        4440 :           gfc_symtree* st;
    4218                 :             : 
    4219                 :        4440 :           mio_lparen ();
    4220                 :             : 
    4221                 :        4440 :           require_atom (ATOM_STRING);
    4222                 :        4440 :           st = gfc_get_tbp_symtree (root, atom_string);
    4223                 :        4440 :           free (atom_string);
    4224                 :             : 
    4225                 :        4440 :           mio_typebound_symtree (st);
    4226                 :             :         }
    4227                 :             :     }
    4228                 :             : 
    4229                 :       53592 :   mio_rparen ();
    4230                 :       53592 : }
    4231                 :             : 
    4232                 :             : static void
    4233                 :         850 : mio_finalizer (gfc_finalizer **f)
    4234                 :             : {
    4235                 :         850 :   if (iomode == IO_OUTPUT)
    4236                 :             :     {
    4237                 :         428 :       gcc_assert (*f);
    4238                 :         428 :       gcc_assert ((*f)->proc_tree); /* Should already be resolved.  */
    4239                 :         428 :       mio_symtree_ref (&(*f)->proc_tree);
    4240                 :             :     }
    4241                 :             :   else
    4242                 :             :     {
    4243                 :         422 :       *f = gfc_get_finalizer ();
    4244                 :         422 :       (*f)->where = gfc_current_locus; /* Value should not matter.  */
    4245                 :         422 :       (*f)->next = NULL;
    4246                 :             : 
    4247                 :         422 :       mio_symtree_ref (&(*f)->proc_tree);
    4248                 :         422 :       (*f)->proc_sym = NULL;
    4249                 :             :     }
    4250                 :         850 : }
    4251                 :             : 
    4252                 :             : static void
    4253                 :       26796 : mio_f2k_derived (gfc_namespace *f2k)
    4254                 :             : {
    4255                 :       26796 :   current_f2k_derived = f2k;
    4256                 :             : 
    4257                 :             :   /* Handle the list of finalizer procedures.  */
    4258                 :       26796 :   mio_lparen ();
    4259                 :       26796 :   if (iomode == IO_OUTPUT)
    4260                 :             :     {
    4261                 :       11463 :       gfc_finalizer *f;
    4262                 :       11891 :       for (f = f2k->finalizers; f; f = f->next)
    4263                 :         428 :         mio_finalizer (&f);
    4264                 :             :     }
    4265                 :             :   else
    4266                 :             :     {
    4267                 :       15333 :       f2k->finalizers = NULL;
    4268                 :       15755 :       while (peek_atom () != ATOM_RPAREN)
    4269                 :             :         {
    4270                 :         422 :           gfc_finalizer *cur = NULL;
    4271                 :         422 :           mio_finalizer (&cur);
    4272                 :         422 :           cur->next = f2k->finalizers;
    4273                 :         422 :           f2k->finalizers = cur;
    4274                 :             :         }
    4275                 :             :     }
    4276                 :       26796 :   mio_rparen ();
    4277                 :             : 
    4278                 :             :   /* Handle type-bound procedures.  */
    4279                 :       26796 :   mio_full_typebound_tree (&f2k->tb_sym_root);
    4280                 :             : 
    4281                 :             :   /* Type-bound user operators.  */
    4282                 :       26796 :   mio_full_typebound_tree (&f2k->tb_uop_root);
    4283                 :             : 
    4284                 :             :   /* Type-bound intrinsic operators.  */
    4285                 :       26796 :   mio_lparen ();
    4286                 :       26796 :   if (iomode == IO_OUTPUT)
    4287                 :             :     {
    4288                 :             :       int op;
    4289                 :      332427 :       for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
    4290                 :             :         {
    4291                 :      320964 :           gfc_intrinsic_op realop;
    4292                 :             : 
    4293                 :      320964 :           if (op == INTRINSIC_USER || !f2k->tb_op[op])
    4294                 :      320311 :             continue;
    4295                 :             : 
    4296                 :         653 :           mio_lparen ();
    4297                 :         653 :           realop = (gfc_intrinsic_op) op;
    4298                 :         653 :           mio_intrinsic_op (&realop);
    4299                 :         653 :           mio_typebound_proc (&f2k->tb_op[op]);
    4300                 :         653 :           mio_rparen ();
    4301                 :             :         }
    4302                 :             :     }
    4303                 :             :   else
    4304                 :       15905 :     while (peek_atom () != ATOM_RPAREN)
    4305                 :             :       {
    4306                 :         572 :         gfc_intrinsic_op op = GFC_INTRINSIC_BEGIN; /* Silence GCC.  */
    4307                 :             : 
    4308                 :         572 :         mio_lparen ();
    4309                 :         572 :         mio_intrinsic_op (&op);
    4310                 :         572 :         mio_typebound_proc (&f2k->tb_op[op]);
    4311                 :         572 :         mio_rparen ();
    4312                 :             :       }
    4313                 :       26796 :   mio_rparen ();
    4314                 :       26796 : }
    4315                 :             : 
    4316                 :             : static void
    4317                 :      961510 : mio_full_f2k_derived (gfc_symbol *sym)
    4318                 :             : {
    4319                 :      961510 :   mio_lparen ();
    4320                 :             : 
    4321                 :      961510 :   if (iomode == IO_OUTPUT)
    4322                 :             :     {
    4323                 :      199542 :       if (sym->f2k_derived)
    4324                 :       11463 :         mio_f2k_derived (sym->f2k_derived);
    4325                 :             :     }
    4326                 :             :   else
    4327                 :             :     {
    4328                 :      761968 :       if (peek_atom () != ATOM_RPAREN)
    4329                 :             :         {
    4330                 :       15333 :           gfc_namespace *ns;
    4331                 :             : 
    4332                 :       15333 :           sym->f2k_derived = gfc_get_namespace (NULL, 0);
    4333                 :             : 
    4334                 :             :           /* PDT templates make use of the mechanisms for formal args
    4335                 :             :              and so the parameter symbols are stored in the formal
    4336                 :             :              namespace.  Transfer the sym_root to f2k_derived and then
    4337                 :             :              free the formal namespace since it is uneeded.  */
    4338                 :       15333 :           if (sym->attr.pdt_template && sym->formal && sym->formal->sym)
    4339                 :             :             {
    4340                 :           6 :               ns = sym->formal->sym->ns;
    4341                 :           6 :               sym->f2k_derived->sym_root = ns->sym_root;
    4342                 :           6 :               ns->sym_root = NULL;
    4343                 :           6 :               ns->refs++;
    4344                 :           6 :               gfc_free_namespace (ns);
    4345                 :           6 :               ns = NULL;
    4346                 :             :             }
    4347                 :             : 
    4348                 :       15333 :           mio_f2k_derived (sym->f2k_derived);
    4349                 :             :         }
    4350                 :             :       else
    4351                 :      746635 :         gcc_assert (!sym->f2k_derived);
    4352                 :             :     }
    4353                 :             : 
    4354                 :      961510 :   mio_rparen ();
    4355                 :      961510 : }
    4356                 :             : 
    4357                 :             : static const mstring omp_declare_simd_clauses[] =
    4358                 :             : {
    4359                 :             :     minit ("INBRANCH", 0),
    4360                 :             :     minit ("NOTINBRANCH", 1),
    4361                 :             :     minit ("SIMDLEN", 2),
    4362                 :             :     minit ("UNIFORM", 3),
    4363                 :             :     minit ("LINEAR", 4),
    4364                 :             :     minit ("ALIGNED", 5),
    4365                 :             :     minit ("LINEAR_REF", 33),
    4366                 :             :     minit ("LINEAR_VAL", 34),
    4367                 :             :     minit ("LINEAR_UVAL", 35),
    4368                 :             :     minit (NULL, -1)
    4369                 :             : };
    4370                 :             : 
    4371                 :             : /* Handle !$omp declare simd.  */
    4372                 :             : 
    4373                 :             : static void
    4374                 :      208893 : mio_omp_declare_simd (gfc_namespace *ns, gfc_omp_declare_simd **odsp)
    4375                 :             : {
    4376                 :      208893 :   if (iomode == IO_OUTPUT)
    4377                 :             :     {
    4378                 :       23824 :       if (*odsp == NULL)
    4379                 :             :         return;
    4380                 :             :     }
    4381                 :      185069 :   else if (peek_atom () != ATOM_LPAREN)
    4382                 :             :     return;
    4383                 :             : 
    4384                 :         158 :   gfc_omp_declare_simd *ods = *odsp;
    4385                 :             : 
    4386                 :         158 :   mio_lparen ();
    4387                 :         158 :   if (iomode == IO_OUTPUT)
    4388                 :             :     {
    4389                 :          84 :       write_atom (ATOM_NAME, "OMP_DECLARE_SIMD");
    4390                 :          84 :       if (ods->clauses)
    4391                 :             :         {
    4392                 :          84 :           gfc_omp_namelist *n;
    4393                 :             : 
    4394                 :          84 :           if (ods->clauses->inbranch)
    4395                 :           6 :             mio_name (0, omp_declare_simd_clauses);
    4396                 :          84 :           if (ods->clauses->notinbranch)
    4397                 :          18 :             mio_name (1, omp_declare_simd_clauses);
    4398                 :          84 :           if (ods->clauses->simdlen_expr)
    4399                 :             :             {
    4400                 :          23 :               mio_name (2, omp_declare_simd_clauses);
    4401                 :          23 :               mio_expr (&ods->clauses->simdlen_expr);
    4402                 :             :             }
    4403                 :         138 :           for (n = ods->clauses->lists[OMP_LIST_UNIFORM]; n; n = n->next)
    4404                 :             :             {
    4405                 :          54 :               mio_name (3, omp_declare_simd_clauses);
    4406                 :          54 :               mio_symbol_ref (&n->sym);
    4407                 :             :             }
    4408                 :         135 :           for (n = ods->clauses->lists[OMP_LIST_LINEAR]; n; n = n->next)
    4409                 :             :             {
    4410                 :          51 :               if (n->u.linear.op == OMP_LINEAR_DEFAULT)
    4411                 :          32 :                 mio_name (4, omp_declare_simd_clauses);
    4412                 :             :               else
    4413                 :          19 :                 mio_name (32 + n->u.linear.op, omp_declare_simd_clauses);
    4414                 :          51 :               mio_symbol_ref (&n->sym);
    4415                 :          51 :               mio_expr (&n->expr);
    4416                 :             :             }
    4417                 :          84 :           for (n = ods->clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
    4418                 :             :             {
    4419                 :           0 :               mio_name (5, omp_declare_simd_clauses);
    4420                 :           0 :               mio_symbol_ref (&n->sym);
    4421                 :           0 :               mio_expr (&n->expr);
    4422                 :             :             }
    4423                 :             :         }
    4424                 :             :     }
    4425                 :             :   else
    4426                 :             :     {
    4427                 :          74 :       gfc_omp_namelist **ptrs[3] = { NULL, NULL, NULL };
    4428                 :             : 
    4429                 :          74 :       require_atom (ATOM_NAME);
    4430                 :          74 :       *odsp = ods = gfc_get_omp_declare_simd ();
    4431                 :          74 :       ods->where = gfc_current_locus;
    4432                 :          74 :       ods->proc_name = ns->proc_name;
    4433                 :          74 :       if (peek_atom () == ATOM_NAME)
    4434                 :             :         {
    4435                 :          56 :           ods->clauses = gfc_get_omp_clauses ();
    4436                 :          56 :           ptrs[0] = &ods->clauses->lists[OMP_LIST_UNIFORM];
    4437                 :          56 :           ptrs[1] = &ods->clauses->lists[OMP_LIST_LINEAR];
    4438                 :          56 :           ptrs[2] = &ods->clauses->lists[OMP_LIST_ALIGNED];
    4439                 :             :         }
    4440                 :         243 :       while (peek_atom () == ATOM_NAME)
    4441                 :             :         {
    4442                 :         169 :           gfc_omp_namelist *n;
    4443                 :         169 :           int t = mio_name (0, omp_declare_simd_clauses);
    4444                 :             : 
    4445                 :         169 :           switch (t)
    4446                 :             :             {
    4447                 :           0 :             case 0: ods->clauses->inbranch = true; break;
    4448                 :          30 :             case 1: ods->clauses->notinbranch = true; break;
    4449                 :          19 :             case 2: mio_expr (&ods->clauses->simdlen_expr); break;
    4450                 :         117 :             case 3:
    4451                 :         117 :             case 4:
    4452                 :         117 :             case 5:
    4453                 :         117 :               *ptrs[t - 3] = n = gfc_get_omp_namelist ();
    4454                 :         120 :             finish_namelist:
    4455                 :         120 :               n->where = gfc_current_locus;
    4456                 :         120 :               ptrs[t - 3] = &n->next;
    4457                 :         120 :               mio_symbol_ref (&n->sym);
    4458                 :         120 :               if (t != 3)
    4459                 :          52 :                 mio_expr (&n->expr);
    4460                 :             :               break;
    4461                 :           3 :             case 33:
    4462                 :           3 :             case 34:
    4463                 :           3 :             case 35:
    4464                 :           3 :               *ptrs[1] = n = gfc_get_omp_namelist ();
    4465                 :           3 :               n->u.linear.op = (enum gfc_omp_linear_op) (t - 32);
    4466                 :           3 :               t = 4;
    4467                 :           3 :               goto finish_namelist;
    4468                 :             :             }
    4469                 :             :         }
    4470                 :             :     }
    4471                 :             : 
    4472                 :         158 :   mio_omp_declare_simd (ns, &ods->next);
    4473                 :             : 
    4474                 :         158 :   mio_rparen ();
    4475                 :             : }
    4476                 :             : 
    4477                 :             : 
    4478                 :             : static const mstring omp_declare_reduction_stmt[] =
    4479                 :             : {
    4480                 :             :     minit ("ASSIGN", 0),
    4481                 :             :     minit ("CALL", 1),
    4482                 :             :     minit (NULL, -1)
    4483                 :             : };
    4484                 :             : 
    4485                 :             : 
    4486                 :             : static void
    4487                 :         280 : mio_omp_udr_expr (gfc_omp_udr *udr, gfc_symbol **sym1, gfc_symbol **sym2,
    4488                 :             :                   gfc_namespace *ns, bool is_initializer)
    4489                 :             : {
    4490                 :         280 :   if (iomode == IO_OUTPUT)
    4491                 :             :     {
    4492                 :         136 :       if ((*sym1)->module == NULL)
    4493                 :             :         {
    4494                 :         100 :           (*sym1)->module = module_name;
    4495                 :         100 :           (*sym2)->module = module_name;
    4496                 :             :         }
    4497                 :         136 :       mio_symbol_ref (sym1);
    4498                 :         136 :       mio_symbol_ref (sym2);
    4499                 :         136 :       if (ns->code->op == EXEC_ASSIGN)
    4500                 :             :         {
    4501                 :          82 :           mio_name (0, omp_declare_reduction_stmt);
    4502                 :          82 :           mio_expr (&ns->code->expr1);
    4503                 :          82 :           mio_expr (&ns->code->expr2);
    4504                 :             :         }
    4505                 :             :       else
    4506                 :             :         {
    4507                 :          54 :           int flag;
    4508                 :          54 :           mio_name (1, omp_declare_reduction_stmt);
    4509                 :          54 :           mio_symtree_ref (&ns->code->symtree);
    4510                 :          54 :           mio_actual_arglist (&ns->code->ext.actual, false);
    4511                 :             : 
    4512                 :          54 :           flag = ns->code->resolved_isym != NULL;
    4513                 :          54 :           mio_integer (&flag);
    4514                 :          54 :           if (flag)
    4515                 :           0 :             write_atom (ATOM_STRING, ns->code->resolved_isym->name);
    4516                 :             :           else
    4517                 :          54 :             mio_symbol_ref (&ns->code->resolved_sym);
    4518                 :             :         }
    4519                 :             :     }
    4520                 :             :   else
    4521                 :             :     {
    4522                 :         144 :       pointer_info *p1 = mio_symbol_ref (sym1);
    4523                 :         144 :       pointer_info *p2 = mio_symbol_ref (sym2);
    4524                 :         144 :       gfc_symbol *sym;
    4525                 :         144 :       gcc_assert (p1->u.rsym.ns == p2->u.rsym.ns);
    4526                 :         144 :       gcc_assert (p1->u.rsym.sym == NULL);
    4527                 :             :       /* Add hidden symbols to the symtree.  */
    4528                 :         144 :       pointer_info *q = get_integer (p1->u.rsym.ns);
    4529                 :         144 :       q->u.pointer = (void *) ns;
    4530                 :         222 :       sym = gfc_new_symbol (is_initializer ? "omp_priv" : "omp_out", ns);
    4531                 :         144 :       sym->ts = udr->ts;
    4532                 :         144 :       sym->module = gfc_get_string ("%s", p1->u.rsym.module);
    4533                 :         144 :       associate_integer_pointer (p1, sym);
    4534                 :         144 :       sym->attr.omp_udr_artificial_var = 1;
    4535                 :         144 :       gcc_assert (p2->u.rsym.sym == NULL);
    4536                 :         222 :       sym = gfc_new_symbol (is_initializer ? "omp_orig" : "omp_in", ns);
    4537                 :         144 :       sym->ts = udr->ts;
    4538                 :         144 :       sym->module = gfc_get_string ("%s", p2->u.rsym.module);
    4539                 :         144 :       associate_integer_pointer (p2, sym);
    4540                 :         144 :       sym->attr.omp_udr_artificial_var = 1;
    4541                 :         144 :       if (mio_name (0, omp_declare_reduction_stmt) == 0)
    4542                 :             :         {
    4543                 :          90 :           ns->code = gfc_get_code (EXEC_ASSIGN);
    4544                 :          90 :           mio_expr (&ns->code->expr1);
    4545                 :          90 :           mio_expr (&ns->code->expr2);
    4546                 :             :         }
    4547                 :             :       else
    4548                 :             :         {
    4549                 :          54 :           int flag;
    4550                 :          54 :           ns->code = gfc_get_code (EXEC_CALL);
    4551                 :          54 :           mio_symtree_ref (&ns->code->symtree);
    4552                 :          54 :           mio_actual_arglist (&ns->code->ext.actual, false);
    4553                 :             : 
    4554                 :          54 :           mio_integer (&flag);
    4555                 :          54 :           if (flag)
    4556                 :             :             {
    4557                 :           0 :               require_atom (ATOM_STRING);
    4558                 :           0 :               ns->code->resolved_isym = gfc_find_subroutine (atom_string);
    4559                 :           0 :               free (atom_string);
    4560                 :             :             }
    4561                 :             :           else
    4562                 :          54 :             mio_symbol_ref (&ns->code->resolved_sym);
    4563                 :             :         }
    4564                 :         144 :       ns->code->loc = gfc_current_locus;
    4565                 :         144 :       ns->omp_udr_ns = 1;
    4566                 :             :     }
    4567                 :         280 : }
    4568                 :             : 
    4569                 :             : 
    4570                 :             : /* Unlike most other routines, the address of the symbol node is already
    4571                 :             :    fixed on input and the name/module has already been filled in.
    4572                 :             :    If you update the symbol format here, don't forget to update read_module
    4573                 :             :    as well (look for "seek to the symbol's component list").   */
    4574                 :             : 
    4575                 :             : static void
    4576                 :      961510 : mio_symbol (gfc_symbol *sym)
    4577                 :             : {
    4578                 :      961510 :   int intmod = INTMOD_NONE;
    4579                 :             : 
    4580                 :      961510 :   mio_lparen ();
    4581                 :             : 
    4582                 :      961510 :   mio_symbol_attribute (&sym->attr);
    4583                 :             : 
    4584                 :      961510 :   if (sym->attr.pdt_type)
    4585                 :         112 :     sym->name = gfc_dt_upper_string (sym->name);
    4586                 :             : 
    4587                 :             :   /* Note that components are always saved, even if they are supposed
    4588                 :             :      to be private.  Component access is checked during searching.  */
    4589                 :      961510 :   mio_component_list (&sym->components, sym->attr.vtype);
    4590                 :      961510 :   if (sym->components != NULL)
    4591                 :       61760 :     sym->component_access
    4592                 :       61760 :       = MIO_NAME (gfc_access) (sym->component_access, access_types);
    4593                 :             : 
    4594                 :      961510 :   mio_typespec (&sym->ts);
    4595                 :      961510 :   if (sym->ts.type == BT_CLASS)
    4596                 :       13369 :     sym->attr.class_ok = 1;
    4597                 :             : 
    4598                 :      961510 :   if (iomode == IO_OUTPUT)
    4599                 :      199542 :     mio_namespace_ref (&sym->formal_ns);
    4600                 :             :   else
    4601                 :             :     {
    4602                 :      761968 :       mio_namespace_ref (&sym->formal_ns);
    4603                 :      761968 :       if (sym->formal_ns)
    4604                 :      184995 :         sym->formal_ns->proc_name = sym;
    4605                 :             :     }
    4606                 :             : 
    4607                 :             :   /* Save/restore common block links.  */
    4608                 :      961510 :   mio_symbol_ref (&sym->common_next);
    4609                 :             : 
    4610                 :      961510 :   mio_formal_arglist (&sym->formal);
    4611                 :             : 
    4612                 :      961510 :   if (sym->attr.flavor == FL_PARAMETER)
    4613                 :      134455 :     mio_expr (&sym->value);
    4614                 :             : 
    4615                 :      961510 :   mio_array_spec (&sym->as);
    4616                 :             : 
    4617                 :      961510 :   mio_symbol_ref (&sym->result);
    4618                 :             : 
    4619                 :      961510 :   if (sym->attr.cray_pointee)
    4620                 :          26 :     mio_symbol_ref (&sym->cp_pointer);
    4621                 :             : 
    4622                 :             :   /* Load/save the f2k_derived namespace of a derived-type symbol.  */
    4623                 :      961510 :   mio_full_f2k_derived (sym);
    4624                 :             : 
    4625                 :             :   /* PDT types store the symbol specification list here. */
    4626                 :      961510 :   mio_actual_arglist (&sym->param_list, true);
    4627                 :             : 
    4628                 :      961510 :   mio_namelist (sym);
    4629                 :             : 
    4630                 :             :   /* Add the fields that say whether this is from an intrinsic module,
    4631                 :             :      and if so, what symbol it is within the module.  */
    4632                 :             : /*   mio_integer (&(sym->from_intmod)); */
    4633                 :      961510 :   if (iomode == IO_OUTPUT)
    4634                 :             :     {
    4635                 :      199542 :       intmod = sym->from_intmod;
    4636                 :      199542 :       mio_integer (&intmod);
    4637                 :             :     }
    4638                 :             :   else
    4639                 :             :     {
    4640                 :      761968 :       mio_integer (&intmod);
    4641                 :      761968 :       if (current_intmod)
    4642                 :      271334 :         sym->from_intmod = current_intmod;
    4643                 :             :       else
    4644                 :      490634 :         sym->from_intmod = (intmod_id) intmod;
    4645                 :             :     }
    4646                 :             : 
    4647                 :      961510 :   mio_integer (&(sym->intmod_sym_id));
    4648                 :             : 
    4649                 :      961510 :   if (gfc_fl_struct (sym->attr.flavor))
    4650                 :       64756 :     mio_integer (&(sym->hash_value));
    4651                 :             : 
    4652                 :      961510 :   if (sym->formal_ns
    4653                 :      209132 :       && sym->formal_ns->proc_name == sym
    4654                 :      208735 :       && sym->formal_ns->entries == NULL)
    4655                 :      208735 :     mio_omp_declare_simd (sym->formal_ns, &sym->formal_ns->omp_declare_simd);
    4656                 :             : 
    4657                 :      961510 :   mio_rparen ();
    4658                 :      961510 : }
    4659                 :             : 
    4660                 :             : 
    4661                 :             : /************************* Top level subroutines *************************/
    4662                 :             : 
    4663                 :             : /* A recursive function to look for a specific symbol by name and by
    4664                 :             :    module.  Whilst several symtrees might point to one symbol, its
    4665                 :             :    is sufficient for the purposes here than one exist.  Note that
    4666                 :             :    generic interfaces are distinguished as are symbols that have been
    4667                 :             :    renamed in another module.  */
    4668                 :             : static gfc_symtree *
    4669                 :    23668578 : find_symbol (gfc_symtree *st, const char *name,
    4670                 :             :              const char *module, int generic)
    4671                 :             : {
    4672                 :    46993980 :   int c;
    4673                 :    46993980 :   gfc_symtree *retval, *s;
    4674                 :             : 
    4675                 :    46993980 :   if (st == NULL || st->n.sym == NULL)
    4676                 :             :     return NULL;
    4677                 :             : 
    4678                 :    23327922 :   c = strcmp (name, st->n.sym->name);
    4679                 :       85609 :   if (c == 0 && st->n.sym->module
    4680                 :       85603 :              && strcmp (module, st->n.sym->module) == 0
    4681                 :    23360569 :              && !check_unique_name (st->name))
    4682                 :             :     {
    4683                 :       32563 :       s = gfc_find_symtree (gfc_current_ns->sym_root, name);
    4684                 :             : 
    4685                 :             :       /* Detect symbols that are renamed by use association in another
    4686                 :             :          module by the absence of a symtree and null attr.use_rename,
    4687                 :             :          since the latter is not transmitted in the module file.  */
    4688                 :       32563 :       if (((!generic && !st->n.sym->attr.generic)
    4689                 :       25109 :                 || (generic && st->n.sym->attr.generic))
    4690                 :        7498 :             && !(s == NULL && !st->n.sym->attr.use_rename))
    4691                 :             :         return st;
    4692                 :             :     }
    4693                 :             : 
    4694                 :    23327333 :   retval = find_symbol (st->left, name, module, generic);
    4695                 :             : 
    4696                 :    23327333 :   if (retval == NULL)
    4697                 :    23325402 :     retval = find_symbol (st->right, name, module, generic);
    4698                 :             : 
    4699                 :             :   return retval;
    4700                 :             : }
    4701                 :             : 
    4702                 :             : 
    4703                 :             : /* Skip a list between balanced left and right parens.
    4704                 :             :    By setting NEST_LEVEL one assumes that a number of NEST_LEVEL opening parens
    4705                 :             :    have been already parsed by hand, and the remaining of the content is to be
    4706                 :             :    skipped here.  The default value is 0 (balanced parens).  */
    4707                 :             : 
    4708                 :             : static void
    4709                 :     1068864 : skip_list (int nest_level = 0)
    4710                 :             : {
    4711                 :     1068864 :   int level;
    4712                 :             : 
    4713                 :     1068864 :   level = nest_level;
    4714                 :    49611065 :   do
    4715                 :             :     {
    4716                 :    49611065 :       switch (parse_atom ())
    4717                 :             :         {
    4718                 :    12264774 :         case ATOM_LPAREN:
    4719                 :    12264774 :           level++;
    4720                 :    12264774 :           break;
    4721                 :             : 
    4722                 :    12280292 :         case ATOM_RPAREN:
    4723                 :    12280292 :           level--;
    4724                 :    12280292 :           break;
    4725                 :             : 
    4726                 :      525964 :         case ATOM_STRING:
    4727                 :      525964 :           free (atom_string);
    4728                 :      525964 :           break;
    4729                 :             : 
    4730                 :             :         case ATOM_NAME:
    4731                 :             :         case ATOM_INTEGER:
    4732                 :             :           break;
    4733                 :             :         }
    4734                 :             :     }
    4735                 :    49611065 :   while (level > 0);
    4736                 :     1068864 : }
    4737                 :             : 
    4738                 :             : 
    4739                 :             : /* Load operator interfaces from the module.  Interfaces are unusual
    4740                 :             :    in that they attach themselves to existing symbols.  */
    4741                 :             : 
    4742                 :             : static void
    4743                 :       11892 : load_operator_interfaces (void)
    4744                 :             : {
    4745                 :       11892 :   const char *p;
    4746                 :             :   /* "module" must be large enough for the case of submodules in which the name
    4747                 :             :      has the form module.submodule */
    4748                 :       11892 :   char name[GFC_MAX_SYMBOL_LEN + 1], module[2 * GFC_MAX_SYMBOL_LEN + 2];
    4749                 :       11892 :   gfc_user_op *uop;
    4750                 :       11892 :   pointer_info *pi = NULL;
    4751                 :       11892 :   int n, i;
    4752                 :             : 
    4753                 :       11892 :   mio_lparen ();
    4754                 :             : 
    4755                 :       23935 :   while (peek_atom () != ATOM_RPAREN)
    4756                 :             :     {
    4757                 :         151 :       mio_lparen ();
    4758                 :             : 
    4759                 :         151 :       mio_internal_string (name);
    4760                 :         151 :       mio_internal_string (module);
    4761                 :             : 
    4762                 :         151 :       n = number_use_names (name, true);
    4763                 :         151 :       n = n ? n : 1;
    4764                 :             : 
    4765                 :         320 :       for (i = 1; i <= n; i++)
    4766                 :             :         {
    4767                 :             :           /* Decide if we need to load this one or not.  */
    4768                 :         169 :           p = find_use_name_n (name, &i, true);
    4769                 :             : 
    4770                 :         169 :           if (p == NULL)
    4771                 :             :             {
    4772                 :          14 :               while (parse_atom () != ATOM_RPAREN);
    4773                 :           7 :               continue;
    4774                 :             :             }
    4775                 :             : 
    4776                 :         162 :           if (i == 1)
    4777                 :             :             {
    4778                 :         144 :               uop = gfc_get_uop (p);
    4779                 :         144 :               pi = mio_interface_rest (&uop->op);
    4780                 :             :             }
    4781                 :             :           else
    4782                 :             :             {
    4783                 :          18 :               if (gfc_find_uop (p, NULL))
    4784                 :           6 :                 continue;
    4785                 :          12 :               uop = gfc_get_uop (p);
    4786                 :          12 :               uop->op = gfc_get_interface ();
    4787                 :          12 :               uop->op->where = gfc_current_locus;
    4788                 :          12 :               add_fixup (pi->integer, &uop->op->sym);
    4789                 :             :             }
    4790                 :             :         }
    4791                 :             :     }
    4792                 :             : 
    4793                 :       11892 :   mio_rparen ();
    4794                 :       11892 : }
    4795                 :             : 
    4796                 :             : 
    4797                 :             : /* Load interfaces from the module.  Interfaces are unusual in that
    4798                 :             :    they attach themselves to existing symbols.  */
    4799                 :             : 
    4800                 :             : static void
    4801                 :       11892 : load_generic_interfaces (void)
    4802                 :             : {
    4803                 :       11892 :   const char *p;
    4804                 :             :   /* "module" must be large enough for the case of submodules in which the name
    4805                 :             :      has the form module.submodule */
    4806                 :       11892 :   char name[GFC_MAX_SYMBOL_LEN + 1], module[2 * GFC_MAX_SYMBOL_LEN + 2];
    4807                 :       11892 :   gfc_symbol *sym;
    4808                 :       11892 :   gfc_interface *generic = NULL, *gen = NULL;
    4809                 :       11892 :   int n, i, renamed;
    4810                 :       11892 :   bool ambiguous_set = false;
    4811                 :             : 
    4812                 :       11892 :   mio_lparen ();
    4813                 :             : 
    4814                 :       72057 :   while (peek_atom () != ATOM_RPAREN)
    4815                 :             :     {
    4816                 :       48273 :       mio_lparen ();
    4817                 :             : 
    4818                 :       48273 :       mio_internal_string (name);
    4819                 :       48273 :       mio_internal_string (module);
    4820                 :             : 
    4821                 :       48273 :       n = number_use_names (name, false);
    4822                 :       48273 :       renamed = n ? 1 : 0;
    4823                 :       47567 :       n = n ? n : 1;
    4824                 :             : 
    4825                 :       96550 :       for (i = 1; i <= n; i++)
    4826                 :             :         {
    4827                 :       48277 :           gfc_symtree *st;
    4828                 :             :           /* Decide if we need to load this one or not.  */
    4829                 :       48277 :           p = find_use_name_n (name, &i, false);
    4830                 :             : 
    4831                 :       48277 :           if (!p || gfc_find_symbol (p, NULL, 0, &sym))
    4832                 :             :             {
    4833                 :             :               /* Skip the specific names for these cases.  */
    4834                 :        9105 :               while (i == 1 && parse_atom () != ATOM_RPAREN);
    4835                 :             : 
    4836                 :        1628 :               continue;
    4837                 :             :             }
    4838                 :             : 
    4839                 :       46649 :           st = find_symbol (gfc_current_ns->sym_root,
    4840                 :             :                             name, module_name, 1);
    4841                 :             : 
    4842                 :             :           /* If the symbol exists already and is being USEd without being
    4843                 :             :              in an ONLY clause, do not load a new symtree(11.3.2).  */
    4844                 :       46649 :           if (!only_flag && st)
    4845                 :          43 :             sym = st->n.sym;
    4846                 :             : 
    4847                 :       46649 :           if (!sym)
    4848                 :             :             {
    4849                 :       23975 :               if (st)
    4850                 :             :                 {
    4851                 :           1 :                   sym = st->n.sym;
    4852                 :           1 :                   if (strcmp (st->name, p) != 0)
    4853                 :             :                     {
    4854                 :           1 :                       st = gfc_new_symtree (&gfc_current_ns->sym_root, p);
    4855                 :           1 :                       st->n.sym = sym;
    4856                 :           1 :                       sym->refs++;
    4857                 :             :                     }
    4858                 :             :                 }
    4859                 :             : 
    4860                 :             :               /* Since we haven't found a valid generic interface, we had
    4861                 :             :                  better make one.  */
    4862                 :       23975 :               if (!sym)
    4863                 :             :                 {
    4864                 :       23974 :                   gfc_get_symbol (p, NULL, &sym);
    4865                 :       23974 :                   sym->name = gfc_get_string ("%s", name);
    4866                 :       23974 :                   sym->module = module_name;
    4867                 :       23974 :                   sym->attr.flavor = FL_PROCEDURE;
    4868                 :       23974 :                   sym->attr.generic = 1;
    4869                 :       23974 :                   sym->attr.use_assoc = 1;
    4870                 :             :                 }
    4871                 :             :             }
    4872                 :             :           else
    4873                 :             :             {
    4874                 :             :               /* Unless sym is a generic interface, this reference
    4875                 :             :                  is ambiguous.  */
    4876                 :       22674 :               if (st == NULL)
    4877                 :       22630 :                 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
    4878                 :             : 
    4879                 :       22674 :               sym = st->n.sym;
    4880                 :             : 
    4881                 :       22674 :               if (st && !sym->attr.generic
    4882                 :       20372 :                      && !st->ambiguous
    4883                 :       20372 :                      && sym->module
    4884                 :       20371 :                      && strcmp (module, sym->module))
    4885                 :             :                 {
    4886                 :           1 :                   ambiguous_set = true;
    4887                 :           1 :                   st->ambiguous = 1;
    4888                 :             :                 }
    4889                 :             :             }
    4890                 :             : 
    4891                 :       46649 :           sym->attr.use_only = only_flag;
    4892                 :       46649 :           sym->attr.use_rename = renamed;
    4893                 :             : 
    4894                 :       46649 :           if (i == 1)
    4895                 :             :             {
    4896                 :       46645 :               mio_interface_rest (&sym->generic);
    4897                 :       46645 :               generic = sym->generic;
    4898                 :             :             }
    4899                 :           4 :           else if (!sym->generic)
    4900                 :             :             {
    4901                 :           0 :               sym->generic = generic;
    4902                 :           0 :               sym->attr.generic_copy = 1;
    4903                 :             :             }
    4904                 :             : 
    4905                 :             :           /* If a procedure that is not generic has generic interfaces
    4906                 :             :              that include itself, it is generic! We need to take care
    4907                 :             :              to retain symbols ambiguous that were already so.  */
    4908                 :       46649 :           if (sym->attr.use_assoc
    4909                 :       46649 :                 && !sym->attr.generic
    4910                 :           2 :                 && sym->attr.flavor == FL_PROCEDURE)
    4911                 :             :             {
    4912                 :           4 :               for (gen = generic; gen; gen = gen->next)
    4913                 :             :                 {
    4914                 :           3 :                   if (gen->sym == sym)
    4915                 :             :                     {
    4916                 :           1 :                       sym->attr.generic = 1;
    4917                 :           1 :                       if (ambiguous_set)
    4918                 :           0 :                         st->ambiguous = 0;
    4919                 :             :                       break;
    4920                 :             :                     }
    4921                 :             :                 }
    4922                 :             :             }
    4923                 :             : 
    4924                 :             :         }
    4925                 :             :     }
    4926                 :             : 
    4927                 :       11892 :   mio_rparen ();
    4928                 :       11892 : }
    4929                 :             : 
    4930                 :             : 
    4931                 :             : /* Load common blocks.  */
    4932                 :             : 
    4933                 :             : static void
    4934                 :       11892 : load_commons (void)
    4935                 :             : {
    4936                 :       11892 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    4937                 :       11892 :   gfc_common_head *p;
    4938                 :             : 
    4939                 :       11892 :   mio_lparen ();
    4940                 :             : 
    4941                 :       23954 :   while (peek_atom () != ATOM_RPAREN)
    4942                 :             :     {
    4943                 :         170 :       int flags = 0;
    4944                 :         170 :       char* label;
    4945                 :         170 :       mio_lparen ();
    4946                 :         170 :       mio_internal_string (name);
    4947                 :             : 
    4948                 :         170 :       p = gfc_get_common (name, 1);
    4949                 :             : 
    4950                 :         170 :       mio_symbol_ref (&p->head);
    4951                 :         170 :       mio_integer (&flags);
    4952                 :         170 :       if (flags & 1)
    4953                 :           0 :         p->saved = 1;
    4954                 :         170 :       if (flags & 2)
    4955                 :           0 :         p->threadprivate = 1;
    4956                 :         170 :       p->omp_device_type = (gfc_omp_device_type) ((flags >> 2) & 3);
    4957                 :         170 :       p->use_assoc = 1;
    4958                 :             : 
    4959                 :             :       /* Get whether this was a bind(c) common or not.  */
    4960                 :         170 :       mio_integer (&p->is_bind_c);
    4961                 :             :       /* Get the binding label.  */
    4962                 :         170 :       label = read_string ();
    4963                 :         170 :       if (strlen (label))
    4964                 :          22 :         p->binding_label = IDENTIFIER_POINTER (get_identifier (label));
    4965                 :         170 :       XDELETEVEC (label);
    4966                 :             : 
    4967                 :         170 :       mio_rparen ();
    4968                 :             :     }
    4969                 :             : 
    4970                 :       11892 :   mio_rparen ();
    4971                 :       11892 : }
    4972                 :             : 
    4973                 :             : 
    4974                 :             : /* Load equivalences.  The flag in_load_equiv informs mio_expr_ref of this
    4975                 :             :    so that unused variables are not loaded and so that the expression can
    4976                 :             :    be safely freed.  */
    4977                 :             : 
    4978                 :             : static void
    4979                 :       11892 : load_equiv (void)
    4980                 :             : {
    4981                 :       11892 :   gfc_equiv *head, *tail, *end, *eq, *equiv;
    4982                 :       11892 :   bool duplicate;
    4983                 :             : 
    4984                 :       11892 :   mio_lparen ();
    4985                 :       11892 :   in_load_equiv = true;
    4986                 :             : 
    4987                 :       11892 :   end = gfc_current_ns->equiv;
    4988                 :       11898 :   while (end != NULL && end->next != NULL)
    4989                 :             :     end = end->next;
    4990                 :             : 
    4991                 :       12025 :   while (peek_atom () != ATOM_RPAREN) {
    4992                 :         133 :     mio_lparen ();
    4993                 :         133 :     head = tail = NULL;
    4994                 :             : 
    4995                 :         532 :     while(peek_atom () != ATOM_RPAREN)
    4996                 :             :       {
    4997                 :         266 :         if (head == NULL)
    4998                 :         133 :           head = tail = gfc_get_equiv ();
    4999                 :             :         else
    5000                 :             :           {
    5001                 :         133 :             tail->eq = gfc_get_equiv ();
    5002                 :         133 :             tail = tail->eq;
    5003                 :             :           }
    5004                 :             : 
    5005                 :         266 :         mio_pool_string (&tail->module);
    5006                 :         266 :         mio_expr (&tail->expr);
    5007                 :             :       }
    5008                 :             : 
    5009                 :             :     /* Check for duplicate equivalences being loaded from different modules */
    5010                 :         133 :     duplicate = false;
    5011                 :         192 :     for (equiv = gfc_current_ns->equiv; equiv; equiv = equiv->next)
    5012                 :             :       {
    5013                 :          65 :         if (equiv->module && head->module
    5014                 :          65 :             && strcmp (equiv->module, head->module) == 0)
    5015                 :             :           {
    5016                 :             :             duplicate = true;
    5017                 :             :             break;
    5018                 :             :           }
    5019                 :             :       }
    5020                 :             : 
    5021                 :         133 :     if (duplicate)
    5022                 :             :       {
    5023                 :          18 :         for (eq = head; eq; eq = head)
    5024                 :             :           {
    5025                 :          12 :             head = eq->eq;
    5026                 :          12 :             gfc_free_expr (eq->expr);
    5027                 :          12 :             free (eq);
    5028                 :             :           }
    5029                 :             :       }
    5030                 :             : 
    5031                 :         133 :     if (end == NULL)
    5032                 :          80 :       gfc_current_ns->equiv = head;
    5033                 :             :     else
    5034                 :          53 :       end->next = head;
    5035                 :             : 
    5036                 :         133 :     if (head != NULL)
    5037                 :         127 :       end = head;
    5038                 :             : 
    5039                 :         133 :     mio_rparen ();
    5040                 :             :   }
    5041                 :             : 
    5042                 :       11892 :   mio_rparen ();
    5043                 :       11892 :   in_load_equiv = false;
    5044                 :       11892 : }
    5045                 :             : 
    5046                 :             : 
    5047                 :             : /* This function loads OpenMP user defined reductions.  */
    5048                 :             : static void
    5049                 :       11892 : load_omp_udrs (void)
    5050                 :             : {
    5051                 :       11892 :   mio_lparen ();
    5052                 :       23866 :   while (peek_atom () != ATOM_RPAREN)
    5053                 :             :     {
    5054                 :          82 :       const char *name = NULL, *newname;
    5055                 :          82 :       char *altname;
    5056                 :          82 :       gfc_typespec ts;
    5057                 :          82 :       gfc_symtree *st;
    5058                 :          82 :       gfc_omp_reduction_op rop = OMP_REDUCTION_USER;
    5059                 :             : 
    5060                 :          82 :       mio_lparen ();
    5061                 :          82 :       mio_pool_string (&name);
    5062                 :          82 :       gfc_clear_ts (&ts);
    5063                 :          82 :       mio_typespec (&ts);
    5064                 :          82 :       if (startswith (name, "operator "))
    5065                 :             :         {
    5066                 :          32 :           const char *p = name + sizeof ("operator ") - 1;
    5067                 :          32 :           if (strcmp (p, "+") == 0)
    5068                 :             :             rop = OMP_REDUCTION_PLUS;
    5069                 :           0 :           else if (strcmp (p, "*") == 0)
    5070                 :             :             rop = OMP_REDUCTION_TIMES;
    5071                 :           0 :           else if (strcmp (p, "-") == 0)
    5072                 :             :             rop = OMP_REDUCTION_MINUS;
    5073                 :           0 :           else if (strcmp (p, ".and.") == 0)
    5074                 :             :             rop = OMP_REDUCTION_AND;
    5075                 :           0 :           else if (strcmp (p, ".or.") == 0)
    5076                 :             :             rop = OMP_REDUCTION_OR;
    5077                 :           0 :           else if (strcmp (p, ".eqv.") == 0)
    5078                 :             :             rop = OMP_REDUCTION_EQV;
    5079                 :           0 :           else if (strcmp (p, ".neqv.") == 0)
    5080                 :             :             rop = OMP_REDUCTION_NEQV;
    5081                 :             :         }
    5082                 :          50 :       altname = NULL;
    5083                 :          50 :       if (rop == OMP_REDUCTION_USER && name[0] == '.')
    5084                 :             :         {
    5085                 :          50 :           size_t len = strlen (name + 1);
    5086                 :          50 :           altname = XALLOCAVEC (char, len);
    5087                 :          50 :           gcc_assert (name[len] == '.');
    5088                 :          50 :           memcpy (altname, name + 1, len - 1);
    5089                 :          50 :           altname[len - 1] = '\0';
    5090                 :             :         }
    5091                 :          82 :       newname = name;
    5092                 :          82 :       if (rop == OMP_REDUCTION_USER)
    5093                 :         100 :         newname = find_use_name (altname ? altname : name, !!altname);
    5094                 :          38 :       else if (only_flag && find_use_operator ((gfc_intrinsic_op) rop) == NULL)
    5095                 :             :         newname = NULL;
    5096                 :          82 :       if (newname == NULL)
    5097                 :             :         {
    5098                 :           0 :           skip_list (1);
    5099                 :           4 :           continue;
    5100                 :             :         }
    5101                 :          82 :       if (altname && newname != altname)
    5102                 :             :         {
    5103                 :          18 :           size_t len = strlen (newname);
    5104                 :          18 :           altname = XALLOCAVEC (char, len + 3);
    5105                 :          18 :           altname[0] = '.';
    5106                 :          18 :           memcpy (altname + 1, newname, len);
    5107                 :          18 :           altname[len + 1] = '.';
    5108                 :          18 :           altname[len + 2] = '\0';
    5109                 :          18 :           name = gfc_get_string ("%s", altname);
    5110                 :             :         }
    5111                 :          82 :       st = gfc_find_symtree (gfc_current_ns->omp_udr_root, name);
    5112                 :          82 :       gfc_omp_udr *udr = gfc_omp_udr_find (st, &ts);
    5113                 :          82 :       if (udr)
    5114                 :             :         {
    5115                 :           4 :           require_atom (ATOM_INTEGER);
    5116                 :           4 :           pointer_info *p = get_integer (atom_int);
    5117                 :           4 :           if (strcmp (p->u.rsym.module, udr->omp_out->module))
    5118                 :             :             {
    5119                 :           4 :               gfc_error ("Ambiguous !$OMP DECLARE REDUCTION from "
    5120                 :             :                          "module %s at %L",
    5121                 :             :                          p->u.rsym.module, &gfc_current_locus);
    5122                 :           4 :               gfc_error ("Previous !$OMP DECLARE REDUCTION from module "
    5123                 :             :                          "%s at %L",
    5124                 :           4 :                          udr->omp_out->module, &udr->where);
    5125                 :             :             }
    5126                 :           4 :           skip_list (1);
    5127                 :           4 :           continue;
    5128                 :           4 :         }
    5129                 :          78 :       udr = gfc_get_omp_udr ();
    5130                 :          78 :       udr->name = name;
    5131                 :          78 :       udr->rop = rop;
    5132                 :          78 :       udr->ts = ts;
    5133                 :          78 :       udr->where = gfc_current_locus;
    5134                 :          78 :       udr->combiner_ns = gfc_get_namespace (gfc_current_ns, 1);
    5135                 :          78 :       udr->combiner_ns->proc_name = gfc_current_ns->proc_name;
    5136                 :          78 :       mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns,
    5137                 :             :                         false);
    5138                 :          78 :       if (peek_atom () != ATOM_RPAREN)
    5139                 :             :         {
    5140                 :          66 :           udr->initializer_ns = gfc_get_namespace (gfc_current_ns, 1);
    5141                 :          66 :           udr->initializer_ns->proc_name = gfc_current_ns->proc_name;
    5142                 :          66 :           mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig,
    5143                 :             :                             udr->initializer_ns, true);
    5144                 :             :         }
    5145                 :          78 :       if (st)
    5146                 :             :         {
    5147                 :           0 :           udr->next = st->n.omp_udr;
    5148                 :           0 :           st->n.omp_udr = udr;
    5149                 :             :         }
    5150                 :             :       else
    5151                 :             :         {
    5152                 :          78 :           st = gfc_new_symtree (&gfc_current_ns->omp_udr_root, name);
    5153                 :          78 :           st->n.omp_udr = udr;
    5154                 :             :         }
    5155                 :          78 :       mio_rparen ();
    5156                 :             :     }
    5157                 :       11892 :   mio_rparen ();
    5158                 :       11892 : }
    5159                 :             : 
    5160                 :             : 
    5161                 :             : /* Recursive function to traverse the pointer_info tree and load a
    5162                 :             :    needed symbol.  We return nonzero if we load a symbol and stop the
    5163                 :             :    traversal, because the act of loading can alter the tree.  */
    5164                 :             : 
    5165                 :             : static int
    5166                 :     7522741 : load_needed (pointer_info *p)
    5167                 :             : {
    5168                 :     7522741 :   gfc_namespace *ns;
    5169                 :     7522741 :   pointer_info *q;
    5170                 :     7522741 :   gfc_symbol *sym;
    5171                 :     7522741 :   int rv;
    5172                 :             : 
    5173                 :     7522741 :   rv = 0;
    5174                 :     7522741 :   if (p == NULL)
    5175                 :             :     return rv;
    5176                 :             : 
    5177                 :     3744968 :   rv |= load_needed (p->left);
    5178                 :     3744968 :   rv |= load_needed (p->right);
    5179                 :             : 
    5180                 :     3744968 :   if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED)
    5181                 :             :     return rv;
    5182                 :             : 
    5183                 :      761968 :   p->u.rsym.state = USED;
    5184                 :             : 
    5185                 :      761968 :   set_module_locus (&p->u.rsym.where);
    5186                 :             : 
    5187                 :      761968 :   sym = p->u.rsym.sym;
    5188                 :      761968 :   if (sym == NULL)
    5189                 :             :     {
    5190                 :      493563 :       q = get_integer (p->u.rsym.ns);
    5191                 :             : 
    5192                 :      493563 :       ns = (gfc_namespace *) q->u.pointer;
    5193                 :      493563 :       if (ns == NULL)
    5194                 :             :         {
    5195                 :             :           /* Create an interface namespace if necessary.  These are
    5196                 :             :              the namespaces that hold the formal parameters of module
    5197                 :             :              procedures.  */
    5198                 :             : 
    5199                 :       18055 :           ns = gfc_get_namespace (NULL, 0);
    5200                 :       18055 :           associate_integer_pointer (q, ns);
    5201                 :             :         }
    5202                 :             : 
    5203                 :             :       /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
    5204                 :             :          doesn't go pear-shaped if the symbol is used.  */
    5205                 :      493563 :       if (!ns->proc_name)
    5206                 :       25344 :         gfc_find_symbol (p->u.rsym.module, gfc_current_ns,
    5207                 :             :                                  1, &ns->proc_name);
    5208                 :             : 
    5209                 :      493563 :       sym = gfc_new_symbol (p->u.rsym.true_name, ns);
    5210                 :      493563 :       sym->name = gfc_dt_lower_string (p->u.rsym.true_name);
    5211                 :      493563 :       sym->module = gfc_get_string ("%s", p->u.rsym.module);
    5212                 :      493563 :       if (p->u.rsym.binding_label)
    5213                 :          19 :         sym->binding_label = IDENTIFIER_POINTER (get_identifier
    5214                 :             :                                                  (p->u.rsym.binding_label));
    5215                 :             : 
    5216                 :      493563 :       associate_integer_pointer (p, sym);
    5217                 :             :     }
    5218                 :             : 
    5219                 :      761968 :   mio_symbol (sym);
    5220                 :      761968 :   sym->attr.use_assoc = 1;
    5221                 :             : 
    5222                 :             :   /* Unliked derived types, a STRUCTURE may share names with other symbols.
    5223                 :             :      We greedily converted the symbol name to lowercase before we knew its
    5224                 :             :      type, so now we must fix it. */
    5225                 :      761968 :   if (sym->attr.flavor == FL_STRUCT)
    5226                 :          60 :     sym->name = gfc_dt_upper_string (sym->name);
    5227                 :             : 
    5228                 :             :   /* Mark as only or rename for later diagnosis for explicitly imported
    5229                 :             :      but not used warnings; don't mark internal symbols such as __vtab,
    5230                 :             :      __def_init etc. Only mark them if they have been explicitly loaded.  */
    5231                 :             : 
    5232                 :      761968 :   if (only_flag && sym->name[0] != '_' && sym->name[1] != '_')
    5233                 :             :     {
    5234                 :       10735 :       gfc_use_rename *u;
    5235                 :             : 
    5236                 :             :       /* Search the use/rename list for the variable; if the variable is
    5237                 :             :          found, mark it.  */
    5238                 :       26735 :       for (u = gfc_rename_list; u; u = u->next)
    5239                 :             :         {
    5240                 :       18695 :           if (strcmp (u->use_name, sym->name) == 0)
    5241                 :             :             {
    5242                 :        2695 :               sym->attr.use_only = 1;
    5243                 :        2695 :               break;
    5244                 :             :             }
    5245                 :             :         }
    5246                 :             :     }
    5247                 :             : 
    5248                 :      761968 :   if (p->u.rsym.renamed)
    5249                 :        3081 :     sym->attr.use_rename = 1;
    5250                 :             : 
    5251                 :             :   return 1;
    5252                 :             : }
    5253                 :             : 
    5254                 :             : 
    5255                 :             : /* Recursive function for cleaning up things after a module has been read.  */
    5256                 :             : 
    5257                 :             : static void
    5258                 :     2629436 : read_cleanup (pointer_info *p)
    5259                 :             : {
    5260                 :     2629436 :   gfc_symtree *st;
    5261                 :     2629436 :   pointer_info *q;
    5262                 :             : 
    5263                 :     2629436 :   if (p == NULL)
    5264                 :             :     return;
    5265                 :             : 
    5266                 :     1308772 :   read_cleanup (p->left);
    5267                 :     1308772 :   read_cleanup (p->right);
    5268                 :             : 
    5269                 :     1308772 :   if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
    5270                 :             :     {
    5271                 :      539530 :       gfc_namespace *ns;
    5272                 :             :       /* Add hidden symbols to the symtree.  */
    5273                 :      539530 :       q = get_integer (p->u.rsym.ns);
    5274                 :      539530 :       ns = (gfc_namespace *) q->u.pointer;
    5275                 :             : 
    5276                 :      539530 :       if (!p->u.rsym.sym->attr.vtype
    5277                 :      539530 :             && !p->u.rsym.sym->attr.vtab)
    5278                 :      537700 :         st = gfc_get_unique_symtree (ns);
    5279                 :             :       else
    5280                 :             :         {
    5281                 :             :           /* There is no reason to use 'unique_symtrees' for vtabs or
    5282                 :             :              vtypes - their name is fine for a symtree and reduces the
    5283                 :             :              namespace pollution.  */
    5284                 :        1830 :           st = gfc_find_symtree (ns->sym_root, p->u.rsym.sym->name);
    5285                 :        1830 :           if (!st)
    5286                 :         290 :             st = gfc_new_symtree (&ns->sym_root, p->u.rsym.sym->name);
    5287                 :             :         }
    5288                 :             : 
    5289                 :      539530 :       st->n.sym = p->u.rsym.sym;
    5290                 :      539530 :       st->n.sym->refs++;
    5291                 :             : 
    5292                 :             :       /* Fixup any symtree references.  */
    5293                 :      539530 :       p->u.rsym.symtree = st;
    5294                 :      539530 :       resolve_fixups (p->u.rsym.stfixup, st);
    5295                 :      539530 :       p->u.rsym.stfixup = NULL;
    5296                 :             :     }
    5297                 :             : 
    5298                 :             :   /* Free unused symbols.  */
    5299                 :     1308772 :   if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED)
    5300                 :      129237 :     gfc_free_symbol (p->u.rsym.sym);
    5301                 :             : }
    5302                 :             : 
    5303                 :             : 
    5304                 :             : /* It is not quite enough to check for ambiguity in the symbols by
    5305                 :             :    the loaded symbol and the new symbol not being identical.  */
    5306                 :             : static bool
    5307                 :       41227 : check_for_ambiguous (gfc_symtree *st, pointer_info *info)
    5308                 :             : {
    5309                 :       41227 :   gfc_symbol *rsym;
    5310                 :       41227 :   module_locus locus;
    5311                 :       41227 :   symbol_attribute attr;
    5312                 :       41227 :   gfc_symbol *st_sym;
    5313                 :             : 
    5314                 :       41227 :   if (gfc_current_ns->proc_name && st->name == gfc_current_ns->proc_name->name)
    5315                 :             :     {
    5316                 :           6 :       gfc_error ("%qs of module %qs, imported at %C, is also the name of the "
    5317                 :             :                  "current program unit", st->name, module_name);
    5318                 :           6 :       return true;
    5319                 :             :     }
    5320                 :             : 
    5321                 :       41221 :   st_sym = st->n.sym;
    5322                 :       41221 :   rsym = info->u.rsym.sym;
    5323                 :       41221 :   if (st_sym == rsym)
    5324                 :             :     return false;
    5325                 :             : 
    5326                 :         447 :   if (st_sym->attr.vtab || st_sym->attr.vtype)
    5327                 :             :     return false;
    5328                 :             : 
    5329                 :             :   /* If the existing symbol is generic from a different module and
    5330                 :             :      the new symbol is generic there can be no ambiguity.  */
    5331                 :         295 :   if (st_sym->attr.generic
    5332                 :          20 :         && st_sym->module
    5333                 :          20 :         && st_sym->module != module_name)
    5334                 :             :     {
    5335                 :             :       /* The new symbol's attributes have not yet been read.  Since
    5336                 :             :          we need attr.generic, read it directly.  */
    5337                 :          20 :       get_module_locus (&locus);
    5338                 :          20 :       set_module_locus (&info->u.rsym.where);
    5339                 :          20 :       mio_lparen ();
    5340                 :          20 :       attr.generic = 0;
    5341                 :          20 :       mio_symbol_attribute (&attr);
    5342                 :          20 :       set_module_locus (&locus);
    5343                 :          20 :       if (attr.generic)
    5344                 :             :         return false;
    5345                 :             :     }
    5346                 :             : 
    5347                 :             :   return true;
    5348                 :             : }
    5349                 :             : 
    5350                 :             : 
    5351                 :             : /* Read a module file.  */
    5352                 :             : 
    5353                 :             : static void
    5354                 :       11892 : read_module (void)
    5355                 :             : {
    5356                 :       11892 :   module_locus operator_interfaces, user_operators, omp_udrs;
    5357                 :       11892 :   const char *p;
    5358                 :       11892 :   char name[GFC_MAX_SYMBOL_LEN + 1];
    5359                 :       11892 :   int i;
    5360                 :             :   /* Workaround -Wmaybe-uninitialized false positive during
    5361                 :             :      profiledbootstrap by initializing them.  */
    5362                 :       11892 :   int ambiguous = 0, j, nuse, symbol = 0;
    5363                 :       11892 :   pointer_info *info, *q;
    5364                 :       11892 :   gfc_use_rename *u = NULL;
    5365                 :       11892 :   gfc_symtree *st;
    5366                 :       11892 :   gfc_symbol *sym;
    5367                 :             : 
    5368                 :       11892 :   get_module_locus (&operator_interfaces);  /* Skip these for now.  */
    5369                 :       11892 :   skip_list ();
    5370                 :             : 
    5371                 :       11892 :   get_module_locus (&user_operators);
    5372                 :       11892 :   skip_list ();
    5373                 :       11892 :   skip_list ();
    5374                 :             : 
    5375                 :             :   /* Skip commons and equivalences for now.  */
    5376                 :       11892 :   skip_list ();
    5377                 :       11892 :   skip_list ();
    5378                 :             : 
    5379                 :             :   /* Skip OpenMP UDRs.  */
    5380                 :       11892 :   get_module_locus (&omp_udrs);
    5381                 :       11892 :   skip_list ();
    5382                 :             : 
    5383                 :       11892 :   mio_lparen ();
    5384                 :             : 
    5385                 :             :   /* Create the fixup nodes for all the symbols.  */
    5386                 :             : 
    5387                 :      962020 :   while (peek_atom () != ATOM_RPAREN)
    5388                 :             :     {
    5389                 :      938236 :       char* bind_label;
    5390                 :      938236 :       require_atom (ATOM_INTEGER);
    5391                 :      938236 :       info = get_integer (atom_int);
    5392                 :             : 
    5393                 :      938236 :       info->type = P_SYMBOL;
    5394                 :      938236 :       info->u.rsym.state = UNUSED;
    5395                 :             : 
    5396                 :      938236 :       info->u.rsym.true_name = read_string ();
    5397                 :      938236 :       info->u.rsym.module = read_string ();
    5398                 :      938236 :       bind_label = read_string ();
    5399                 :      938236 :       if (strlen (bind_label))
    5400                 :       23797 :         info->u.rsym.binding_label = bind_label;
    5401                 :             :       else
    5402                 :      914439 :         XDELETEVEC (bind_label);
    5403                 :             : 
    5404                 :      938236 :       require_atom (ATOM_INTEGER);
    5405                 :      938236 :       info->u.rsym.ns = atom_int;
    5406                 :             : 
    5407                 :      938236 :       get_module_locus (&info->u.rsym.where);
    5408                 :             : 
    5409                 :             :       /* See if the symbol has already been loaded by a previous module.
    5410                 :             :          If so, we reference the existing symbol and prevent it from
    5411                 :             :          being loaded again.  This should not happen if the symbol being
    5412                 :             :          read is an index for an assumed shape dummy array (ns != 1).  */
    5413                 :             : 
    5414                 :      938236 :       sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
    5415                 :             : 
    5416                 :      938236 :       if (sym == NULL
    5417                 :       47056 :           || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
    5418                 :             :         {
    5419                 :      891205 :           skip_list ();
    5420                 :      891205 :           continue;
    5421                 :             :         }
    5422                 :             : 
    5423                 :       47031 :       info->u.rsym.state = USED;
    5424                 :       47031 :       info->u.rsym.sym = sym;
    5425                 :             :       /* The current symbol has already been loaded, so we can avoid loading
    5426                 :             :          it again.  However, if it is a derived type, some of its components
    5427                 :             :          can be used in expressions in the module.  To avoid the module loading
    5428                 :             :          failing, we need to associate the module's component pointer indexes
    5429                 :             :          with the existing symbol's component pointers.  */
    5430                 :       47031 :       if (gfc_fl_struct (sym->attr.flavor))
    5431                 :             :         {
    5432                 :        4229 :           gfc_component *c;
    5433                 :             : 
    5434                 :             :           /* First seek to the symbol's component list.  */
    5435                 :        4229 :           mio_lparen (); /* symbol opening.  */
    5436                 :        4229 :           skip_list (); /* skip symbol attribute.  */
    5437                 :             : 
    5438                 :        4229 :           mio_lparen (); /* component list opening.  */
    5439                 :       15514 :           for (c = sym->components; c; c = c->next)
    5440                 :             :             {
    5441                 :       11285 :               pointer_info *p;
    5442                 :       11285 :               const char *comp_name = NULL;
    5443                 :       11285 :               int n = 0;
    5444                 :             : 
    5445                 :       11285 :               mio_lparen (); /* component opening.  */
    5446                 :       11285 :               mio_integer (&n);
    5447                 :       11285 :               p = get_integer (n);
    5448                 :       11285 :               if (p->u.pointer == NULL)
    5449                 :       11285 :                 associate_integer_pointer (p, c);
    5450                 :       11285 :               mio_pool_string (&comp_name);
    5451                 :       11285 :               if (comp_name != c->name)
    5452                 :             :                 {
    5453                 :           0 :                   gfc_fatal_error ("Mismatch in components of derived type "
    5454                 :             :                                    "%qs from %qs at %C: expecting %qs, "
    5455                 :             :                                    "but got %qs", sym->name, sym->module,
    5456                 :             :                                    c->name, comp_name);
    5457                 :             :                 }
    5458                 :       11285 :               skip_list (1); /* component end.  */
    5459                 :             :             }
    5460                 :        4229 :           mio_rparen (); /* component list closing.  */
    5461                 :             : 
    5462                 :        4229 :           skip_list (1); /* symbol end.  */
    5463                 :        4229 :         }
    5464                 :             :       else
    5465                 :       42802 :         skip_list ();
    5466                 :             : 
    5467                 :             :       /* Some symbols do not have a namespace (eg. formal arguments),
    5468                 :             :          so the automatic "unique symtree" mechanism must be suppressed
    5469                 :             :          by marking them as referenced.  */
    5470                 :       47031 :       q = get_integer (info->u.rsym.ns);
    5471                 :       47031 :       if (q->u.pointer == NULL)
    5472                 :             :         {
    5473                 :        1239 :           info->u.rsym.referenced = 1;
    5474                 :        1239 :           continue;
    5475                 :             :         }
    5476                 :             :     }
    5477                 :             : 
    5478                 :       11892 :   mio_rparen ();
    5479                 :             : 
    5480                 :             :   /* Parse the symtree lists.  This lets us mark which symbols need to
    5481                 :             :      be loaded.  Renaming is also done at this point by replacing the
    5482                 :             :      symtree name.  */
    5483                 :             : 
    5484                 :       11892 :   mio_lparen ();
    5485                 :             : 
    5486                 :      375572 :   while (peek_atom () != ATOM_RPAREN)
    5487                 :             :     {
    5488                 :      351788 :       mio_internal_string (name);
    5489                 :      351788 :       mio_integer (&ambiguous);
    5490                 :      351788 :       mio_integer (&symbol);
    5491                 :             : 
    5492                 :      351788 :       info = get_integer (symbol);
    5493                 :             : 
    5494                 :             :       /* See how many use names there are.  If none, go through the start
    5495                 :             :          of the loop at least once.  */
    5496                 :      351788 :       nuse = number_use_names (name, false);
    5497                 :      351788 :       info->u.rsym.renamed = nuse ? 1 : 0;
    5498                 :             : 
    5499                 :      351788 :       if (nuse == 0)
    5500                 :      348684 :         nuse = 1;
    5501                 :             : 
    5502                 :      703610 :       for (j = 1; j <= nuse; j++)
    5503                 :             :         {
    5504                 :             :           /* Get the jth local name for this symbol.  */
    5505                 :      351822 :           p = find_use_name_n (name, &j, false);
    5506                 :             : 
    5507                 :      351822 :           if (p == NULL && strcmp (name, module_name) == 0)
    5508                 :             :             p = name;
    5509                 :             : 
    5510                 :             :           /* Exception: Always import vtabs & vtypes.  */
    5511                 :       43882 :           if (p == NULL && name[0] == '_'
    5512                 :        2986 :               && (startswith (name, "__vtab_")
    5513                 :        1974 :                   || startswith (name, "__vtype_")))
    5514                 :             :             p = name;
    5515                 :             : 
    5516                 :             :           /* Skip symtree nodes not in an ONLY clause, unless there
    5517                 :             :              is an existing symtree loaded from another USE statement.  */
    5518                 :      349798 :           if (p == NULL)
    5519                 :             :             {
    5520                 :       41858 :               st = gfc_find_symtree (gfc_current_ns->sym_root, name);
    5521                 :       41858 :               if (st != NULL
    5522                 :         533 :                   && strcmp (st->n.sym->name, info->u.rsym.true_name) == 0
    5523                 :         475 :                   && st->n.sym->module != NULL
    5524                 :         198 :                   && strcmp (st->n.sym->module, info->u.rsym.module) == 0)
    5525                 :             :                 {
    5526                 :         190 :                   info->u.rsym.symtree = st;
    5527                 :         190 :                   info->u.rsym.sym = st->n.sym;
    5528                 :             :                 }
    5529                 :       41858 :               continue;
    5530                 :             :             }
    5531                 :             : 
    5532                 :             :           /* If a symbol of the same name and module exists already,
    5533                 :             :              this symbol, which is not in an ONLY clause, must not be
    5534                 :             :              added to the namespace(11.3.2).  Note that find_symbol
    5535                 :             :              only returns the first occurrence that it finds.  */
    5536                 :      303857 :           if (!only_flag && !info->u.rsym.renamed
    5537                 :      303496 :                 && strcmp (name, module_name) != 0
    5538                 :      604560 :                 && find_symbol (gfc_current_ns->sym_root, name,
    5539                 :             :                                 module_name, 0))
    5540                 :         544 :             continue;
    5541                 :             : 
    5542                 :      309420 :           st = gfc_find_symtree (gfc_current_ns->sym_root, p);
    5543                 :             : 
    5544                 :      309420 :           if (st != NULL
    5545                 :       41263 :               && !(st->n.sym && st->n.sym->attr.used_in_submodule))
    5546                 :             :             {
    5547                 :             :               /* Check for ambiguous symbols.  */
    5548                 :       41227 :               if (check_for_ambiguous (st, info))
    5549                 :         282 :                 st->ambiguous = 1;
    5550                 :             :               else
    5551                 :       40945 :                 info->u.rsym.symtree = st;
    5552                 :             :             }
    5553                 :             :           else
    5554                 :             :             {
    5555                 :      268193 :               if (st)
    5556                 :             :                 {
    5557                 :             :                   /* This symbol is host associated from a module in a
    5558                 :             :                      submodule.  Hide it with a unique symtree.  */
    5559                 :          36 :                   gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns);
    5560                 :          36 :                   s->n.sym = st->n.sym;
    5561                 :          36 :                   st->n.sym = NULL;
    5562                 :             :                 }
    5563                 :             :               else
    5564                 :             :                 {
    5565                 :             :                   /* Create a symtree node in the current namespace for this
    5566                 :             :                      symbol.  */
    5567                 :      536314 :                   st = check_unique_name (p)
    5568                 :      268157 :                        ? gfc_get_unique_symtree (gfc_current_ns)
    5569                 :      268157 :                        : gfc_new_symtree (&gfc_current_ns->sym_root, p);
    5570                 :      268157 :                   st->ambiguous = ambiguous;
    5571                 :             :                 }
    5572                 :             : 
    5573                 :      268193 :               sym = info->u.rsym.sym;
    5574                 :             : 
    5575                 :             :               /* Create a symbol node if it doesn't already exist.  */
    5576                 :      268193 :               if (sym == NULL)
    5577                 :             :                 {
    5578                 :      268042 :                   info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
    5579                 :             :                                                      gfc_current_ns);
    5580                 :      268042 :                   info->u.rsym.sym->name = gfc_dt_lower_string (info->u.rsym.true_name);
    5581                 :      268042 :                   sym = info->u.rsym.sym;
    5582                 :      268042 :                   sym->module = gfc_get_string ("%s", info->u.rsym.module);
    5583                 :             : 
    5584                 :      268042 :                   if (info->u.rsym.binding_label)
    5585                 :             :                     {
    5586                 :       14695 :                       tree id = get_identifier (info->u.rsym.binding_label);
    5587                 :       14695 :                       sym->binding_label = IDENTIFIER_POINTER (id);
    5588                 :             :                     }
    5589                 :             :                 }
    5590                 :             : 
    5591                 :      268193 :               st->n.sym = sym;
    5592                 :      268193 :               st->n.sym->refs++;
    5593                 :             : 
    5594                 :      268193 :               if (strcmp (name, p) != 0)
    5595                 :         509 :                 sym->attr.use_rename = 1;
    5596                 :             : 
    5597                 :      268193 :               if (name[0] != '_'
    5598                 :      268193 :                   || (!startswith (name, "__vtab_")
    5599                 :       26129 :                       && !startswith (name, "__vtype_")))
    5600                 :      243207 :                 sym->attr.use_only = only_flag;
    5601                 :             : 
    5602                 :             :               /* Store the symtree pointing to this symbol.  */
    5603                 :      268193 :               info->u.rsym.symtree = st;
    5604                 :             : 
    5605                 :      268193 :               if (info->u.rsym.state == UNUSED)
    5606                 :      268042 :                 info->u.rsym.state = NEEDED;
    5607                 :      268193 :               info->u.rsym.referenced = 1;
    5608                 :             :             }
    5609                 :             :         }
    5610                 :             :     }
    5611                 :             : 
    5612                 :       11892 :   mio_rparen ();
    5613                 :             : 
    5614                 :             :   /* Load intrinsic operator interfaces.  */
    5615                 :       11892 :   set_module_locus (&operator_interfaces);
    5616                 :       11892 :   mio_lparen ();
    5617                 :             : 
    5618                 :      344868 :   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
    5619                 :             :     {
    5620                 :      332976 :       gfc_use_rename *u = NULL, *v = NULL;
    5621                 :      332976 :       int j = i;
    5622                 :             : 
    5623                 :      332976 :       if (i == INTRINSIC_USER)
    5624                 :       11892 :         continue;
    5625                 :             : 
    5626                 :      321084 :       if (only_flag)
    5627                 :             :         {
    5628                 :       43902 :           u = find_use_operator ((gfc_intrinsic_op) i);
    5629                 :             : 
    5630                 :             :           /* F2018:10.1.5.5.1 requires same interpretation of old and new-style
    5631                 :             :              relational operators.  Special handling for USE, ONLY.  */
    5632                 :       43902 :           switch (i)
    5633                 :             :             {
    5634                 :             :             case INTRINSIC_EQ:
    5635                 :             :               j = INTRINSIC_EQ_OS;
    5636                 :             :               break;
    5637                 :             :             case INTRINSIC_EQ_OS:
    5638                 :             :               j = INTRINSIC_EQ;
    5639                 :             :               break;
    5640                 :             :             case INTRINSIC_NE:
    5641                 :             :               j = INTRINSIC_NE_OS;
    5642                 :             :               break;
    5643                 :             :             case INTRINSIC_NE_OS:
    5644                 :             :               j = INTRINSIC_NE;
    5645                 :             :               break;
    5646                 :             :             case INTRINSIC_GT:
    5647                 :             :               j = INTRINSIC_GT_OS;
    5648                 :             :               break;
    5649                 :             :             case INTRINSIC_GT_OS:
    5650                 :             :               j = INTRINSIC_GT;
    5651                 :             :               break;
    5652                 :             :             case INTRINSIC_GE:
    5653                 :             :               j = INTRINSIC_GE_OS;
    5654                 :             :               break;
    5655                 :             :             case INTRINSIC_GE_OS:
    5656                 :             :               j = INTRINSIC_GE;
    5657                 :             :               break;
    5658                 :             :             case INTRINSIC_LT:
    5659                 :             :               j = INTRINSIC_LT_OS;
    5660                 :             :               break;
    5661                 :             :             case INTRINSIC_LT_OS:
    5662                 :             :               j = INTRINSIC_LT;
    5663                 :             :               break;
    5664                 :             :             case INTRINSIC_LE:
    5665                 :             :               j = INTRINSIC_LE_OS;
    5666                 :             :               break;
    5667                 :             :             case INTRINSIC_LE_OS:
    5668                 :             :               j = INTRINSIC_LE;
    5669                 :             :               break;
    5670                 :             :             default:
    5671                 :             :               break;
    5672                 :             :             }
    5673                 :             : 
    5674                 :             :           if (j != i)
    5675                 :       19512 :             v = find_use_operator ((gfc_intrinsic_op) j);
    5676                 :             : 
    5677                 :       43902 :           if (u == NULL && v == NULL)
    5678                 :             :             {
    5679                 :       43758 :               skip_list ();
    5680                 :       43758 :               continue;
    5681                 :             :             }
    5682                 :             : 
    5683                 :         144 :           if (u)
    5684                 :         107 :             u->found = 1;
    5685                 :         144 :           if (v)
    5686                 :          89 :             v->found = 1;
    5687                 :             :         }
    5688                 :             : 
    5689                 :      277326 :       mio_interface (&gfc_current_ns->op[i]);
    5690                 :      277326 :       if (!gfc_current_ns->op[i] && !gfc_current_ns->op[j])
    5691                 :             :         {
    5692                 :      275791 :           if (u)
    5693                 :          15 :             u->found = 0;
    5694                 :      275791 :           if (v)
    5695                 :          26 :             v->found = 0;
    5696                 :             :         }
    5697                 :             :     }
    5698                 :             : 
    5699                 :       11892 :   mio_rparen ();
    5700                 :             : 
    5701                 :             :   /* Load generic and user operator interfaces.  These must follow the
    5702                 :             :      loading of symtree because otherwise symbols can be marked as
    5703                 :             :      ambiguous.  */
    5704                 :             : 
    5705                 :       11892 :   set_module_locus (&user_operators);
    5706                 :             : 
    5707                 :       11892 :   load_operator_interfaces ();
    5708                 :       11892 :   load_generic_interfaces ();
    5709                 :             : 
    5710                 :       11892 :   load_commons ();
    5711                 :       11892 :   load_equiv ();
    5712                 :             : 
    5713                 :             :   /* Load OpenMP user defined reductions.  */
    5714                 :       11892 :   set_module_locus (&omp_udrs);
    5715                 :       11892 :   load_omp_udrs ();
    5716                 :             : 
    5717                 :             :   /* At this point, we read those symbols that are needed but haven't
    5718                 :             :      been loaded yet.  If one symbol requires another, the other gets
    5719                 :             :      marked as NEEDED if its previous state was UNUSED.  */
    5720                 :             : 
    5721                 :       44697 :   while (load_needed (pi_root));
    5722                 :             : 
    5723                 :             :   /* Make sure all elements of the rename-list were found in the module.  */
    5724                 :             : 
    5725                 :       14643 :   for (u = gfc_rename_list; u; u = u->next)
    5726                 :             :     {
    5727                 :        2751 :       if (u->found)
    5728                 :        2744 :         continue;
    5729                 :             : 
    5730                 :           7 :       if (u->op == INTRINSIC_NONE)
    5731                 :             :         {
    5732                 :           2 :           gfc_error ("Symbol %qs referenced at %L not found in module %qs",
    5733                 :           2 :                      u->use_name, &u->where, module_name);
    5734                 :           2 :           continue;
    5735                 :             :         }
    5736                 :             : 
    5737                 :           5 :       if (u->op == INTRINSIC_USER)
    5738                 :             :         {
    5739                 :           2 :           gfc_error ("User operator %qs referenced at %L not found "
    5740                 :           2 :                      "in module %qs", u->use_name, &u->where, module_name);
    5741                 :           2 :           continue;
    5742                 :             :         }
    5743                 :             : 
    5744                 :           3 :       gfc_error ("Intrinsic operator %qs referenced at %L not found "
    5745                 :             :                  "in module %qs", gfc_op2string (u->op), &u->where,
    5746                 :             :                  module_name);
    5747                 :             :     }
    5748                 :             : 
    5749                 :             :   /* Clean up symbol nodes that were never loaded, create references
    5750                 :             :      to hidden symbols.  */
    5751                 :             : 
    5752                 :       11892 :   read_cleanup (pi_root);
    5753                 :       11892 : }
    5754                 :             : 
    5755                 :             : 
    5756                 :             : /* Given an access type that is specific to an entity and the default
    5757                 :             :    access, return nonzero if the entity is publicly accessible.  If the
    5758                 :             :    element is declared as PUBLIC, then it is public; if declared
    5759                 :             :    PRIVATE, then private, and otherwise it is public unless the default
    5760                 :             :    access in this context has been declared PRIVATE.  */
    5761                 :             : 
    5762                 :             : static bool dump_smod = false;
    5763                 :             : 
    5764                 :             : static bool
    5765                 :      886270 : check_access (gfc_access specific_access, gfc_access default_access)
    5766                 :             : {
    5767                 :      886270 :   if (dump_smod)
    5768                 :             :     return true;
    5769                 :             : 
    5770                 :      869741 :   if (specific_access == ACCESS_PUBLIC)
    5771                 :             :     return true;
    5772                 :      843618 :   if (specific_access == ACCESS_PRIVATE)
    5773                 :             :     return false;
    5774                 :             : 
    5775                 :      841388 :   if (flag_module_private)
    5776                 :          91 :     return default_access == ACCESS_PUBLIC;
    5777                 :             :   else
    5778                 :      841297 :     return default_access != ACCESS_PRIVATE;
    5779                 :             : }
    5780                 :             : 
    5781                 :             : 
    5782                 :             : bool
    5783                 :      740726 : gfc_check_symbol_access (gfc_symbol *sym)
    5784                 :             : {
    5785                 :      740726 :   if (sym->attr.vtab || sym->attr.vtype)
    5786                 :             :     return true;
    5787                 :             :   else
    5788                 :      650058 :     return check_access (sym->attr.access, sym->ns->default_access);
    5789                 :             : }
    5790                 :             : 
    5791                 :             : 
    5792                 :             : /* A structure to remember which commons we've already written.  */
    5793                 :             : 
    5794                 :             : struct written_common
    5795                 :             : {
    5796                 :             :   BBT_HEADER(written_common);
    5797                 :             :   const char *name, *label;
    5798                 :             : };
    5799                 :             : 
    5800                 :             : static struct written_common *written_commons = NULL;
    5801                 :             : 
    5802                 :             : /* Comparison function used for balancing the binary tree.  */
    5803                 :             : 
    5804                 :             : static int
    5805                 :          86 : compare_written_commons (void *a1, void *b1)
    5806                 :             : {
    5807                 :          86 :   const char *aname = ((struct written_common *) a1)->name;
    5808                 :          86 :   const char *alabel = ((struct written_common *) a1)->label;
    5809                 :          86 :   const char *bname = ((struct written_common *) b1)->name;
    5810                 :          86 :   const char *blabel = ((struct written_common *) b1)->label;
    5811                 :          86 :   int c = strcmp (aname, bname);
    5812                 :             : 
    5813                 :          86 :   return (c != 0 ? c : strcmp (alabel, blabel));
    5814                 :             : }
    5815                 :             : 
    5816                 :             : /* Free a list of written commons.  */
    5817                 :             : 
    5818                 :             : static void
    5819                 :        8805 : free_written_common (struct written_common *w)
    5820                 :             : {
    5821                 :        8805 :   if (!w)
    5822                 :             :     return;
    5823                 :             : 
    5824                 :         203 :   if (w->left)
    5825                 :          32 :     free_written_common (w->left);
    5826                 :         203 :   if (w->right)
    5827                 :          31 :     free_written_common (w->right);
    5828                 :             : 
    5829                 :         203 :   free (w);
    5830                 :             : }
    5831                 :             : 
    5832                 :             : /* Write a common block to the module -- recursive helper function.  */
    5833                 :             : 
    5834                 :             : static void
    5835                 :       18392 : write_common_0 (gfc_symtree *st, bool this_module)
    5836                 :             : {
    5837                 :       18392 :   gfc_common_head *p;
    5838                 :       18392 :   const char * name;
    5839                 :       18392 :   int flags;
    5840                 :       18392 :   const char *label;
    5841                 :       18392 :   struct written_common *w;
    5842                 :       18392 :   bool write_me = true;
    5843                 :             : 
    5844                 :       18392 :   if (st == NULL)
    5845                 :       17938 :     return;
    5846                 :             : 
    5847                 :         454 :   write_common_0 (st->left, this_module);
    5848                 :             : 
    5849                 :             :   /* We will write out the binding label, or "" if no label given.  */
    5850                 :         454 :   name = st->n.common->name;
    5851                 :         454 :   p = st->n.common;
    5852                 :         454 :   label = (p->is_bind_c && p->binding_label) ? p->binding_label : "";
    5853                 :             : 
    5854                 :             :   /* Check if we've already output this common.  */
    5855                 :         454 :   w = written_commons;
    5856                 :         857 :   while (w)
    5857                 :             :     {
    5858                 :         403 :       int c = strcmp (name, w->name);
    5859                 :         403 :       c = (c != 0 ? c : strcmp (label, w->label));
    5860                 :         198 :       if (c == 0)
    5861                 :             :         write_me = false;
    5862                 :             : 
    5863                 :         403 :       w = (c < 0) ? w->left : w->right;
    5864                 :             :     }
    5865                 :             : 
    5866                 :         454 :   if (this_module && p->use_assoc)
    5867                 :             :     write_me = false;
    5868                 :             : 
    5869                 :         401 :   if (write_me)
    5870                 :             :     {
    5871                 :             :       /* Write the common to the module.  */
    5872                 :         203 :       mio_lparen ();
    5873                 :         203 :       mio_pool_string (&name);
    5874                 :             : 
    5875                 :         203 :       mio_symbol_ref (&p->head);
    5876                 :         203 :       flags = p->saved ? 1 : 0;
    5877                 :         203 :       if (p->threadprivate)
    5878                 :           0 :         flags |= 2;
    5879                 :         203 :       flags |= p->omp_device_type << 2;
    5880                 :         203 :       mio_integer (&flags);
    5881                 :             : 
    5882                 :             :       /* Write out whether the common block is bind(c) or not.  */
    5883                 :         203 :       mio_integer (&(p->is_bind_c));
    5884                 :             : 
    5885                 :         203 :       mio_pool_string (&label);
    5886                 :         203 :       mio_rparen ();
    5887                 :             : 
    5888                 :             :       /* Record that we have written this common.  */
    5889                 :         203 :       w = XCNEW (struct written_common);
    5890                 :         203 :       w->name = p->name;
    5891                 :         203 :       w->label = label;
    5892                 :         203 :       gfc_insert_bbt (&written_commons, w, compare_written_commons);
    5893                 :             :     }
    5894                 :             : 
    5895                 :         454 :   write_common_0 (st->right, this_module);
    5896                 :             : }
    5897                 :             : 
    5898                 :             : 
    5899                 :             : /* Write a common, by initializing the list of written commons, calling
    5900                 :             :    the recursive function write_common_0() and cleaning up afterwards.  */
    5901                 :             : 
    5902                 :             : static void
    5903                 :        8742 : write_common (gfc_symtree *st)
    5904                 :             : {
    5905                 :        8742 :   written_commons = NULL;
    5906                 :        8742 :   write_common_0 (st, true);
    5907                 :        8742 :   write_common_0 (st, false);
    5908                 :        8742 :   free_written_common (written_commons);
    5909                 :        8742 :   written_commons = NULL;
    5910                 :        8742 : }
    5911                 :             : 
    5912                 :             : 
    5913                 :             : /* Write the blank common block to the module.  */
    5914                 :             : 
    5915                 :             : static void
    5916                 :        8742 : write_blank_common (void)
    5917                 :             : {
    5918                 :        8742 :   const char * name = BLANK_COMMON_NAME;
    5919                 :        8742 :   int saved;
    5920                 :             :   /* TODO: Blank commons are not bind(c).  The F2003 standard probably says
    5921                 :             :      this, but it hasn't been checked.  Just making it so for now.  */
    5922                 :        8742 :   int is_bind_c = 0;
    5923                 :             : 
    5924                 :        8742 :   if (gfc_current_ns->blank_common.head == NULL)
    5925                 :        8735 :     return;
    5926                 :             : 
    5927                 :           7 :   mio_lparen ();
    5928                 :             : 
    5929                 :           7 :   mio_pool_string (&name);
    5930                 :             : 
    5931                 :           7 :   mio_symbol_ref (&gfc_current_ns->blank_common.head);
    5932                 :           7 :   saved = gfc_current_ns->blank_common.saved;
    5933                 :           7 :   mio_integer (&saved);
    5934                 :             : 
    5935                 :             :   /* Write out whether the common block is bind(c) or not.  */
    5936                 :           7 :   mio_integer (&is_bind_c);
    5937                 :             : 
    5938                 :             :   /* Write out an empty binding label.  */
    5939                 :           7 :   write_atom (ATOM_STRING, "");
    5940                 :             : 
    5941                 :           7 :   mio_rparen ();
    5942                 :             : }
    5943                 :             : 
    5944                 :             : 
    5945                 :             : /* Write equivalences to the module.  */
    5946                 :             : 
    5947                 :             : static void
    5948                 :        8742 : write_equiv (void)
    5949                 :             : {
    5950                 :        8742 :   gfc_equiv *eq, *e;
    5951                 :        8742 :   int num;
    5952                 :             : 
    5953                 :        8742 :   num = 0;
    5954                 :        8824 :   for (eq = gfc_current_ns->equiv; eq; eq = eq->next)
    5955                 :             :     {
    5956                 :          82 :       mio_lparen ();
    5957                 :             : 
    5958                 :         328 :       for (e = eq; e; e = e->eq)
    5959                 :             :         {
    5960                 :         164 :           if (e->module == NULL)
    5961                 :         142 :             e->module = gfc_get_string ("%s.eq.%d", module_name, num);
    5962                 :         164 :           mio_allocated_string (e->module);
    5963                 :         164 :           mio_expr (&e->expr);
    5964                 :             :         }
    5965                 :             : 
    5966                 :          82 :       num++;
    5967                 :          82 :       mio_rparen ();
    5968                 :             :     }
    5969                 :        8742 : }
    5970                 :             : 
    5971                 :             : 
    5972                 :             : /* Write a symbol to the module.  */
    5973                 :             : 
    5974                 :             : static void
    5975                 :      199542 : write_symbol (int n, gfc_symbol *sym)
    5976                 :             : {
    5977                 :      199542 :   const char *label;
    5978                 :             : 
    5979                 :      199542 :   if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
    5980                 :           0 :     gfc_internal_error ("write_symbol(): bad module symbol %qs", sym->name);
    5981                 :             : 
    5982                 :      199542 :   mio_integer (&n);
    5983                 :             : 
    5984                 :      199542 :   if (gfc_fl_struct (sym->attr.flavor))
    5985                 :             :     {
    5986                 :       22870 :       const char *name;
    5987                 :       22870 :       name = gfc_dt_upper_string (sym->name);
    5988                 :       22870 :       mio_pool_string (&name);
    5989                 :       22870 :     }
    5990                 :             :   else
    5991                 :      176672 :     mio_pool_string (&sym->name);
    5992                 :             : 
    5993                 :      199542 :   mio_pool_string (&sym->module);
    5994                 :      199542 :   if ((sym->attr.is_bind_c || sym->attr.is_iso_c) && sym->binding_label)
    5995                 :             :     {
    5996                 :        2322 :       label = sym->binding_label;
    5997                 :        2322 :       mio_pool_string (&label);
    5998                 :             :     }
    5999                 :             :   else
    6000                 :      197220 :     write_atom (ATOM_STRING, "");
    6001                 :             : 
    6002                 :      199542 :   mio_pointer_ref (&sym->ns);
    6003                 :             : 
    6004                 :      199542 :   mio_symbol (sym);
    6005                 :      199542 :   write_char ('\n');
    6006                 :      199542 : }
    6007                 :             : 
    6008                 :             : 
    6009                 :             : /* Recursive traversal function to write the initial set of symbols to
    6010                 :             :    the module.  We check to see if the symbol should be written
    6011                 :             :    according to the access specification.  */
    6012                 :             : 
    6013                 :             : static void
    6014                 :      140465 : write_symbol0 (gfc_symtree *st)
    6015                 :             : {
    6016                 :      272188 :   gfc_symbol *sym;
    6017                 :      272188 :   pointer_info *p;
    6018                 :      272188 :   bool dont_write = false;
    6019                 :             : 
    6020                 :      272188 :   if (st == NULL)
    6021                 :      140465 :     return;
    6022                 :             : 
    6023                 :      131723 :   write_symbol0 (st->left);
    6024                 :             : 
    6025                 :      131723 :   sym = st->n.sym;
    6026                 :      131723 :   if (sym->module == NULL)
    6027                 :       61693 :     sym->module = module_name;
    6028                 :             : 
    6029                 :      131723 :   if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
    6030                 :       43291 :       && !sym->attr.subroutine && !sym->attr.function)
    6031                 :      131723 :     dont_write = true;
    6032                 :             : 
    6033                 :      131723 :   if (!gfc_check_symbol_access (sym))
    6034                 :             :     dont_write = true;
    6035                 :             : 
    6036                 :      115119 :   if (!dont_write)
    6037                 :             :     {
    6038                 :      113802 :       p = get_pointer (sym);
    6039                 :      113802 :       if (p->type == P_UNKNOWN)
    6040                 :       86101 :         p->type = P_SYMBOL;
    6041                 :             : 
    6042                 :      113802 :       if (p->u.wsym.state != WRITTEN)
    6043                 :             :         {
    6044                 :      110973 :           write_symbol (p->integer, sym);
    6045                 :      110973 :           p->u.wsym.state = WRITTEN;
    6046                 :             :         }
    6047                 :             :     }
    6048                 :             : 
    6049                 :      131723 :   write_symbol0 (st->right);
    6050                 :             : }
    6051                 :             : 
    6052                 :             : 
    6053                 :             : static void
    6054                 :          94 : write_omp_udr (gfc_omp_udr *udr)
    6055                 :             : {
    6056                 :          94 :   switch (udr->rop)
    6057                 :             :     {
    6058                 :          65 :     case OMP_REDUCTION_USER:
    6059                 :             :       /* Non-operators can't be used outside of the module.  */
    6060                 :          65 :       if (udr->name[0] != '.')
    6061                 :             :         return;
    6062                 :             :       else
    6063                 :             :         {
    6064                 :          47 :           gfc_symtree *st;
    6065                 :          47 :           size_t len = strlen (udr->name + 1);
    6066                 :          47 :           char *name = XALLOCAVEC (char, len);
    6067                 :          47 :           memcpy (name, udr->name, len - 1);
    6068                 :          47 :           name[len - 1] = '\0';
    6069                 :          47 :           st = gfc_find_symtree (gfc_current_ns->uop_root, name);
    6070                 :             :           /* If corresponding user operator is private, don't write
    6071                 :             :              the UDR.  */
    6072                 :          47 :           if (st != NULL)
    6073                 :             :             {
    6074                 :           0 :               gfc_user_op *uop = st->n.uop;
    6075                 :           0 :               if (!check_access (uop->access, uop->ns->default_access))
    6076                 :             :                 return;
    6077                 :             :             }
    6078                 :             :         }
    6079                 :             :       break;
    6080                 :          29 :     case OMP_REDUCTION_PLUS:
    6081                 :          29 :     case OMP_REDUCTION_MINUS:
    6082                 :          29 :     case OMP_REDUCTION_TIMES:
    6083                 :          29 :     case OMP_REDUCTION_AND:
    6084                 :          29 :     case OMP_REDUCTION_OR:
    6085                 :          29 :     case OMP_REDUCTION_EQV:
    6086                 :          29 :     case OMP_REDUCTION_NEQV:
    6087                 :             :       /* If corresponding operator is private, don't write the UDR.  */
    6088                 :          29 :       if (!check_access (gfc_current_ns->operator_access[udr->rop],
    6089                 :             :                          gfc_current_ns->default_access))
    6090                 :             :         return;
    6091                 :             :       break;
    6092                 :             :     default:
    6093                 :             :       break;
    6094                 :             :     }
    6095                 :          75 :   if (udr->ts.type == BT_DERIVED || udr->ts.type == BT_CLASS)
    6096                 :             :     {
    6097                 :             :       /* If derived type is private, don't write the UDR.  */
    6098                 :          39 :       if (!gfc_check_symbol_access (udr->ts.u.derived))
    6099                 :             :         return;
    6100                 :             :     }
    6101                 :             : 
    6102                 :          74 :   mio_lparen ();
    6103                 :          74 :   mio_pool_string (&udr->name);
    6104                 :          74 :   mio_typespec (&udr->ts);
    6105                 :          74 :   mio_omp_udr_expr (udr, &udr->omp_out, &udr->omp_in, udr->combiner_ns, false);
    6106                 :          74 :   if (udr->initializer_ns)
    6107                 :          62 :     mio_omp_udr_expr (udr, &udr->omp_priv, &udr->omp_orig,
    6108                 :             :                       udr->initializer_ns, true);
    6109                 :          74 :   mio_rparen ();
    6110                 :             : }
    6111                 :             : 
    6112                 :             : 
    6113                 :             : static void
    6114                 :        8836 : write_omp_udrs (gfc_symtree *st)
    6115                 :             : {
    6116                 :        8930 :   if (st == NULL)
    6117                 :        8836 :     return;
    6118                 :             : 
    6119                 :          94 :   write_omp_udrs (st->left);
    6120                 :          94 :   gfc_omp_udr *udr;
    6121                 :         188 :   for (udr = st->n.omp_udr; udr; udr = udr->next)
    6122                 :          94 :     write_omp_udr (udr);
    6123                 :          94 :   write_omp_udrs (st->right);
    6124                 :             : }
    6125                 :             : 
    6126                 :             : 
    6127                 :             : /* Type for the temporary tree used when writing secondary symbols.  */
    6128                 :             : 
    6129                 :             : struct sorted_pointer_info
    6130                 :             : {
    6131                 :             :   BBT_HEADER (sorted_pointer_info);
    6132                 :             : 
    6133                 :             :   pointer_info *p;
    6134                 :             : };
    6135                 :             : 
    6136                 :             : #define gfc_get_sorted_pointer_info() XCNEW (sorted_pointer_info)
    6137                 :             : 
    6138                 :             : /* Recursively traverse the temporary tree, free its contents.  */
    6139                 :             : 
    6140                 :             : static void
    6141                 :      190327 : free_sorted_pointer_info_tree (sorted_pointer_info *p)
    6142                 :             : {
    6143                 :      190327 :   if (!p)
    6144                 :             :     return;
    6145                 :             : 
    6146                 :       88569 :   free_sorted_pointer_info_tree (p->left);
    6147                 :       88569 :   free_sorted_pointer_info_tree (p->right);
    6148                 :             : 
    6149                 :       88569 :   free (p);
    6150                 :             : }
    6151                 :             : 
    6152                 :             : /* Comparison function for the temporary tree.  */
    6153                 :             : 
    6154                 :             : static int
    6155                 :      300321 : compare_sorted_pointer_info (void *_spi1, void *_spi2)
    6156                 :             : {
    6157                 :      300321 :   sorted_pointer_info *spi1, *spi2;
    6158                 :      300321 :   spi1 = (sorted_pointer_info *)_spi1;
    6159                 :      300321 :   spi2 = (sorted_pointer_info *)_spi2;
    6160                 :             : 
    6161                 :      300321 :   if (spi1->p->integer < spi2->p->integer)
    6162                 :             :     return -1;
    6163                 :      168242 :   if (spi1->p->integer > spi2->p->integer)
    6164                 :      168242 :     return 1;
    6165                 :             :   return 0;
    6166                 :             : }
    6167                 :             : 
    6168                 :             : 
    6169                 :             : /* Finds the symbols that need to be written and collects them in the
    6170                 :             :    sorted_pi tree so that they can be traversed in an order
    6171                 :             :    independent of memory addresses.  */
    6172                 :             : 
    6173                 :             : static void
    6174                 :     1028082 : find_symbols_to_write(sorted_pointer_info **tree, pointer_info *p)
    6175                 :             : {
    6176                 :     2034233 :   if (!p)
    6177                 :     1028082 :     return;
    6178                 :             : 
    6179                 :     1006151 :   if (p->type == P_SYMBOL && p->u.wsym.state == NEEDS_WRITE)
    6180                 :             :     {
    6181                 :       88569 :       sorted_pointer_info *sp = gfc_get_sorted_pointer_info();
    6182                 :       88569 :       sp->p = p;
    6183                 :             : 
    6184                 :       88569 :       gfc_insert_bbt (tree, sp, compare_sorted_pointer_info);
    6185                 :             :    }
    6186                 :             : 
    6187                 :     1006151 :   find_symbols_to_write (tree, p->left);
    6188                 :     1006151 :   find_symbols_to_write (tree, p->right);
    6189                 :             : }
    6190                 :             : 
    6191                 :             : 
    6192                 :             : /* Recursive function that traverses the tree of symbols that need to be
    6193                 :             :    written and writes them in order.  */
    6194                 :             : 
    6195                 :             : static void
    6196                 :      101758 : write_symbol1_recursion (sorted_pointer_info *sp)
    6197                 :             : {
    6198                 :      190327 :   if (!sp)
    6199                 :      101758 :     return;
    6200                 :             : 
    6201                 :       88569 :   write_symbol1_recursion (sp->left);
    6202                 :             : 
    6203                 :       88569 :   pointer_info *p1 = sp->p;
    6204                 :       88569 :   gcc_assert (p1->type == P_SYMBOL && p1->u.wsym.state == NEEDS_WRITE);
    6205                 :             : 
    6206                 :       88569 :   p1->u.wsym.state = WRITTEN;
    6207                 :       88569 :   write_symbol (p1->integer, p1->u.wsym.sym);
    6208                 :       88569 :   p1->u.wsym.sym->attr.public_used = 1;
    6209                 :             : 
    6210                 :       88569 :   write_symbol1_recursion (sp->right);
    6211                 :             : }
    6212                 :             : 
    6213                 :             : 
    6214                 :             : /* Write the secondary set of symbols to the module file.  These are
    6215                 :             :    symbols that were not public yet are needed by the public symbols
    6216                 :             :    or another dependent symbol.  The act of writing a symbol can add
    6217                 :             :    symbols to the pointer_info tree, so we return nonzero if a symbol
    6218                 :             :    was written and pass that information upwards.  The caller will
    6219                 :             :    then call this function again until nothing was written.  It uses
    6220                 :             :    the utility functions and a temporary tree to ensure a reproducible
    6221                 :             :    ordering of the symbol output and thus the module file.  */
    6222                 :             : 
    6223                 :             : static int
    6224                 :       21931 : write_symbol1 (pointer_info *p)
    6225                 :             : {
    6226                 :       21931 :   if (!p)
    6227                 :             :     return 0;
    6228                 :             : 
    6229                 :             :   /* Put symbols that need to be written into a tree sorted on the
    6230                 :             :      integer field.  */
    6231                 :             : 
    6232                 :       21931 :   sorted_pointer_info *spi_root = NULL;
    6233                 :       21931 :   find_symbols_to_write (&spi_root, p);
    6234                 :             : 
    6235                 :             :   /* No symbols to write, return.  */
    6236                 :       21931 :   if (!spi_root)
    6237                 :             :     return 0;
    6238                 :             : 
    6239                 :             :   /* Otherwise, write and free the tree again.  */
    6240                 :       13189 :   write_symbol1_recursion (spi_root);
    6241                 :       13189 :   free_sorted_pointer_info_tree (spi_root);
    6242                 :             : 
    6243                 :       13189 :   return 1;
    6244                 :             : }
    6245                 :             : 
    6246                 :             : 
    6247                 :             : /* Write operator interfaces associated with a symbol.  */
    6248                 :             : 
    6249                 :             : static void
    6250                 :         149 : write_operator (gfc_user_op *uop)
    6251                 :             : {
    6252                 :         149 :   static char nullstring[] = "";
    6253                 :         149 :   const char *p = nullstring;
    6254                 :             : 
    6255                 :         149 :   if (uop->op == NULL || !check_access (uop->access, uop->ns->default_access))
    6256                 :           1 :     return;
    6257                 :             : 
    6258                 :         148 :   mio_symbol_interface (&uop->name, &p, &uop->op);
    6259                 :             : }
    6260                 :             : 
    6261                 :             : 
    6262                 :             : /* Write generic interfaces from the namespace sym_root.  */
    6263                 :             : 
    6264                 :             : static void
    6265                 :      140465 : write_generic (gfc_symtree *st)
    6266                 :             : {
    6267                 :      272188 :   gfc_symbol *sym;
    6268                 :             : 
    6269                 :      272188 :   if (st == NULL)
    6270                 :      140465 :     return;
    6271                 :             : 
    6272                 :      131723 :   write_generic (st->left);
    6273                 :             : 
    6274                 :      131723 :   sym = st->n.sym;
    6275                 :      131723 :   if (sym && !check_unique_name (st->name)
    6276                 :      256377 :       && sym->generic && gfc_check_symbol_access (sym))
    6277                 :             :     {
    6278                 :        9177 :       if (!sym->module)
    6279                 :        6119 :         sym->module = module_name;
    6280                 :             : 
    6281                 :        9177 :       mio_symbol_interface (&st->name, &sym->module, &sym->generic);
    6282                 :             :     }
    6283                 :             : 
    6284                 :      131723 :   write_generic (st->right);
    6285                 :             : }
    6286                 :             : 
    6287                 :             : 
    6288                 :             : static void
    6289                 :      131724 : write_symtree (gfc_symtree *st)
    6290                 :             : {
    6291                 :      131724 :   gfc_symbol *sym;
    6292                 :      131724 :   pointer_info *p;
    6293                 :             : 
    6294                 :      131724 :   sym = st->n.sym;
    6295                 :             : 
    6296                 :             :   /* A symbol in an interface body must not be visible in the
    6297                 :             :      module file.  */
    6298                 :      131724 :   if (sym->ns != gfc_current_ns
    6299                 :         435 :         && sym->ns->proc_name
    6300                 :         435 :         && sym->ns->proc_name->attr.if_source == IFSRC_IFBODY)
    6301                 :             :     return;
    6302                 :             : 
    6303                 :      131724 :   if (!gfc_check_symbol_access (sym)
    6304                 :      131724 :       || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
    6305                 :       37386 :           && !sym->attr.subroutine && !sym->attr.function))
    6306                 :             :     return;
    6307                 :             : 
    6308                 :      113802 :   if (check_unique_name (st->name))
    6309                 :             :     return;
    6310                 :             : 
    6311                 :             :   /* From F2003 onwards, intrinsic procedures are no longer subject to
    6312                 :             :      the restriction, "that an elemental intrinsic function here be of
    6313                 :             :      type integer or character and each argument must be an initialization
    6314                 :             :      expr of type integer or character" is lifted so that intrinsic
    6315                 :             :      procedures can be over-ridden. This requires that the intrinsic
    6316                 :             :      symbol not appear in the module file, thereby preventing ambiguity
    6317                 :             :      when USEd.  */
    6318                 :      107588 :   if (strcmp (sym->module, "(intrinsic)") == 0
    6319                 :        1708 :       && (gfc_option.allow_std & GFC_STD_F2003))
    6320                 :             :     return;
    6321                 :             : 
    6322                 :      105881 :   p = find_pointer (sym);
    6323                 :      105881 :   if (p == NULL)
    6324                 :           0 :     gfc_internal_error ("write_symtree(): Symbol not written");
    6325                 :             : 
    6326                 :      105881 :   mio_pool_string (&st->name);
    6327                 :      105881 :   mio_integer (&st->ambiguous);
    6328                 :      105881 :   mio_hwi (&p->integer);
    6329                 :             : }
    6330                 :             : 
    6331                 :             : 
    6332                 :             : static void
    6333                 :        8742 : write_module (void)
    6334                 :             : {
    6335                 :        8742 :   int i;
    6336                 :             : 
    6337                 :             :   /* Initialize the column counter. */
    6338                 :        8742 :   module_column = 1;
    6339                 :             :   
    6340                 :             :   /* Write the operator interfaces.  */
    6341                 :        8742 :   mio_lparen ();
    6342                 :             : 
    6343                 :      262260 :   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
    6344                 :             :     {
    6345                 :      244776 :       if (i == INTRINSIC_USER)
    6346                 :        8742 :         continue;
    6347                 :             : 
    6348                 :      472068 :       mio_interface (check_access (gfc_current_ns->operator_access[i],
    6349                 :             :                                    gfc_current_ns->default_access)
    6350                 :             :                      ? &gfc_current_ns->op[i] : NULL);
    6351                 :             :     }
    6352                 :             : 
    6353                 :        8742 :   mio_rparen ();
    6354                 :        8742 :   write_char ('\n');
    6355                 :        8742 :   write_char ('\n');
    6356                 :             : 
    6357                 :        8742 :   mio_lparen ();
    6358                 :        8742 :   gfc_traverse_user_op (gfc_current_ns, write_operator);
    6359                 :        8742 :   mio_rparen ();
    6360                 :        8742 :   write_char ('\n');
    6361                 :        8742 :   write_char ('\n');
    6362                 :             : 
    6363                 :        8742 :   mio_lparen ();
    6364                 :        8742 :   write_generic (gfc_current_ns->sym_root);
    6365                 :        8742 :   mio_rparen ();
    6366                 :        8742 :   write_char ('\n');
    6367                 :        8742 :   write_char ('\n');
    6368                 :             : 
    6369                 :        8742 :   mio_lparen ();
    6370                 :        8742 :   write_blank_common ();
    6371                 :        8742 :   write_common (gfc_current_ns->common_root);
    6372                 :        8742 :   mio_rparen ();
    6373                 :        8742 :   write_char ('\n');
    6374                 :        8742 :   write_char ('\n');
    6375                 :             : 
    6376                 :        8742 :   mio_lparen ();
    6377                 :        8742 :   write_equiv ();
    6378                 :        8742 :   mio_rparen ();
    6379                 :        8742 :   write_char ('\n');
    6380                 :        8742 :   write_char ('\n');
    6381                 :             : 
    6382                 :        8742 :   mio_lparen ();
    6383                 :        8742 :   write_omp_udrs (gfc_current_ns->omp_udr_root);
    6384                 :        8742 :   mio_rparen ();
    6385                 :        8742 :   write_char ('\n');
    6386                 :        8742 :   write_char ('\n');
    6387                 :             : 
    6388                 :             :   /* Write symbol information.  First we traverse all symbols in the
    6389                 :             :      primary namespace, writing those that need to be written.
    6390                 :             :      Sometimes writing one symbol will cause another to need to be
    6391                 :             :      written.  A list of these symbols ends up on the write stack, and
    6392                 :             :      we end by popping the bottom of the stack and writing the symbol
    6393                 :             :      until the stack is empty.  */
    6394                 :             : 
    6395                 :        8742 :   mio_lparen ();
    6396                 :             : 
    6397                 :        8742 :   write_symbol0 (gfc_current_ns->sym_root);
    6398                 :       30673 :   while (write_symbol1 (pi_root))
    6399                 :             :     /* Nothing.  */;
    6400                 :             : 
    6401                 :        8742 :   mio_rparen ();
    6402                 :             : 
    6403                 :        8742 :   write_char ('\n');
    6404                 :        8742 :   write_char ('\n');
    6405                 :             : 
    6406                 :        8742 :   mio_lparen ();
    6407                 :        8742 :   gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
    6408                 :        8742 :   mio_rparen ();
    6409                 :        8742 : }
    6410                 :             : 
    6411                 :             : 
    6412                 :             : /* Read a CRC32 sum from the gzip trailer of a module file.  Returns
    6413                 :             :    true on success, false on failure.  */
    6414                 :             : 
    6415                 :             : static bool
    6416                 :       17484 : read_crc32_from_module_file (const char* filename, uLong* crc)
    6417                 :             : {
    6418                 :       17484 :   FILE *file;
    6419                 :       17484 :   char buf[4];
    6420                 :       17484 :   unsigned int val;
    6421                 :             : 
    6422                 :             :   /* Open the file in binary mode.  */
    6423                 :       17484 :   if ((file = fopen (filename, "rb")) == NULL)
    6424                 :             :     return false;
    6425                 :             : 
    6426                 :             :   /* The gzip crc32 value is found in the [END-8, END-4] bytes of the
    6427                 :             :      file. See RFC 1952.  */
    6428                 :        8935 :   if (fseek (file, -8, SEEK_END) != 0)
    6429                 :             :     {
    6430                 :           0 :       fclose (file);
    6431                 :           0 :       return false;
    6432                 :             :     }
    6433                 :             : 
    6434                 :             :   /* Read the CRC32.  */
    6435                 :        8935 :   if (fread (buf, 1, 4, file) != 4)
    6436                 :             :     {
    6437                 :           0 :       fclose (file);
    6438                 :           0 :       return false;
    6439                 :             :     }
    6440                 :             : 
    6441                 :             :   /* Close the file.  */
    6442                 :        8935 :   fclose (file);
    6443                 :             : 
    6444                 :        8935 :   val = (buf[0] & 0xFF) + ((buf[1] & 0xFF) << 8) + ((buf[2] & 0xFF) << 16)
    6445                 :        8935 :     + ((buf[3] & 0xFF) << 24);
    6446                 :        8935 :   *crc = val;
    6447                 :             : 
    6448                 :             :   /* For debugging, the CRC value printed in hexadecimal should match
    6449                 :             :      the CRC printed by "zcat -l -v filename".
    6450                 :             :      printf("CRC of file %s is %x\n", filename, val); */
    6451                 :             : 
    6452                 :        8935 :   return true;
    6453                 :             : }
    6454                 :             : 
    6455                 :             : 
    6456                 :             : /* Given module, dump it to disk.  If there was an error while
    6457                 :             :    processing the module, dump_flag will be set to zero and we delete
    6458                 :             :    the module file, even if it was already there.  */
    6459                 :             : 
    6460                 :             : static void
    6461                 :        9187 : dump_module (const char *name, int dump_flag)
    6462                 :             : {
    6463                 :        9187 :   int n;
    6464                 :        9187 :   char *filename, *filename_tmp;
    6465                 :        9187 :   uLong crc, crc_old;
    6466                 :             : 
    6467                 :        9187 :   module_name = gfc_get_string ("%s", name);
    6468                 :             : 
    6469                 :        9187 :   if (dump_smod)
    6470                 :             :     {
    6471                 :         385 :       name = submodule_name;
    6472                 :         385 :       n = strlen (name) + strlen (SUBMODULE_EXTENSION) + 1;
    6473                 :             :     }
    6474                 :             :   else
    6475                 :        8802 :     n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
    6476                 :             : 
    6477                 :        9187 :   if (gfc_option.module_dir != NULL)
    6478                 :             :     {
    6479                 :           0 :       n += strlen (gfc_option.module_dir);
    6480                 :           0 :       filename = (char *) alloca (n);
    6481                 :           0 :       strcpy (filename, gfc_option.module_dir);
    6482                 :           0 :       strcat (filename, name);
    6483                 :             :     }
    6484                 :             :   else
    6485                 :             :     {
    6486                 :        9187 :       filename = (char *) alloca (n);
    6487                 :        9187 :       strcpy (filename, name);
    6488                 :             :     }
    6489                 :             : 
    6490                 :        9187 :   if (dump_smod)
    6491                 :         385 :     strcat (filename, SUBMODULE_EXTENSION);
    6492                 :             :   else
    6493                 :        8802 :   strcat (filename, MODULE_EXTENSION);
    6494                 :             : 
    6495                 :             :   /* Name of the temporary file used to write the module.  */
    6496                 :        9187 :   filename_tmp = (char *) alloca (n + 1);
    6497                 :        9187 :   strcpy (filename_tmp, filename);
    6498                 :        9187 :   strcat (filename_tmp, "0");
    6499                 :             : 
    6500                 :             :   /* There was an error while processing the module.  We delete the
    6501                 :             :      module file, even if it was already there.  */
    6502                 :        9187 :   if (!dump_flag)
    6503                 :             :     {
    6504                 :         445 :       remove (filename);
    6505                 :         445 :       return;
    6506                 :             :     }
    6507                 :             : 
    6508                 :        8742 :   if (gfc_cpp_makedep ())
    6509                 :           0 :     gfc_cpp_add_target (filename);
    6510                 :             : 
    6511                 :             :   /* Write the module to the temporary file.  */
    6512                 :        8742 :   module_fp = gzopen (filename_tmp, "w");
    6513                 :        8742 :   if (module_fp == NULL)
    6514                 :           0 :     gfc_fatal_error ("Cannot open module file %qs for writing at %C: %s",
    6515                 :           0 :                      filename_tmp, xstrerror (errno));
    6516                 :             : 
    6517                 :             :   /* Use lbasename to ensure module files are reproducible regardless
    6518                 :             :      of the build path (see the reproducible builds project).  */
    6519                 :        8742 :   gzprintf (module_fp, "GFORTRAN module version '%s' created from %s\n",
    6520                 :             :             MOD_VERSION, lbasename (gfc_source_file));
    6521                 :             : 
    6522                 :             :   /* Write the module itself.  */
    6523                 :        8742 :   iomode = IO_OUTPUT;
    6524                 :             : 
    6525                 :        8742 :   init_pi_tree ();
    6526                 :             : 
    6527                 :        8742 :   write_module ();
    6528                 :             : 
    6529                 :        8742 :   free_pi_tree (pi_root);
    6530                 :        8742 :   pi_root = NULL;
    6531                 :             : 
    6532                 :        8742 :   write_char ('\n');
    6533                 :             : 
    6534                 :        8742 :   if (gzclose (module_fp))
    6535                 :           0 :     gfc_fatal_error ("Error writing module file %qs for writing: %s",
    6536                 :           0 :                      filename_tmp, xstrerror (errno));
    6537                 :             : 
    6538                 :             :   /* Read the CRC32 from the gzip trailers of the module files and
    6539                 :             :      compare.  */
    6540                 :        8742 :   if (!read_crc32_from_module_file (filename_tmp, &crc)
    6541                 :        8742 :       || !read_crc32_from_module_file (filename, &crc_old)
    6542                 :        8935 :       || crc_old != crc)
    6543                 :             :     {
    6544                 :             :       /* Module file have changed, replace the old one.  */
    6545                 :        8554 :       if (remove (filename) && errno != ENOENT)
    6546                 :           0 :         gfc_fatal_error ("Cannot delete module file %qs: %s", filename,
    6547                 :             :                          xstrerror (errno));
    6548                 :        8554 :       if (rename (filename_tmp, filename))
    6549                 :           0 :         gfc_fatal_error ("Cannot rename module file %qs to %qs: %s",
    6550                 :           0 :                          filename_tmp, filename, xstrerror (errno));
    6551                 :             :     }
    6552                 :             :   else
    6553                 :             :     {
    6554                 :         188 :       if (remove (filename_tmp))
    6555                 :           0 :         gfc_fatal_error ("Cannot delete temporary module file %qs: %s",
    6556                 :           0 :                          filename_tmp, xstrerror (errno));
    6557                 :             :     }
    6558                 :             : }
    6559                 :             : 
    6560                 :             : 
    6561                 :             : /* Suppress the output of a .smod file by module, if no module
    6562                 :             :    procedures have been seen.  */
    6563                 :             : static bool no_module_procedures;
    6564                 :             : 
    6565                 :             : static void
    6566                 :      131958 : check_for_module_procedures (gfc_symbol *sym)
    6567                 :             : {
    6568                 :      131958 :   if (sym && sym->attr.module_procedure)
    6569                 :         886 :     no_module_procedures = false;
    6570                 :      131958 : }
    6571                 :             : 
    6572                 :             : 
    6573                 :             : void
    6574                 :        8992 : gfc_dump_module (const char *name, int dump_flag)
    6575                 :             : {
    6576                 :        8992 :   if (gfc_state_stack->state == COMP_SUBMODULE)
    6577                 :         190 :     dump_smod = true;
    6578                 :             :   else
    6579                 :        8802 :     dump_smod =false;
    6580                 :             : 
    6581                 :        8992 :   no_module_procedures = true;
    6582                 :        8992 :   gfc_traverse_ns (gfc_current_ns, check_for_module_procedures);
    6583                 :             : 
    6584                 :        8992 :   dump_module (name, dump_flag);
    6585                 :             : 
    6586                 :        8992 :   if (no_module_procedures || dump_smod)
    6587                 :             :     return;
    6588                 :             : 
    6589                 :             :   /* Write a submodule file from a module.  The 'dump_smod' flag switches
    6590                 :             :      off the check for PRIVATE entities.  */
    6591                 :         195 :   dump_smod = true;
    6592                 :         195 :   submodule_name = module_name;
    6593                 :         195 :   dump_module (name, dump_flag);
    6594                 :         195 :   dump_smod = false;
    6595                 :             : }
    6596                 :             : 
    6597                 :             : static void
    6598                 :       18136 : create_intrinsic_function (const char *name, int id,
    6599                 :             :                            const char *modname, intmod_id module,
    6600                 :             :                            bool subroutine, gfc_symbol *result_type)
    6601                 :             : {
    6602                 :       18136 :   gfc_intrinsic_sym *isym;
    6603                 :       18136 :   gfc_symtree *tmp_symtree;
    6604                 :       18136 :   gfc_symbol *sym;
    6605                 :             : 
    6606                 :       18136 :   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
    6607                 :       18136 :   if (tmp_symtree)
    6608                 :             :     {
    6609                 :          36 :       if (tmp_symtree->n.sym && tmp_symtree->n.sym->module
    6610                 :          36 :           && strcmp (modname, tmp_symtree->n.sym->module) == 0)
    6611                 :          36 :         return;
    6612                 :           0 :       gfc_error ("Symbol %qs at %C already declared", name);
    6613                 :           0 :       return;
    6614                 :             :     }
    6615                 :             : 
    6616                 :       18100 :   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
    6617                 :       18100 :   sym = tmp_symtree->n.sym;
    6618                 :             : 
    6619                 :       18100 :   if (subroutine)
    6620                 :             :     {
    6621                 :        5811 :       gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id);
    6622                 :        5811 :       isym = gfc_intrinsic_subroutine_by_id (isym_id);
    6623                 :        5811 :       sym->attr.subroutine = 1;
    6624                 :             :     }
    6625                 :             :   else
    6626                 :             :     {
    6627                 :       12289 :       gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id);
    6628                 :       12289 :       isym = gfc_intrinsic_function_by_id (isym_id);
    6629                 :             : 
    6630                 :       12289 :       sym->attr.function = 1;
    6631                 :       12289 :       if (result_type)
    6632                 :             :         {
    6633                 :        5907 :           sym->ts.type = BT_DERIVED;
    6634                 :        5907 :           sym->ts.u.derived = result_type;
    6635                 :        5907 :           sym->ts.is_c_interop = 1;
    6636                 :        5907 :           isym->ts.f90_type = BT_VOID;
    6637                 :        5907 :           isym->ts.type = BT_DERIVED;
    6638                 :        5907 :           isym->ts.f90_type = BT_VOID;
    6639                 :        5907 :           isym->ts.u.derived = result_type;
    6640                 :        5907 :           isym->ts.is_c_interop = 1;
    6641                 :             :         }
    6642                 :             :     }
    6643                 :       18100 :   gcc_assert (isym);
    6644                 :             : 
    6645                 :       18100 :   sym->attr.flavor = FL_PROCEDURE;
    6646                 :       18100 :   sym->attr.intrinsic = 1;
    6647                 :             : 
    6648                 :       18100 :   sym->module = gfc_get_string ("%s", modname);
    6649                 :       18100 :   sym->attr.use_assoc = 1;
    6650                 :       18100 :   sym->from_intmod = module;
    6651                 :       18100 :   sym->intmod_sym_id = id;
    6652                 :             : }
    6653                 :             : 
    6654                 :             : 
    6655                 :             : /* Import the intrinsic ISO_C_BINDING module, generating symbols in
    6656                 :             :    the current namespace for all named constants, pointer types, and
    6657                 :             :    procedures in the module unless the only clause was used or a rename
    6658                 :             :    list was provided.  */
    6659                 :             : 
    6660                 :             : static void
    6661                 :        7866 : import_iso_c_binding_module (void)
    6662                 :             : {
    6663                 :        7866 :   gfc_symbol *mod_sym = NULL, *return_type;
    6664                 :        7866 :   gfc_symtree *mod_symtree = NULL, *tmp_symtree;
    6665                 :        7866 :   gfc_symtree *c_ptr = NULL, *c_funptr = NULL;
    6666                 :        7866 :   const char *iso_c_module_name = "__iso_c_binding";
    6667                 :        7866 :   gfc_use_rename *u;
    6668                 :        7866 :   int i;
    6669                 :        7866 :   bool want_c_ptr = false, want_c_funptr = false;
    6670                 :             : 
    6671                 :             :   /* Look only in the current namespace.  */
    6672                 :        7866 :   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
    6673                 :             : 
    6674                 :        7866 :   if (mod_symtree == NULL)
    6675                 :             :     {
    6676                 :             :       /* symtree doesn't already exist in current namespace.  */
    6677                 :        7800 :       gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree,
    6678                 :             :                         false);
    6679                 :             : 
    6680                 :        7800 :       if (mod_symtree != NULL)
    6681                 :        7800 :         mod_sym = mod_symtree->n.sym;
    6682                 :             :       else
    6683                 :           0 :         gfc_internal_error ("import_iso_c_binding_module(): Unable to "
    6684                 :             :                             "create symbol for %s", iso_c_module_name);
    6685                 :             : 
    6686                 :        7800 :       mod_sym->attr.flavor = FL_MODULE;
    6687                 :        7800 :       mod_sym->attr.intrinsic = 1;
    6688                 :        7800 :       mod_sym->module = gfc_get_string ("%s", iso_c_module_name);
    6689                 :        7800 :       mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
    6690                 :             :     }
    6691                 :             : 
    6692                 :             :   /* Check whether C_PTR or C_FUNPTR are in the include list, if so, load it;
    6693                 :             :      check also whether C_NULL_(FUN)PTR or C_(FUN)LOC are requested, which
    6694                 :             :      need C_(FUN)PTR.  */
    6695                 :       15678 :   for (u = gfc_rename_list; u; u = u->next)
    6696                 :             :     {
    6697                 :        7812 :       if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_PTR].name,
    6698                 :        7812 :                   u->use_name) == 0)
    6699                 :             :         want_c_ptr = true;
    6700                 :        7760 :       else if (strcmp (c_interop_kinds_table[ISOCBINDING_LOC].name,
    6701                 :             :                        u->use_name) == 0)
    6702                 :             :         want_c_ptr = true;
    6703                 :        7638 :       else if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_FUNPTR].name,
    6704                 :             :                        u->use_name) == 0)
    6705                 :             :         want_c_funptr = true;
    6706                 :        7638 :       else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNLOC].name,
    6707                 :             :                        u->use_name) == 0)
    6708                 :             :         want_c_funptr = true;
    6709                 :        7605 :       else if (strcmp (c_interop_kinds_table[ISOCBINDING_PTR].name,
    6710                 :             :                        u->use_name) == 0)
    6711                 :             :         {
    6712                 :        1735 :           c_ptr = generate_isocbinding_symbol (iso_c_module_name,
    6713                 :             :                                                (iso_c_binding_symbol)
    6714                 :             :                                                         ISOCBINDING_PTR,
    6715                 :        1735 :                                                u->local_name[0] ? u->local_name
    6716                 :             :                                                                 : u->use_name,
    6717                 :             :                                                NULL, false);
    6718                 :             :         }
    6719                 :        5870 :       else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNPTR].name,
    6720                 :             :                        u->use_name) == 0)
    6721                 :             :         {
    6722                 :          95 :           c_funptr
    6723                 :          95 :              = generate_isocbinding_symbol (iso_c_module_name,
    6724                 :             :                                             (iso_c_binding_symbol)
    6725                 :             :                                                         ISOCBINDING_FUNPTR,
    6726                 :          95 :                                              u->local_name[0] ? u->local_name
    6727                 :             :                                                               : u->use_name,
    6728                 :             :                                              NULL, false);
    6729                 :             :         }
    6730                 :             :     }
    6731                 :             : 
    6732                 :        7866 :   if ((want_c_ptr || !only_flag) && !c_ptr)
    6733                 :        2919 :     c_ptr = generate_isocbinding_symbol (iso_c_module_name,
    6734                 :             :                                          (iso_c_binding_symbol)
    6735                 :             :                                                         ISOCBINDING_PTR,
    6736                 :             :                                          NULL, NULL, only_flag);
    6737                 :        7866 :   if ((want_c_funptr || !only_flag) && !c_funptr)
    6738                 :        2883 :     c_funptr = generate_isocbinding_symbol (iso_c_module_name,
    6739                 :             :                                             (iso_c_binding_symbol)
    6740                 :             :                                                         ISOCBINDING_FUNPTR,
    6741                 :             :                                             NULL, NULL, only_flag);
    6742                 :             : 
    6743                 :             :   /* Generate the symbols for the named constants representing
    6744                 :             :      the kinds for intrinsic data types.  */
    6745                 :      416898 :   for (i = 0; i < ISOCBINDING_NUMBER; i++)
    6746                 :             :     {
    6747                 :      409032 :       bool found = false;
    6748                 :      815256 :       for (u = gfc_rename_list; u; u = u->next)
    6749                 :      406224 :         if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
    6750                 :             :           {
    6751                 :        7810 :             bool not_in_std;
    6752                 :        7810 :             const char *name;
    6753                 :        7810 :             u->found = 1;
    6754                 :        7810 :             found = true;
    6755                 :             : 
    6756                 :        7810 :             switch (i)
    6757                 :             :               {
    6758                 :             : #define NAMED_FUNCTION(a,b,c,d) \
    6759                 :             :                 case a: \
    6760                 :             :                   not_in_std = (gfc_option.allow_std & d) == 0; \
    6761                 :             :                   name = b; \
    6762                 :             :                   break;
    6763                 :             : #define NAMED_SUBROUTINE(a,b,c,d) \
    6764                 :             :                 case a: \
    6765                 :             :                   not_in_std = (gfc_option.allow_std & d) == 0; \
    6766                 :             :                   name = b; \
    6767                 :             :                   break;
    6768                 :             : #define NAMED_INTCST(a,b,c,d) \
    6769                 :             :                 case a: \
    6770                 :             :                   not_in_std = (gfc_option.allow_std & d) == 0; \
    6771                 :             :                   name = b; \
    6772                 :             :                   break;
    6773                 :             : #define NAMED_REALCST(a,b,c,d) \
    6774                 :             :                 case a: \
    6775                 :             :                   not_in_std = (gfc_option.allow_std & d) == 0; \
    6776                 :             :                   name = b; \
    6777                 :             :                   break;
    6778                 :             : #define NAMED_CMPXCST(a,b,c,d) \
    6779                 :             :                 case a: \
    6780                 :             :                   not_in_std = (gfc_option.allow_std & d) == 0; \
    6781                 :             :                   name = b; \
    6782                 :             :                   break;
    6783                 :             : #include "iso-c-binding.def"
    6784                 :             :                 default:
    6785                 :             :                   not_in_std = false;
    6786                 :             :                   name = "";
    6787                 :             :               }
    6788                 :             : 
    6789                 :        5616 :             if (not_in_std)
    6790                 :             :               {
    6791                 :           6 :                 gfc_error ("The symbol %qs, referenced at %L, is not "
    6792                 :             :                            "in the selected standard", name, &u->where);
    6793                 :           6 :                 continue;
    6794                 :             :               }
    6795                 :             : 
    6796                 :        7804 :             switch (i)
    6797                 :             :               {
    6798                 :             : #define NAMED_FUNCTION(a,b,c,d) \
    6799                 :             :                 case a: \
    6800                 :             :                   if (a == ISOCBINDING_LOC) \
    6801                 :             :                     return_type = c_ptr->n.sym; \
    6802                 :             :                   else if (a == ISOCBINDING_FUNLOC) \
    6803                 :             :                     return_type = c_funptr->n.sym; \
    6804                 :             :                   else \
    6805                 :             :                     return_type = NULL; \
    6806                 :             :                   create_intrinsic_function (u->local_name[0] \
    6807                 :             :                                              ? u->local_name : u->use_name, \
    6808                 :             :                                              a, iso_c_module_name, \
    6809                 :             :                                              INTMOD_ISO_C_BINDING, false, \
    6810                 :             :                                              return_type); \
    6811                 :             :                   break;
    6812                 :             : #define NAMED_SUBROUTINE(a,b,c,d) \
    6813                 :             :                 case a: \
    6814                 :             :                   create_intrinsic_function (u->local_name[0] ? u->local_name \
    6815                 :             :                                                               : u->use_name, \
    6816                 :             :                                              a, iso_c_module_name, \
    6817                 :             :                                              INTMOD_ISO_C_BINDING, true, NULL); \
    6818                 :             :                   break;
    6819                 :             : #include "iso-c-binding.def"
    6820                 :             : 
    6821                 :             :                 case ISOCBINDING_PTR:
    6822                 :             :                 case ISOCBINDING_FUNPTR:
    6823                 :             :                   /* Already handled above.  */
    6824                 :             :                   break;
    6825                 :        5640 :                 default:
    6826                 :        5640 :                   if (i == ISOCBINDING_NULL_PTR)
    6827                 :             :                     tmp_symtree = c_ptr;
    6828                 :        5588 :                   else if (i == ISOCBINDING_NULL_FUNPTR)
    6829                 :             :                     tmp_symtree = c_funptr;
    6830                 :             :                   else
    6831                 :        5588 :                     tmp_symtree = NULL;
    6832                 :        5640 :                   generate_isocbinding_symbol (iso_c_module_name,
    6833                 :             :                                                (iso_c_binding_symbol) i,
    6834                 :        5640 :                                                u->local_name[0]
    6835                 :             :                                                ? u->local_name : u->use_name,
    6836                 :             :                                                tmp_symtree, false);
    6837                 :             :               }
    6838                 :             :           }
    6839                 :             : 
    6840                 :      409032 :       if (!found && !only_flag)
    6841                 :             :         {
    6842                 :             :           /* Skip, if the symbol is not in the enabled standard.  */
    6843                 :      149823 :           switch (i)
    6844                 :             :             {
    6845                 :             : #define NAMED_FUNCTION(a,b,c,d) \
    6846                 :             :               case a: \
    6847                 :             :                 if ((gfc_option.allow_std & d) == 0) \
    6848                 :             :                   continue; \
    6849                 :             :                 break;
    6850                 :             : #define NAMED_SUBROUTINE(a,b,c,d) \
    6851                 :             :               case a: \
    6852                 :             :                 if ((gfc_option.allow_std & d) == 0) \
    6853                 :             :                   continue; \
    6854                 :             :                 break;
    6855                 :             : #define NAMED_INTCST(a,b,c,d) \
    6856                 :             :               case a: \
    6857                 :             :                 if ((gfc_option.allow_std & d) == 0) \
    6858                 :             :                   continue; \
    6859                 :             :                 break;
    6860                 :             : #define NAMED_REALCST(a,b,c,d) \
    6861                 :             :               case a: \
    6862                 :             :                 if ((gfc_option.allow_std & d) == 0) \
    6863                 :             :                   continue; \
    6864                 :             :                 break;
    6865                 :             : #define NAMED_CMPXCST(a,b,c,d) \
    6866                 :             :               case a: \
    6867                 :             :                 if ((gfc_option.allow_std & d) == 0) \
    6868                 :             :                   continue; \
    6869                 :             :                 break;
    6870                 :             : #include "iso-c-binding.def"
    6871                 :      149561 :               default:
    6872                 :      149561 :                 ; /* Not GFC_STD_* versioned.  */
    6873                 :             :             }
    6874                 :             : 
    6875                 :      149561 :           switch (i)
    6876                 :             :             {
    6877                 :             : #define NAMED_FUNCTION(a,b,c,d) \
    6878                 :             :               case a: \
    6879                 :             :                 if (a == ISOCBINDING_LOC) \
    6880                 :             :                   return_type = c_ptr->n.sym; \
    6881                 :             :                 else if (a == ISOCBINDING_FUNLOC) \
    6882                 :             :                   return_type = c_funptr->n.sym; \
    6883                 :             :                 else \
    6884                 :             :                   return_type = NULL; \
    6885                 :             :                 create_intrinsic_function (b, a, iso_c_module_name, \
    6886                 :             :                                            INTMOD_ISO_C_BINDING, false, \
    6887                 :             :                                            return_type); \
    6888                 :             :                 break;
    6889                 :             : #define NAMED_SUBROUTINE(a,b,c,d) \
    6890                 :             :               case a: \
    6891                 :             :                 create_intrinsic_function (b, a, iso_c_module_name, \
    6892                 :             :                                            INTMOD_ISO_C_BINDING, true, NULL); \
    6893                 :             :                   break;
    6894                 :             : #include "iso-c-binding.def"
    6895                 :             : 
    6896                 :             :               case ISOCBINDING_PTR:
    6897                 :             :               case ISOCBINDING_FUNPTR:
    6898                 :             :                 /* Already handled above.  */
    6899                 :             :                 break;
    6900                 :      126547 :               default:
    6901                 :      126547 :                 if (i == ISOCBINDING_NULL_PTR)
    6902                 :             :                   tmp_symtree = c_ptr;
    6903                 :      123665 :                 else if (i == ISOCBINDING_NULL_FUNPTR)
    6904                 :             :                   tmp_symtree = c_funptr;
    6905                 :             :                 else
    6906                 :      120783 :                   tmp_symtree = NULL;
    6907                 :      126547 :                 generate_isocbinding_symbol (iso_c_module_name,
    6908                 :             :                                              (iso_c_binding_symbol) i, NULL,
    6909                 :             :                                              tmp_symtree, false);
    6910                 :             :             }
    6911                 :             :         }
    6912                 :             :    }
    6913                 :             : 
    6914                 :       15678 :    for (u = gfc_rename_list; u; u = u->next)
    6915                 :             :      {
    6916                 :        7812 :       if (u->found)
    6917                 :        7810 :         continue;
    6918                 :             : 
    6919                 :           2 :       gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
    6920                 :           2 :                  "module ISO_C_BINDING", u->use_name, &u->where);
    6921                 :             :      }
    6922                 :        7866 : }
    6923                 :             : 
    6924                 :             : 
    6925                 :             : /* Add an integer named constant from a given module.  */
    6926                 :             : 
    6927                 :             : static void
    6928                 :        6302 : create_int_parameter (const char *name, int value, const char *modname,
    6929                 :             :                       intmod_id module, int id)
    6930                 :             : {
    6931                 :        6302 :   gfc_symtree *tmp_symtree;
    6932                 :        6302 :   gfc_symbol *sym;
    6933                 :             : 
    6934                 :        6302 :   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
    6935                 :        6302 :   if (tmp_symtree != NULL)
    6936                 :             :     {
    6937                 :           0 :       if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
    6938                 :           0 :         return;
    6939                 :             :       else
    6940                 :           0 :         gfc_error ("Symbol %qs already declared", name);
    6941                 :             :     }
    6942                 :             : 
    6943                 :        6302 :   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
    6944                 :        6302 :   sym = tmp_symtree->n.sym;
    6945                 :             : 
    6946                 :        6302 :   sym->module = gfc_get_string ("%s", modname);
    6947                 :        6302 :   sym->attr.flavor = FL_PARAMETER;
    6948                 :        6302 :   sym->ts.type = BT_INTEGER;
    6949                 :        6302 :   sym->ts.kind = gfc_default_integer_kind;
    6950                 :        6302 :   sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL, value);
    6951                 :        6302 :   sym->attr.use_assoc = 1;
    6952                 :        6302 :   sym->from_intmod = module;
    6953                 :        6302 :   sym->intmod_sym_id = id;
    6954                 :             : }
    6955                 :             : 
    6956                 :             : 
    6957                 :             : /* Value is already contained by the array constructor, but not
    6958                 :             :    yet the shape.  */
    6959                 :             : 
    6960                 :             : static void
    6961                 :        1092 : create_int_parameter_array (const char *name, int size, gfc_expr *value,
    6962                 :             :                             const char *modname, intmod_id module, int id)
    6963                 :             : {
    6964                 :        1092 :   gfc_symtree *tmp_symtree;
    6965                 :        1092 :   gfc_symbol *sym;
    6966                 :             : 
    6967                 :        1092 :   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
    6968                 :        1092 :   if (tmp_symtree != NULL)
    6969                 :             :     {
    6970                 :           0 :       if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
    6971                 :           0 :         return;
    6972                 :             :       else
    6973                 :           0 :         gfc_error ("Symbol %qs already declared", name);
    6974                 :             :     }
    6975                 :             : 
    6976                 :        1092 :   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
    6977                 :        1092 :   sym = tmp_symtree->n.sym;
    6978                 :             : 
    6979                 :        1092 :   sym->module = gfc_get_string ("%s", modname);
    6980                 :        1092 :   sym->attr.flavor = FL_PARAMETER;
    6981                 :        1092 :   sym->ts.type = BT_INTEGER;
    6982                 :        1092 :   sym->ts.kind = gfc_default_integer_kind;
    6983                 :        1092 :   sym->attr.use_assoc = 1;
    6984                 :        1092 :   sym->from_intmod = module;
    6985                 :        1092 :   sym->intmod_sym_id = id;
    6986                 :        1092 :   sym->attr.dimension = 1;
    6987                 :        1092 :   sym->as = gfc_get_array_spec ();
    6988                 :        1092 :   sym->as->rank = 1;
    6989                 :        1092 :   sym->as->type = AS_EXPLICIT;
    6990                 :        1092 :   sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
    6991                 :        1092 :   sym->as->upper[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, size);
    6992                 :             : 
    6993                 :        1092 :   sym->value = value;
    6994                 :        1092 :   sym->value->shape = gfc_get_shape (1);
    6995                 :        1092 :   mpz_init_set_ui (sym->value->shape[0], size);
    6996                 :             : }
    6997                 :             : 
    6998                 :             : 
    6999                 :             : /* Add an derived type for a given module.  */
    7000                 :             : 
    7001                 :             : static void
    7002                 :         824 : create_derived_type (const char *name, const char *modname,
    7003                 :             :                       intmod_id module, int id)
    7004                 :             : {
    7005                 :         824 :   gfc_symtree *tmp_symtree;
    7006                 :         824 :   gfc_symbol *sym, *dt_sym;
    7007                 :         824 :   gfc_interface *intr, *head;
    7008                 :             : 
    7009                 :         824 :   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
    7010                 :         824 :   if (tmp_symtree != NULL)
    7011                 :             :     {
    7012                 :           0 :       if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
    7013                 :           0 :         return;
    7014                 :             :       else
    7015                 :           0 :         gfc_error ("Symbol %qs already declared", name);
    7016                 :             :     }
    7017                 :             : 
    7018                 :         824 :   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
    7019                 :         824 :   sym = tmp_symtree->n.sym;
    7020                 :         824 :   sym->module = gfc_get_string ("%s", modname);
    7021                 :         824 :   sym->from_intmod = module;
    7022                 :         824 :   sym->intmod_sym_id = id;
    7023                 :         824 :   sym->attr.flavor = FL_PROCEDURE;
    7024                 :         824 :   sym->attr.function = 1;
    7025                 :         824 :   sym->attr.generic = 1;
    7026                 :             : 
    7027                 :         824 :   gfc_get_sym_tree (gfc_dt_upper_string (sym->name),
    7028                 :             :                     gfc_current_ns, &tmp_symtree, false);
    7029                 :         824 :   dt_sym = tmp_symtree->n.sym;
    7030                 :         824 :   dt_sym->name = gfc_get_string ("%s", sym->name);
    7031                 :         824 :   dt_sym->attr.flavor = FL_DERIVED;
    7032                 :         824 :   dt_sym->attr.private_comp = 1;
    7033                 :         824 :   dt_sym->attr.zero_comp = 1;
    7034                 :         824 :   dt_sym->attr.use_assoc = 1;
    7035                 :         824 :   dt_sym->module = gfc_get_string ("%s", modname);
    7036                 :         824 :   dt_sym->from_intmod = module;
    7037                 :         824 :   dt_sym->intmod_sym_id = id;
    7038                 :             : 
    7039                 :         824 :   head = sym->generic;
    7040                 :         824 :   intr = gfc_get_interface ();
    7041                 :         824 :   intr->sym = dt_sym;
    7042                 :         824 :   intr->where = gfc_current_locus;
    7043                 :         824 :   intr->next = head;
    7044                 :         824 :   sym->generic = intr;
    7045                 :         824 :   sym->attr.if_source = IFSRC_DECL;
    7046                 :             : }
    7047                 :             : 
    7048                 :             : 
    7049                 :             : /* Read the contents of the module file into a temporary buffer.  */
    7050                 :             : 
    7051                 :             : static void
    7052                 :       11892 : read_module_to_tmpbuf ()
    7053                 :             : {
    7054                 :             :   /* We don't know the uncompressed size, so enlarge the buffer as
    7055                 :             :      needed.  */
    7056                 :       11892 :   int cursz = 4096;
    7057                 :       11892 :   int rsize = cursz;
    7058                 :       11892 :   int len = 0;
    7059                 :             : 
    7060                 :       11892 :   module_content = XNEWVEC (char, cursz);
    7061                 :             : 
    7062                 :       46036 :   while (1)
    7063                 :             :     {
    7064                 :       28964 :       int nread = gzread (module_fp, module_content + len, rsize);
    7065                 :       28964 :       len += nread;
    7066                 :       28964 :       if (nread < rsize)
    7067                 :             :         break;
    7068                 :       17072 :       cursz *= 2;
    7069                 :       17072 :       module_content = XRESIZEVEC (char, module_content, cursz);
    7070                 :       17072 :       rsize = cursz - len;
    7071                 :       17072 :     }
    7072                 :             : 
    7073                 :       11892 :   module_content = XRESIZEVEC (char, module_content, len + 1);
    7074                 :       11892 :   module_content[len] = '\0';
    7075                 :             : 
    7076                 :       11892 :   module_pos = 0;
    7077                 :       11892 : }
    7078                 :             : 
    7079                 :             : 
    7080                 :             : /* USE the ISO_FORTRAN_ENV intrinsic module.  */
    7081                 :             : 
    7082                 :             : static void
    7083                 :         445 : use_iso_fortran_env_module (void)
    7084                 :             : {
    7085                 :         445 :   static char mod[] = "iso_fortran_env";
    7086                 :         445 :   gfc_use_rename *u;
    7087                 :         445 :   gfc_symbol *mod_sym;
    7088                 :         445 :   gfc_symtree *mod_symtree;
    7089                 :         445 :   gfc_expr *expr;
    7090                 :         445 :   int i, j;
    7091                 :             : 
    7092                 :         445 :   intmod_sym symbol[] = {
    7093                 :             : #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
    7094                 :             : #define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
    7095                 :             : #define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
    7096                 :             : #define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
    7097                 :             : #define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d },
    7098                 :             : #include "iso-fortran-env.def"
    7099                 :             :     { ISOFORTRANENV_INVALID, NULL, -1234, 0 } };
    7100                 :             : 
    7101                 :         445 :   i = 0;
    7102                 :             : #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
    7103                 :             : #include "iso-fortran-env.def"
    7104                 :             : 
    7105                 :             :   /* Generate the symbol for the module itself.  */
    7106                 :         445 :   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
    7107                 :         445 :   if (mod_symtree == NULL)
    7108                 :             :     {
    7109                 :         444 :       gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree, false);
    7110                 :         444 :       gcc_assert (mod_symtree);
    7111                 :         444 :       mod_sym = mod_symtree->n.sym;
    7112                 :             : 
    7113                 :         444 :       mod_sym->attr.flavor = FL_MODULE;
    7114                 :         444 :       mod_sym->attr.intrinsic = 1;
    7115                 :         444 :       mod_sym->module = gfc_get_string ("%s", mod);
    7116                 :         444 :       mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
    7117                 :             :     }
    7118                 :             :   else
    7119                 :           1 :     if (!mod_symtree->n.sym->attr.intrinsic)
    7120                 :           1 :       gfc_error ("Use of intrinsic module %qs at %C conflicts with "
    7121                 :             :                  "non-intrinsic module name used previously", mod);
    7122                 :             : 
    7123                 :             :   /* Generate the symbols for the module integer named constants.  */
    7124                 :             : 
    7125                 :       14685 :   for (i = 0; symbol[i].name; i++)
    7126                 :             :     {
    7127                 :       14240 :       bool found = false;
    7128                 :       24064 :       for (u = gfc_rename_list; u; u = u->next)
    7129                 :             :         {
    7130                 :        9824 :           if (strcmp (symbol[i].name, u->use_name) == 0)
    7131                 :             :             {
    7132                 :         307 :               found = true;
    7133                 :         307 :               u->found = 1;
    7134                 :             : 
    7135                 :         307 :               if (!gfc_notify_std (symbol[i].standard, "The symbol %qs, "
    7136                 :             :                                    "referenced at %L, is not in the selected "
    7137                 :             :                                    "standard", symbol[i].name, &u->where))
    7138                 :           5 :                 continue;
    7139                 :             : 
    7140                 :         302 :               if ((flag_default_integer || flag_default_real_8)
    7141                 :           2 :                   && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
    7142                 :           0 :                 gfc_warning_now (0, "Use of the NUMERIC_STORAGE_SIZE named "
    7143                 :             :                                  "constant from intrinsic module "
    7144                 :             :                                  "ISO_FORTRAN_ENV at %L is incompatible with "
    7145                 :             :                                  "option %qs", &u->where,
    7146                 :             :                                  flag_default_integer
    7147                 :             :                                    ? "-fdefault-integer-8"
    7148                 :             :                                    : "-fdefault-real-8");
    7149                 :         302 :               switch (symbol[i].id)
    7150                 :             :                 {
    7151                 :             : #define NAMED_INTCST(a,b,c,d) \
    7152                 :             :                 case a:
    7153                 :             : #include "iso-fortran-env.def"
    7154                 :         219 :                   create_int_parameter (u->local_name[0] ? u->local_name
    7155                 :             :                                                          : u->use_name,
    7156                 :             :                                         symbol[i].value, mod,
    7157                 :             :                                         INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
    7158                 :         219 :                   break;
    7159                 :             : 
    7160                 :             : #define NAMED_KINDARRAY(a,b,KINDS,d) \
    7161                 :             :                 case a:\
    7162                 :             :                   expr = gfc_get_array_expr (BT_INTEGER, \
    7163                 :             :                                              gfc_default_integer_kind,\
    7164                 :             :                                              NULL); \
    7165                 :             :                   for (j = 0; KINDS[j].kind != 0; j++) \
    7166                 :             :                     gfc_constructor_append_expr (&expr->value.constructor, \
    7167                 :             :                         gfc_get_int_expr (gfc_default_integer_kind, NULL, \
    7168                 :             :                                           KINDS[j].kind), NULL); \
    7169                 :             :                   create_int_parameter_array (u->local_name[0] ? u->local_name \
    7170                 :             :                                                          : u->use_name, \
    7171                 :             :                                               j, expr, mod, \
    7172                 :             :                                               INTMOD_ISO_FORTRAN_ENV, \
    7173                 :             :                                               symbol[i].id); \
    7174                 :             :                   break;
    7175                 :             : #include "iso-fortran-env.def"
    7176                 :             : 
    7177                 :             : #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
    7178                 :             :                 case a:
    7179                 :             : #include "iso-fortran-env.def"
    7180                 :          32 :                   create_derived_type (u->local_name[0] ? u->local_name
    7181                 :             :                                                         : u->use_name,
    7182                 :             :                                        mod, INTMOD_ISO_FORTRAN_ENV,
    7183                 :             :                                        symbol[i].id);
    7184                 :          32 :                   break;
    7185                 :             : 
    7186                 :             : #define NAMED_FUNCTION(a,b,c,d) \
    7187                 :             :                 case a:
    7188                 :             : #include "iso-fortran-env.def"
    7189                 :          15 :                   create_intrinsic_function (u->local_name[0] ? u->local_name
    7190                 :             :                                                               : u->use_name,
    7191                 :             :                                              symbol[i].id, mod,
    7192                 :             :                                              INTMOD_ISO_FORTRAN_ENV, false,
    7193                 :             :                                              NULL);
    7194                 :          15 :                   break;
    7195                 :             : 
    7196                 :           0 :                 default:
    7197                 :           0 :                   gcc_unreachable ();
    7198                 :             :                 }
    7199                 :             :             }
    7200                 :             :         }
    7201                 :             : 
    7202                 :       14240 :       if (!found && !only_flag)
    7203                 :             :         {
    7204                 :        8529 :           if ((gfc_option.allow_std & symbol[i].standard) == 0)
    7205                 :          71 :             continue;
    7206                 :             : 
    7207                 :        8458 :           if ((flag_default_integer || flag_default_real_8)
    7208                 :           0 :               && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
    7209                 :           0 :             gfc_warning_now (0,
    7210                 :             :                              "Use of the NUMERIC_STORAGE_SIZE named constant "
    7211                 :             :                              "from intrinsic module ISO_FORTRAN_ENV at %C is "
    7212                 :             :                              "incompatible with option %s",
    7213                 :             :                              flag_default_integer
    7214                 :             :                                 ? "-fdefault-integer-8" : "-fdefault-real-8");
    7215                 :             : 
    7216                 :        8458 :           switch (symbol[i].id)
    7217                 :             :             {
    7218                 :             : #define NAMED_INTCST(a,b,c,d) \
    7219                 :             :             case a:
    7220                 :             : #include "iso-fortran-env.def"
    7221                 :        6083 :               create_int_parameter (symbol[i].name, symbol[i].value, mod,
    7222                 :             :                                     INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
    7223                 :        6083 :               break;
    7224                 :             : 
    7225                 :             : #define NAMED_KINDARRAY(a,b,KINDS,d) \
    7226                 :             :             case a:\
    7227                 :             :               expr = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, \
    7228                 :             :                                          NULL); \
    7229                 :             :               for (j = 0; KINDS[j].kind != 0; j++) \
    7230                 :             :                 gfc_constructor_append_expr (&expr->value.constructor, \
    7231                 :             :                       gfc_get_int_expr (gfc_default_integer_kind, NULL, \
    7232                 :             :                                         KINDS[j].kind), NULL); \
    7233                 :             :             create_int_parameter_array (symbol[i].name, j, expr, mod, \
    7234                 :             :                                         INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
    7235                 :             :             break;
    7236                 :             : #include "iso-fortran-env.def"
    7237                 :             : 
    7238                 :             : #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
    7239                 :             :           case a:
    7240                 :             : #include "iso-fortran-env.def"
    7241                 :         792 :             create_derived_type (symbol[i].name, mod, INTMOD_ISO_FORTRAN_ENV,
    7242                 :             :                                  symbol[i].id);
    7243                 :         792 :             break;
    7244                 :             : 
    7245                 :             : #define NAMED_FUNCTION(a,b,c,d) \
    7246                 :             :                 case a:
    7247                 :             : #include "iso-fortran-env.def"
    7248                 :         527 :                   create_intrinsic_function (symbol[i].name, symbol[i].id, mod,
    7249                 :             :                                              INTMOD_ISO_FORTRAN_ENV, false,
    7250                 :             :                                              NULL);
    7251                 :         527 :                   break;
    7252                 :             : 
    7253                 :           0 :           default:
    7254                 :           0 :             gcc_unreachable ();
    7255                 :             :           }
    7256                 :             :         }
    7257                 :             :     }
    7258                 :             : 
    7259                 :         752 :   for (u = gfc_rename_list; u; u = u->next)
    7260                 :             :     {
    7261                 :         307 :       if (u->found)
    7262                 :         307 :         continue;
    7263                 :             : 
    7264                 :           0 :       gfc_error ("Symbol %qs referenced at %L not found in intrinsic "
    7265                 :           0 :                      "module ISO_FORTRAN_ENV", u->use_name, &u->where);
    7266                 :             :     }
    7267                 :         445 : }
    7268                 :             : 
    7269                 :             : 
    7270                 :             : /* Process a USE directive.  */
    7271                 :             : 
    7272                 :             : static void
    7273                 :       20206 : gfc_use_module (gfc_use_list *module)
    7274                 :             : {
    7275                 :       20206 :   char *filename;
    7276                 :       20206 :   gfc_state_data *p;
    7277                 :       20206 :   int c, line, start;
    7278                 :       20206 :   gfc_symtree *mod_symtree;
    7279                 :       20206 :   gfc_use_list *use_stmt;
    7280                 :       20206 :   locus old_locus = gfc_current_locus;
    7281                 :             : 
    7282                 :       20206 :   gfc_current_locus = module->where;
    7283                 :       20206 :   module_name = module->module_name;
    7284                 :       20206 :   gfc_rename_list = module->rename;
    7285                 :       20206 :   only_flag = module->only_flag;
    7286                 :       20206 :   current_intmod = INTMOD_NONE;
    7287                 :             : 
    7288                 :       20206 :   if (!only_flag)
    7289                 :       13418 :     gfc_warning_now (OPT_Wuse_without_only,
    7290                 :             :                      "USE statement at %C has no ONLY qualifier");
    7291                 :             : 
    7292                 :       20206 :   if (gfc_state_stack->state == COMP_MODULE
    7293                 :       17906 :       || module->submodule_name == NULL)
    7294                 :             :     {
    7295                 :       20015 :       filename = XALLOCAVEC (char, strlen (module_name)
    7296                 :             :                                    + strlen (MODULE_EXTENSION) + 1);
    7297                 :       20015 :       strcpy (filename, module_name);
    7298                 :       20015 :       strcat (filename, MODULE_EXTENSION);
    7299                 :             :     }
    7300                 :             :   else
    7301                 :             :     {
    7302                 :         191 :       filename = XALLOCAVEC (char, strlen (module->submodule_name)
    7303                 :             :                                    + strlen (SUBMODULE_EXTENSION) + 1);
    7304                 :         191 :       strcpy (filename, module->submodule_name);
    7305                 :         191 :       strcat (filename, SUBMODULE_EXTENSION);
    7306                 :             :     }
    7307                 :             : 
    7308                 :             :   /* First, try to find an non-intrinsic module, unless the USE statement
    7309                 :             :      specified that the module is intrinsic.  */
    7310                 :       20206 :   module_fp = NULL;
    7311                 :       20206 :   if (!module->intrinsic)
    7312                 :       17695 :     module_fp = gzopen_included_file (filename, true, true);
    7313                 :             : 
    7314                 :             :   /* Then, see if it's an intrinsic one, unless the USE statement
    7315                 :             :      specified that the module is non-intrinsic.  */
    7316                 :       20206 :   if (module_fp == NULL && !module->non_intrinsic)
    7317                 :             :     {
    7318                 :        9081 :       if (strcmp (module_name, "iso_fortran_env") == 0
    7319                 :        9081 :           && gfc_notify_std (GFC_STD_F2003, "ISO_FORTRAN_ENV "
    7320                 :             :                              "intrinsic module at %C"))
    7321                 :             :        {
    7322                 :         445 :          use_iso_fortran_env_module ();
    7323                 :         445 :          free_rename (module->rename);
    7324                 :         445 :          module->rename = NULL;
    7325                 :         445 :          gfc_current_locus = old_locus;
    7326                 :         445 :          module->intrinsic = true;
    7327                 :         445 :          return;
    7328                 :             :        }
    7329                 :             : 
    7330                 :        8636 :       if (strcmp (module_name, "iso_c_binding") == 0
    7331                 :        8636 :           && gfc_notify_std (GFC_STD_F2003, "ISO_C_BINDING module at %C"))
    7332                 :             :         {
    7333                 :        7866 :           import_iso_c_binding_module();
    7334                 :        7866 :           free_rename (module->rename);
    7335                 :        7866 :           module->rename = NULL;
    7336                 :        7866 :           gfc_current_locus = old_locus;
    7337                 :        7866 :           module->intrinsic = true;
    7338                 :        7866 :           return;
    7339                 :             :         }
    7340                 :             : 
    7341                 :         770 :       module_fp = gzopen_intrinsic_module (filename);
    7342                 :             : 
    7343                 :         770 :       if (module_fp == NULL && module->intrinsic)
    7344                 :           0 :         gfc_fatal_error ("Cannot find an intrinsic module named %qs at %C",
    7345                 :             :                          module_name);
    7346                 :             : 
    7347                 :             :       /* Check for the IEEE modules, so we can mark their symbols
    7348                 :             :          accordingly when we read them.  */
    7349                 :         770 :       if (strcmp (module_name, "ieee_features") == 0
    7350                 :         770 :           && gfc_notify_std (GFC_STD_F2003, "IEEE_FEATURES module at %C"))
    7351                 :             :         {
    7352                 :          61 :           current_intmod = INTMOD_IEEE_FEATURES;
    7353                 :             :         }
    7354                 :         709 :       else if (strcmp (module_name, "ieee_exceptions") == 0
    7355                 :         709 :                && gfc_notify_std (GFC_STD_F2003,
    7356                 :             :                                   "IEEE_EXCEPTIONS module at %C"))
    7357                 :             :         {
    7358                 :          60 :           current_intmod = INTMOD_IEEE_EXCEPTIONS;
    7359                 :             :         }
    7360                 :         649 :       else if (strcmp (module_name, "ieee_arithmetic") == 0
    7361                 :         649 :                && gfc_notify_std (GFC_STD_F2003,
    7362                 :             :                                   "IEEE_ARITHMETIC module at %C"))
    7363                 :             :         {
    7364                 :         350 :           current_intmod = INTMOD_IEEE_ARITHMETIC;
    7365                 :             :         }
    7366                 :             :     }
    7367                 :             : 
    7368                 :       11895 :   if (module_fp == NULL)
    7369                 :             :     {
    7370                 :           3 :       if (gfc_state_stack->state != COMP_SUBMODULE
    7371                 :           2 :           && module->submodule_name == NULL)
    7372                 :           2 :         gfc_fatal_error ("Cannot open module file %qs for reading at %C: %s",
    7373                 :           2 :                          filename, xstrerror (errno));
    7374                 :             :       else
    7375                 :           1 :         gfc_fatal_error ("Module file %qs has not been generated, either "
    7376                 :             :                          "because the module does not contain a MODULE "
    7377                 :             :                          "PROCEDURE or there is an error in the module.",
    7378                 :             :                          filename);
    7379                 :             :     }
    7380                 :             : 
    7381                 :             :   /* Check that we haven't already USEd an intrinsic module with the
    7382                 :             :      same name.  */
    7383                 :             : 
    7384                 :       11892 :   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name);
    7385                 :       11892 :   if (mod_symtree && mod_symtree->n.sym->attr.intrinsic)
    7386                 :           1 :     gfc_error ("Use of non-intrinsic module %qs at %C conflicts with "
    7387                 :             :                "intrinsic module name used previously", module_name);
    7388                 :             : 
    7389                 :       11892 :   iomode = IO_INPUT;
    7390                 :       11892 :   module_line = 1;
    7391                 :       11892 :   module_column = 1;
    7392                 :       11892 :   start = 0;
    7393                 :             : 
    7394                 :       11892 :   read_module_to_tmpbuf ();
    7395                 :       11892 :   gzclose (module_fp);
    7396                 :             : 
    7397                 :             :   /* Skip the first line of the module, after checking that this is
    7398                 :             :      a gfortran module file.  */
    7399                 :       11892 :   line = 0;
    7400                 :      443628 :   while (line < 1)
    7401                 :             :     {
    7402                 :      419844 :       c = module_char ();
    7403                 :      419844 :       if (c == EOF)
    7404                 :           0 :         bad_module ("Unexpected end of module");
    7405                 :      419844 :       if (start++ < 3)
    7406                 :       35676 :         parse_name (c);
    7407                 :      419844 :       if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0)
    7408                 :      419844 :           || (start == 2 && strcmp (atom_name, " module") != 0))
    7409                 :           0 :         gfc_fatal_error ("File %qs opened at %C is not a GNU Fortran"
    7410                 :             :                          " module file", module_fullpath);
    7411                 :      419844 :       if (start == 3)
    7412                 :             :         {
    7413                 :       11892 :           if (strcmp (atom_name, " version") != 0
    7414                 :       11892 :               || module_char () != ' '
    7415                 :       11892 :               || parse_atom () != ATOM_STRING
    7416                 :       23784 :               || strcmp (atom_string, MOD_VERSION))
    7417                 :           0 :             gfc_fatal_error ("Cannot read module file %qs opened at %C,"
    7418                 :             :                              " because it was created by a different"
    7419                 :             :                              " version of GNU Fortran", module_fullpath);
    7420                 :             : 
    7421                 :       11892 :           free (atom_string);
    7422                 :             :         }
    7423                 :             : 
    7424                 :      419844 :       if (c == '\n')
    7425                 :       11892 :         line++;
    7426                 :             :     }
    7427                 :             : 
    7428                 :             :   /* Make sure we're not reading the same module that we may be building.  */
    7429                 :       39587 :   for (p = gfc_state_stack; p; p = p->previous)
    7430                 :       27695 :     if ((p->state == COMP_MODULE || p->state == COMP_SUBMODULE)
    7431                 :        2072 :          && strcmp (p->sym->name, module_name) == 0)
    7432                 :             :       {
    7433                 :           0 :         if (p->state == COMP_SUBMODULE)
    7434                 :           0 :           gfc_fatal_error ("Cannot USE a submodule that is currently built");
    7435                 :             :         else
    7436                 :           0 :           gfc_fatal_error ("Cannot USE a module that is currently built");
    7437                 :             :       }
    7438                 :             : 
    7439                 :       11892 :   init_pi_tree ();
    7440                 :       11892 :   init_true_name_tree ();
    7441                 :             : 
    7442                 :       11892 :   read_module ();
    7443                 :             : 
    7444                 :       11892 :   free_true_name (true_name_root);
    7445                 :       11892 :   true_name_root = NULL;
    7446                 :             : 
    7447                 :       11892 :   free_pi_tree (pi_root);
    7448                 :       11892 :   pi_root = NULL;
    7449                 :             : 
    7450                 :       11892 :   XDELETEVEC (module_content);
    7451                 :       11892 :   module_content = NULL;
    7452                 :             : 
    7453                 :       11892 :   use_stmt = gfc_get_use_list ();
    7454                 :       11892 :   *use_stmt = *module;
    7455                 :       11892 :   use_stmt->next = gfc_current_ns->use_stmts;
    7456                 :       11892 :   gfc_current_ns->use_stmts = use_stmt;
    7457                 :             : 
    7458                 :       11892 :   gfc_current_locus = old_locus;
    7459                 :             : }
    7460                 :             : 
    7461                 :             : 
    7462                 :             : /* Remove duplicated intrinsic operators from the rename list.  */
    7463                 :             : 
    7464                 :             : static void
    7465                 :       20206 : rename_list_remove_duplicate (gfc_use_rename *list)
    7466                 :             : {
    7467                 :       20206 :   gfc_use_rename *seek, *last;
    7468                 :             : 
    7469                 :       31076 :   for (; list; list = list->next)
    7470                 :       10870 :     if (list->op != INTRINSIC_USER && list->op != INTRINSIC_NONE)
    7471                 :             :       {
    7472                 :         107 :         last = list;
    7473                 :         453 :         for (seek = list->next; seek; seek = last->next)
    7474                 :             :           {
    7475                 :         346 :             if (list->op == seek->op)
    7476                 :             :               {
    7477                 :           2 :                 last->next = seek->next;
    7478                 :           2 :                 free (seek);
    7479                 :             :               }
    7480                 :             :             else
    7481                 :             :               last = seek;
    7482                 :             :           }
    7483                 :             :       }
    7484                 :       20206 : }
    7485                 :             : 
    7486                 :             : 
    7487                 :             : /* Process all USE directives.  */
    7488                 :             : 
    7489                 :             : void
    7490                 :       17439 : gfc_use_modules (void)
    7491                 :             : {
    7492                 :       17439 :   gfc_use_list *next, *seek, *last;
    7493                 :             : 
    7494                 :       37645 :   for (next = module_list; next; next = next->next)
    7495                 :             :     {
    7496                 :       20206 :       bool non_intrinsic = next->non_intrinsic;
    7497                 :       20206 :       bool intrinsic = next->intrinsic;
    7498                 :       20206 :       bool neither = !non_intrinsic && !intrinsic;
    7499                 :             : 
    7500                 :       23758 :       for (seek = next->next; seek; seek = seek->next)
    7501                 :             :         {
    7502                 :        3552 :           if (next->module_name != seek->module_name)
    7503                 :        3356 :             continue;
    7504                 :             : 
    7505                 :         196 :           if (seek->non_intrinsic)
    7506                 :             :             non_intrinsic = true;
    7507                 :         195 :           else if (seek->intrinsic)
    7508                 :             :             intrinsic = true;
    7509                 :             :           else
    7510                 :         155 :             neither = true;
    7511                 :             :         }
    7512                 :             : 
    7513                 :       20206 :       if (intrinsic && neither && !non_intrinsic)
    7514                 :             :         {
    7515                 :           1 :           char *filename;
    7516                 :           1 :           FILE *fp;
    7517                 :             : 
    7518                 :           1 :           filename = XALLOCAVEC (char,
    7519                 :             :                                  strlen (next->module_name)
    7520                 :             :                                  + strlen (MODULE_EXTENSION) + 1);
    7521                 :           1 :           strcpy (filename, next->module_name);
    7522                 :           1 :           strcat (filename, MODULE_EXTENSION);
    7523                 :           1 :           fp = gfc_open_included_file (filename, true, true);
    7524                 :           1 :           if (fp != NULL)
    7525                 :             :             {
    7526                 :           0 :               non_intrinsic = true;
    7527                 :           0 :               fclose (fp);
    7528                 :             :             }
    7529                 :             :         }
    7530                 :             : 
    7531                 :       20206 :       last = next;
    7532                 :       23758 :       for (seek = next->next; seek; seek = last->next)
    7533                 :             :         {
    7534                 :        3552 :           if (next->module_name != seek->module_name)
    7535                 :             :             {
    7536                 :        3356 :               last = seek;
    7537                 :        3356 :               continue;
    7538                 :             :             }
    7539                 :             : 
    7540                 :         196 :           if ((!next->intrinsic && !seek->intrinsic)
    7541                 :          41 :               || (next->intrinsic && seek->intrinsic)
    7542                 :           3 :               || !non_intrinsic)
    7543                 :             :             {
    7544                 :         194 :               if (!seek->only_flag)
    7545                 :          33 :                 next->only_flag = false;
    7546                 :         194 :               if (seek->rename)
    7547                 :             :                 {
    7548                 :             :                   gfc_use_rename *r = seek->rename;
    7549                 :         321 :                   while (r->next)
    7550                 :             :                     r = r->next;
    7551                 :         174 :                   r->next = next->rename;
    7552                 :         174 :                   next->rename = seek->rename;
    7553                 :             :                 }
    7554                 :         194 :               last->next = seek->next;
    7555                 :         194 :               free (seek);
    7556                 :         194 :             }
    7557                 :             :           else
    7558                 :             :             last = seek;
    7559                 :             :         }
    7560                 :             :     }
    7561                 :             : 
    7562                 :       37642 :   for (; module_list; module_list = next)
    7563                 :             :     {
    7564                 :       20206 :       next = module_list->next;
    7565                 :       20206 :       rename_list_remove_duplicate (module_list->rename);
    7566                 :       20206 :       gfc_use_module (module_list);
    7567                 :       20203 :       free (module_list);
    7568                 :             :     }
    7569                 :       17436 :   module_list = NULL;
    7570                 :       17436 :   old_module_list_tail = &module_list;
    7571                 :       17436 :   gfc_rename_list = NULL;
    7572                 :       17436 : }
    7573                 :             : 
    7574                 :             : 
    7575                 :             : void
    7576                 :     7910344 : gfc_free_use_stmts (gfc_use_list *use_stmts)
    7577                 :             : {
    7578                 :     7910344 :   gfc_use_list *next;
    7579                 :     7922241 :   for (; use_stmts; use_stmts = next)
    7580                 :             :     {
    7581                 :             :       gfc_use_rename *next_rename;
    7582                 :             : 
    7583                 :       14648 :       for (; use_stmts->rename; use_stmts->rename = next_rename)
    7584                 :             :         {
    7585                 :        2751 :           next_rename = use_stmts->rename->next;
    7586                 :        2751 :           free (use_stmts->rename);
    7587                 :             :         }
    7588                 :       11897 :       next = use_stmts->next;
    7589                 :       11897 :       free (use_stmts);
    7590                 :             :     }
    7591                 :     7910344 : }
    7592                 :             : 
    7593                 :             : 
    7594                 :             : /* Remember the end of the MODULE_LIST list, so that the list can be restored
    7595                 :             :    to its previous state if the current statement is erroneous.  */
    7596                 :             : 
    7597                 :             : void
    7598                 :     1180864 : gfc_save_module_list ()
    7599                 :             : {
    7600                 :     1180864 :   gfc_use_list **tail = &module_list;
    7601                 :     1206616 :   while (*tail != NULL)
    7602                 :       25752 :     tail = &(*tail)->next;
    7603                 :     1180864 :   old_module_list_tail = tail;
    7604                 :     1180864 : }
    7605                 :             : 
    7606                 :             : 
    7607                 :             : /* Restore the MODULE_LIST list to its previous value and free the use
    7608                 :             :    statements that are no longer part of the list.  */
    7609                 :             : 
    7610                 :             : void
    7611                 :     7468108 : gfc_restore_old_module_list ()
    7612                 :             : {
    7613                 :     7468108 :   gfc_free_use_stmts (*old_module_list_tail);
    7614                 :     7468108 :   *old_module_list_tail = NULL;
    7615                 :     7468108 : }
    7616                 :             : 
    7617                 :             : 
    7618                 :             : void
    7619                 :       75305 : gfc_module_init_2 (void)
    7620                 :             : {
    7621                 :       75305 :   last_atom = ATOM_LPAREN;
    7622                 :       75305 :   gfc_rename_list = NULL;
    7623                 :       75305 :   module_list = NULL;
    7624                 :       75305 : }
    7625                 :             : 
    7626                 :             : 
    7627                 :             : void
    7628                 :       75602 : gfc_module_done_2 (void)
    7629                 :             : {
    7630                 :       75602 :   free_rename (gfc_rename_list);
    7631                 :       75602 :   gfc_rename_list = NULL;
    7632                 :       75602 : }
        

Generated by: LCOV version 2.0-1

LCOV profile is generated on x86_64 machine using following configure options: configure --disable-bootstrap --enable-coverage=opt --enable-languages=c,c++,fortran,go,jit,lto,rust,m2 --enable-host-shared. GCC test suite is run with the built compiler.