gcc/fortran/module.c

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