gcc/fortran/module.c

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