gcc/fortran/module.c

   1 /* Handle modules, which amounts to loading and saving symbols and
   2    their attendant structures.
   3    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
   4    Free Software Foundation, Inc.
   5    Contributed by Andy Vaught
   6
   7 This file is part of GCC.
   8
   9 GCC is free software; you can redistribute it and/or modify it under
  10 the terms of the GNU General Public License as published by the Free
  11 Software Foundation; either version 3, or (at your option) any later
  12 version.
  13
  14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  17 for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with GCC; see the file COPYING3.  If not see
  21 <http://www.gnu.org/licenses/>.  */
  22
  23 /* The syntax of gfortran modules resembles that of lisp lists, i.e. a
  24    sequence of atoms, which can be left or right parenthesis, names,
  25    integers or strings.  Parenthesis are always matched which allows
  26    us to skip over sections at high speed without having to know
  27    anything about the internal structure of the lists.  A "name" is
  28    usually a fortran 95 identifier, but can also start with '@' in
  29    order to reference a hidden symbol.
  30
  31    The first line of a module is an informational message about what
  32    created the module, the file it came from and when it was created.
  33    The second line is a warning for people not to edit the module.
  34    The rest of the module looks like:
  35
  36    ( ( <Interface info for UPLUS> )
  37      ( <Interface info for UMINUS> )
  38      ...
  39    )
  40    ( ( <name of operator interface> <module of op interface> <i/f1> ... )
  41      ...
  42    )
  43    ( ( <name of generic interface> <module of generic interface> <i/f1> ... )
  44      ...
  45    )
  46    ( ( <common name> <symbol> <saved flag>)
  47      ...
  48    )
  49
  50    ( equivalence list )
  51
  52    ( <Symbol Number (in no particular order)>
  53      <True name of symbol>
  54      <Module name of symbol>
  55      ( <symbol information> )
  56      ...
  57    )
  58    ( <Symtree name>
  59      <Ambiguous flag>
  60      <Symbol number>
  61      ...
  62    )
  63
  64    In general, symbols refer to other symbols by their symbol number,
  65    which are zero based.  Symbols are written to the module in no
  66    particular order.  */
  67
  68 #include "config.h"
  69 #include "system.h"
  70 #include "gfortran.h"
  71 #include "arith.h"
  72 #include "match.h"
  73 #include "parse.h" /* FIXME */
  74 #include "md5.h"
  75
  76 #define MODULE_EXTENSION ".mod"
  77
  78 /* Don't put any single quote (') in MOD_VERSION,
  79    if yout want it to be recognized.  */
  80 #define MOD_VERSION "2"
  81
  82
  83 /* Structure that describes a position within a module file.  */
  84
  85 typedef struct
  86 {
  87   int column, line;
  88   fpos_t pos;
  89 }
  90 module_locus;
  91
  92 /* Structure for list of symbols of intrinsic modules.  */
  93 typedef struct
  94 {
  95   int id;
  96   const char *name;
  97   int value;
  98   int standard;
  99 }
 100 intmod_sym;
 101
 102
 103 typedef enum
 104 {
 105   P_UNKNOWN = 0, P_OTHER, P_NAMESPACE, P_COMPONENT, P_SYMBOL
 106 }
 107 pointer_t;
 108
 109 /* The fixup structure lists pointers to pointers that have to
 110    be updated when a pointer value becomes known.  */
 111
 112 typedef struct fixup_t
 113 {
 114   void **pointer;
 115   struct fixup_t *next;
 116 }
 117 fixup_t;
 118
 119
 120 /* Structure for holding extra info needed for pointers being read.  */
 121
 122 enum gfc_rsym_state
 123 {
 124   UNUSED,
 125   NEEDED,
 126   USED
 127 };
 128
 129 enum gfc_wsym_state
 130 {
 131   UNREFERENCED = 0,
 132   NEEDS_WRITE,
 133   WRITTEN
 134 };
 135
 136 typedef struct pointer_info
 137 {
 138   BBT_HEADER (pointer_info);
 139   int integer;
 140   pointer_t type;
 141
 142   /* The first component of each member of the union is the pointer
 143      being stored.  */
 144
 145   fixup_t *fixup;
 146
 147   union
 148   {
 149     void *pointer;      /* Member for doing pointer searches.  */
 150
 151     struct
 152     {
 153       gfc_symbol *sym;
 154       char true_name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
 155       enum gfc_rsym_state state;
 156       int ns, referenced, renamed;
 157       module_locus where;
 158       fixup_t *stfixup;
 159       gfc_symtree *symtree;
 160       char binding_label[GFC_MAX_SYMBOL_LEN + 1];
 161     }
 162     rsym;
 163
 164     struct
 165     {
 166       gfc_symbol *sym;
 167       enum gfc_wsym_state state;
 168     }
 169     wsym;
 170   }
 171   u;
 172
 173 }
 174 pointer_info;
 175
 176 #define gfc_get_pointer_info() XCNEW (pointer_info)
 177
 178
 179 /* Local variables */
 180
 181 /* The FILE for the module we're reading or writing.  */
 182 static FILE *module_fp;
 183
 184 /* MD5 context structure.  */
 185 static struct md5_ctx ctx;
 186
 187 /* The name of the module we're reading (USE'ing) or writing.  */
 188 static char module_name[GFC_MAX_SYMBOL_LEN + 1];
 189
 190 /* The way the module we're reading was specified.  */
 191 static bool specified_nonint, specified_int;
 192
 193 static int module_line, module_column, only_flag;
 194 static enum
 195 { IO_INPUT, IO_OUTPUT }
 196 iomode;
 197
 198 static gfc_use_rename *gfc_rename_list;
 199 static pointer_info *pi_root;
 200 static int symbol_number;       /* Counter for assigning symbol numbers */
 201
 202 /* Tells mio_expr_ref to make symbols for unused equivalence members.  */
 203 static bool in_load_equiv;
 204
 205 static locus use_locus;
 206
 207
 208
 209 /*****************************************************************/
 210
 211 /* Pointer/integer conversion.  Pointers between structures are stored
 212    as integers in the module file.  The next couple of subroutines
 213    handle this translation for reading and writing.  */
 214
 215 /* Recursively free the tree of pointer structures.  */
 216
 217 static void
 218 free_pi_tree (pointer_info *p)
 219 {
 220   if (p == NULL)
 221     return;
 222
 223   if (p->fixup != NULL)
 224     gfc_internal_error ("free_pi_tree(): Unresolved fixup");
 225
 226   free_pi_tree (p->left);
 227   free_pi_tree (p->right);
 228
 229   gfc_free (p);
 230 }
 231
 232
 233 /* Compare pointers when searching by pointer.  Used when writing a
 234    module.  */
 235
 236 static int
 237 compare_pointers (void *_sn1, void *_sn2)
 238 {
 239   pointer_info *sn1, *sn2;
 240
 241   sn1 = (pointer_info *) _sn1;
 242   sn2 = (pointer_info *) _sn2;
 243
 244   if (sn1->u.pointer < sn2->u.pointer)
 245     return -1;
 246   if (sn1->u.pointer > sn2->u.pointer)
 247     return 1;
 248
 249   return 0;
 250 }
 251
 252
 253 /* Compare integers when searching by integer.  Used when reading a
 254    module.  */
 255
 256 static int
 257 compare_integers (void *_sn1, void *_sn2)
 258 {
 259   pointer_info *sn1, *sn2;
 260
 261   sn1 = (pointer_info *) _sn1;
 262   sn2 = (pointer_info *) _sn2;
 263
 264   if (sn1->integer < sn2->integer)
 265     return -1;
 266   if (sn1->integer > sn2->integer)
 267     return 1;
 268
 269   return 0;
 270 }
 271
 272
 273 /* Initialize the pointer_info tree.  */
 274
 275 static void
 276 init_pi_tree (void)
 277 {
 278   compare_fn compare;
 279   pointer_info *p;
 280
 281   pi_root = NULL;
 282   compare = (iomode == IO_INPUT) ? compare_integers : compare_pointers;
 283
 284   /* Pointer 0 is the NULL pointer.  */
 285   p = gfc_get_pointer_info ();
 286   p->u.pointer = NULL;
 287   p->integer = 0;
 288   p->type = P_OTHER;
 289
 290   gfc_insert_bbt (&pi_root, p, compare);
 291
 292   /* Pointer 1 is the current namespace.  */
 293   p = gfc_get_pointer_info ();
 294   p->u.pointer = gfc_current_ns;
 295   p->integer = 1;
 296   p->type = P_NAMESPACE;
 297
 298   gfc_insert_bbt (&pi_root, p, compare);
 299
 300   symbol_number = 2;
 301 }
 302
 303
 304 /* During module writing, call here with a pointer to something,
 305    returning the pointer_info node.  */
 306
 307 static pointer_info *
 308 find_pointer (void *gp)
 309 {
 310   pointer_info *p;
 311
 312   p = pi_root;
 313   while (p != NULL)
 314     {
 315       if (p->u.pointer == gp)
 316         break;
 317       p = (gp < p->u.pointer) ? p->left : p->right;
 318     }
 319
 320   return p;
 321 }
 322
 323
 324 /* Given a pointer while writing, returns the pointer_info tree node,
 325    creating it if it doesn't exist.  */
 326
 327 static pointer_info *
 328 get_pointer (void *gp)
 329 {
 330   pointer_info *p;
 331
 332   p = find_pointer (gp);
 333   if (p != NULL)
 334     return p;
 335
 336   /* Pointer doesn't have an integer.  Give it one.  */
 337   p = gfc_get_pointer_info ();
 338
 339   p->u.pointer = gp;
 340   p->integer = symbol_number++;
 341
 342   gfc_insert_bbt (&pi_root, p, compare_pointers);
 343
 344   return p;
 345 }
 346
 347
 348 /* Given an integer during reading, find it in the pointer_info tree,
 349    creating the node if not found.  */
 350
 351 static pointer_info *
 352 get_integer (int integer)
 353 {
 354   pointer_info *p, t;
 355   int c;
 356
 357   t.integer = integer;
 358
 359   p = pi_root;
 360   while (p != NULL)
 361     {
 362       c = compare_integers (&t, p);
 363       if (c == 0)
 364         break;
 365
 366       p = (c < 0) ? p->left : p->right;
 367     }
 368
 369   if (p != NULL)
 370     return p;
 371
 372   p = gfc_get_pointer_info ();
 373   p->integer = integer;
 374   p->u.pointer = NULL;
 375
 376   gfc_insert_bbt (&pi_root, p, compare_integers);
 377
 378   return p;
 379 }
 380
 381
 382 /* Recursive function to find a pointer within a tree by brute force.  */
 383
 384 static pointer_info *
 385 fp2 (pointer_info *p, const void *target)
 386 {
 387   pointer_info *q;
 388
 389   if (p == NULL)
 390     return NULL;
 391
 392   if (p->u.pointer == target)
 393     return p;
 394
 395   q = fp2 (p->left, target);
 396   if (q != NULL)
 397     return q;
 398
 399   return fp2 (p->right, target);
 400 }
 401
 402
 403 /* During reading, find a pointer_info node from the pointer value.
 404    This amounts to a brute-force search.  */
 405
 406 static pointer_info *
 407 find_pointer2 (void *p)
 408 {
 409   return fp2 (pi_root, p);
 410 }
 411
 412
 413 /* Resolve any fixups using a known pointer.  */
 414
 415 static void
 416 resolve_fixups (fixup_t *f, void *gp)
 417 {
 418   fixup_t *next;
 419
 420   for (; f; f = next)
 421     {
 422       next = f->next;
 423       *(f->pointer) = gp;
 424       gfc_free (f);
 425     }
 426 }
 427
 428
 429 /* Call here during module reading when we know what pointer to
 430    associate with an integer.  Any fixups that exist are resolved at
 431    this time.  */
 432
 433 static void
 434 associate_integer_pointer (pointer_info *p, void *gp)
 435 {
 436   if (p->u.pointer != NULL)
 437     gfc_internal_error ("associate_integer_pointer(): Already associated");
 438
 439   p->u.pointer = gp;
 440
 441   resolve_fixups (p->fixup, gp);
 442
 443   p->fixup = NULL;
 444 }
 445
 446
 447 /* During module reading, given an integer and a pointer to a pointer,
 448    either store the pointer from an already-known value or create a
 449    fixup structure in order to store things later.  Returns zero if
 450    the reference has been actually stored, or nonzero if the reference
 451    must be fixed later (i.e., associate_integer_pointer must be called
 452    sometime later.  Returns the pointer_info structure.  */
 453
 454 static pointer_info *
 455 add_fixup (int integer, void *gp)
 456 {
 457   pointer_info *p;
 458   fixup_t *f;
 459   char **cp;
 460
 461   p = get_integer (integer);
 462
 463   if (p->integer == 0 || p->u.pointer != NULL)
 464     {
 465       cp = (char **) gp;
 466       *cp = (char *) p->u.pointer;
 467     }
 468   else
 469     {
 470       f = XCNEW (fixup_t);
 471
 472       f->next = p->fixup;
 473       p->fixup = f;
 474
 475       f->pointer = (void **) gp;
 476     }
 477
 478   return p;
 479 }
 480
 481
 482 /*****************************************************************/
 483
 484 /* Parser related subroutines */
 485
 486 /* Free the rename list left behind by a USE statement.  */
 487
 488 static void
 489 free_rename (void)
 490 {
 491   gfc_use_rename *next;
 492
 493   for (; gfc_rename_list; gfc_rename_list = next)
 494     {
 495       next = gfc_rename_list->next;
 496       gfc_free (gfc_rename_list);
 497     }
 498 }
 499
 500
 501 /* Match a USE statement.  */
 502
 503 match
 504 gfc_match_use (void)
 505 {
 506   char name[GFC_MAX_SYMBOL_LEN + 1], module_nature[GFC_MAX_SYMBOL_LEN + 1];
 507   gfc_use_rename *tail = NULL, *new_use;
 508   interface_type type, type2;
 509   gfc_intrinsic_op op;
 510   match m;
 511
 512   specified_int = false;
 513   specified_nonint = false;
 514
 515   if (gfc_match (" , ") == MATCH_YES)
 516     {
 517       if ((m = gfc_match (" %n ::", module_nature)) == MATCH_YES)
 518         {
 519           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: module "
 520                               "nature in USE statement at %C") == FAILURE)
 521             return MATCH_ERROR;
 522
 523           if (strcmp (module_nature, "intrinsic") == 0)
 524             specified_int = true;
 525           else
 526             {
 527               if (strcmp (module_nature, "non_intrinsic") == 0)
 528                 specified_nonint = true;
 529               else
 530                 {
 531                   gfc_error ("Module nature in USE statement at %C shall "
 532                              "be either INTRINSIC or NON_INTRINSIC");
 533                   return MATCH_ERROR;
 534                 }
 535             }
 536         }
 537       else
 538         {
 539           /* Help output a better error message than "Unclassifiable
 540              statement".  */
 541           gfc_match (" %n", module_nature);
 542           if (strcmp (module_nature, "intrinsic") == 0
 543               || strcmp (module_nature, "non_intrinsic") == 0)
 544             gfc_error ("\"::\" was expected after module nature at %C "
 545                        "but was not found");
 546           return m;
 547         }
 548     }
 549   else
 550     {
 551       m = gfc_match (" ::");
 552       if (m == MATCH_YES &&
 553           gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
 554                           "\"USE :: module\" at %C") == FAILURE)
 555         return MATCH_ERROR;
 556
 557       if (m != MATCH_YES)
 558         {
 559           m = gfc_match ("% ");
 560           if (m != MATCH_YES)
 561             return m;
 562         }
 563     }
 564
 565   use_locus = gfc_current_locus;
 566
 567   m = gfc_match_name (module_name);
 568   if (m != MATCH_YES)
 569     return m;
 570
 571   free_rename ();
 572   only_flag = 0;
 573
 574   if (gfc_match_eos () == MATCH_YES)
 575     return MATCH_YES;
 576   if (gfc_match_char (',') != MATCH_YES)
 577     goto syntax;
 578
 579   if (gfc_match (" only :") == MATCH_YES)
 580     only_flag = 1;
 581
 582   if (gfc_match_eos () == MATCH_YES)
 583     return MATCH_YES;
 584
 585   for (;;)
 586     {
 587       /* Get a new rename struct and add it to the rename list.  */
 588       new_use = gfc_get_use_rename ();
 589       new_use->where = gfc_current_locus;
 590       new_use->found = 0;
 591
 592       if (gfc_rename_list == NULL)
 593         gfc_rename_list = new_use;
 594       else
 595         tail->next = new_use;
 596       tail = new_use;
 597
 598       /* See what kind of interface we're dealing with.  Assume it is
 599          not an operator.  */
 600       new_use->op = INTRINSIC_NONE;
 601       if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
 602         goto cleanup;
 603
 604       switch (type)
 605         {
 606         case INTERFACE_NAMELESS:
 607           gfc_error ("Missing generic specification in USE statement at %C");
 608           goto cleanup;
 609
 610         case INTERFACE_USER_OP:
 611         case INTERFACE_GENERIC:
 612           m = gfc_match (" =>");
 613
 614           if (type == INTERFACE_USER_OP && m == MATCH_YES
 615               && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Renaming "
 616                                   "operators in USE statements at %C")
 617                  == FAILURE))
 618             goto cleanup;
 619
 620           if (type == INTERFACE_USER_OP)
 621             new_use->op = INTRINSIC_USER;
 622
 623           if (only_flag)
 624             {
 625               if (m != MATCH_YES)
 626                 strcpy (new_use->use_name, name);
 627               else
 628                 {
 629                   strcpy (new_use->local_name, name);
 630                   m = gfc_match_generic_spec (&type2, new_use->use_name, &op);
 631                   if (type != type2)
 632                     goto syntax;
 633                   if (m == MATCH_NO)
 634                     goto syntax;
 635                   if (m == MATCH_ERROR)
 636                     goto cleanup;
 637                 }
 638             }
 639           else
 640             {
 641               if (m != MATCH_YES)
 642                 goto syntax;
 643               strcpy (new_use->local_name, name);
 644
 645               m = gfc_match_generic_spec (&type2, new_use->use_name, &op);
 646               if (type != type2)
 647                 goto syntax;
 648               if (m == MATCH_NO)
 649                 goto syntax;
 650               if (m == MATCH_ERROR)
 651                 goto cleanup;
 652             }
 653
 654           if (strcmp (new_use->use_name, module_name) == 0
 655               || strcmp (new_use->local_name, module_name) == 0)
 656             {
 657               gfc_error ("The name '%s' at %C has already been used as "
 658                          "an external module name.", module_name);
 659               goto cleanup;
 660             }
 661           break;
 662
 663         case INTERFACE_INTRINSIC_OP:
 664           new_use->op = op;
 665           break;
 666
 667         default:
 668           gcc_unreachable ();
 669         }
 670
 671       if (gfc_match_eos () == MATCH_YES)
 672         break;
 673       if (gfc_match_char (',') != MATCH_YES)
 674         goto syntax;
 675     }
 676
 677   return MATCH_YES;
 678
 679 syntax:
 680   gfc_syntax_error (ST_USE);
 681
 682 cleanup:
 683   free_rename ();
 684   return MATCH_ERROR;
 685  }
 686
 687
 688 /* Given a name and a number, inst, return the inst name
 689    under which to load this symbol. Returns NULL if this
 690    symbol shouldn't be loaded. If inst is zero, returns
 691    the number of instances of this name. If interface is
 692    true, a user-defined operator is sought, otherwise only
 693    non-operators are sought.  */
 694
 695 static const char *
 696 find_use_name_n (const char *name, int *inst, bool interface)
 697 {
 698   gfc_use_rename *u;
 699   int i;
 700
 701   i = 0;
 702   for (u = gfc_rename_list; u; u = u->next)
 703     {
 704       if (strcmp (u->use_name, name) != 0
 705           || (u->op == INTRINSIC_USER && !interface)
 706           || (u->op != INTRINSIC_USER &&  interface))
 707         continue;
 708       if (++i == *inst)
 709         break;
 710     }
 711
 712   if (!*inst)
 713     {
 714       *inst = i;
 715       return NULL;
 716     }
 717
 718   if (u == NULL)
 719     return only_flag ? NULL : name;
 720
 721   u->found = 1;
 722
 723   return (u->local_name[0] != '\0') ? u->local_name : name;
 724 }
 725
 726
 727 /* Given a name, return the name under which to load this symbol.
 728    Returns NULL if this symbol shouldn't be loaded.  */
 729
 730 static const char *
 731 find_use_name (const char *name, bool interface)
 732 {
 733   int i = 1;
 734   return find_use_name_n (name, &i, interface);
 735 }
 736
 737
 738 /* Given a real name, return the number of use names associated with it.  */
 739
 740 static int
 741 number_use_names (const char *name, bool interface)
 742 {
 743   int i = 0;
 744   const char *c;
 745   c = find_use_name_n (name, &i, interface);
 746   return i;
 747 }
 748
 749
 750 /* Try to find the operator in the current list.  */
 751
 752 static gfc_use_rename *
 753 find_use_operator (gfc_intrinsic_op op)
 754 {
 755   gfc_use_rename *u;
 756
 757   for (u = gfc_rename_list; u; u = u->next)
 758     if (u->op == op)
 759       return u;
 760
 761   return NULL;
 762 }
 763
 764
 765 /*****************************************************************/
 766
 767 /* The next couple of subroutines maintain a tree used to avoid a
 768    brute-force search for a combination of true name and module name.
 769    While symtree names, the name that a particular symbol is known by
 770    can changed with USE statements, we still have to keep track of the
 771    true names to generate the correct reference, and also avoid
 772    loading the same real symbol twice in a program unit.
 773
 774    When we start reading, the true name tree is built and maintained
 775    as symbols are read.  The tree is searched as we load new symbols
 776    to see if it already exists someplace in the namespace.  */
 777
 778 typedef struct true_name
 779 {
 780   BBT_HEADER (true_name);
 781   gfc_symbol *sym;
 782 }
 783 true_name;
 784
 785 static true_name *true_name_root;
 786
 787
 788 /* Compare two true_name structures.  */
 789
 790 static int
 791 compare_true_names (void *_t1, void *_t2)
 792 {
 793   true_name *t1, *t2;
 794   int c;
 795
 796   t1 = (true_name *) _t1;
 797   t2 = (true_name *) _t2;
 798
 799   c = ((t1->sym->module > t2->sym->module)
 800        - (t1->sym->module < t2->sym->module));
 801   if (c != 0)
 802     return c;
 803
 804   return strcmp (t1->sym->name, t2->sym->name);
 805 }
 806
 807
 808 /* Given a true name, search the true name tree to see if it exists
 809    within the main namespace.  */
 810
 811 static gfc_symbol *
 812 find_true_name (const char *name, const char *module)
 813 {
 814   true_name t, *p;
 815   gfc_symbol sym;
 816   int c;
 817
 818   sym.name = gfc_get_string (name);
 819   if (module != NULL)
 820     sym.module = gfc_get_string (module);
 821   else
 822     sym.module = NULL;
 823   t.sym = &sym;
 824
 825   p = true_name_root;
 826   while (p != NULL)
 827     {
 828       c = compare_true_names ((void *) (&t), (void *) p);
 829       if (c == 0)
 830         return p->sym;
 831
 832       p = (c < 0) ? p->left : p->right;
 833     }
 834
 835   return NULL;
 836 }
 837
 838
 839 /* Given a gfc_symbol pointer that is not in the true name tree, add it.  */
 840
 841 static void
 842 add_true_name (gfc_symbol *sym)
 843 {
 844   true_name *t;
 845
 846   t = XCNEW (true_name);
 847   t->sym = sym;
 848
 849   gfc_insert_bbt (&true_name_root, t, compare_true_names);
 850 }
 851
 852
 853 /* Recursive function to build the initial true name tree by
 854    recursively traversing the current namespace.  */
 855
 856 static void
 857 build_tnt (gfc_symtree *st)
 858 {
 859   if (st == NULL)
 860     return;
 861
 862   build_tnt (st->left);
 863   build_tnt (st->right);
 864
 865   if (find_true_name (st->n.sym->name, st->n.sym->module) != NULL)
 866     return;
 867
 868   add_true_name (st->n.sym);
 869 }
 870
 871
 872 /* Initialize the true name tree with the current namespace.  */
 873
 874 static void
 875 init_true_name_tree (void)
 876 {
 877   true_name_root = NULL;
 878   build_tnt (gfc_current_ns->sym_root);
 879 }
 880
 881
 882 /* Recursively free a true name tree node.  */
 883
 884 static void
 885 free_true_name (true_name *t)
 886 {
 887   if (t == NULL)
 888     return;
 889   free_true_name (t->left);
 890   free_true_name (t->right);
 891
 892   gfc_free (t);
 893 }
 894
 895
 896 /*****************************************************************/
 897
 898 /* Module reading and writing.  */
 899
 900 typedef enum
 901 {
 902   ATOM_NAME, ATOM_LPAREN, ATOM_RPAREN, ATOM_INTEGER, ATOM_STRING
 903 }
 904 atom_type;
 905
 906 static atom_type last_atom;
 907
 908
 909 /* The name buffer must be at least as long as a symbol name.  Right
 910    now it's not clear how we're going to store numeric constants--
 911    probably as a hexadecimal string, since this will allow the exact
 912    number to be preserved (this can't be done by a decimal
 913    representation).  Worry about that later.  TODO!  */
 914
 915 #define MAX_ATOM_SIZE 100
 916
 917 static int atom_int;
 918 static char *atom_string, atom_name[MAX_ATOM_SIZE];
 919
 920
 921 /* Report problems with a module.  Error reporting is not very
 922    elaborate, since this sorts of errors shouldn't really happen.
 923    This subroutine never returns.  */
 924
 925 static void bad_module (const char *) ATTRIBUTE_NORETURN;
 926
 927 static void
 928 bad_module (const char *msgid)
 929 {
 930   fclose (module_fp);
 931
 932   switch (iomode)
 933     {
 934     case IO_INPUT:
 935       gfc_fatal_error ("Reading module %s at line %d column %d: %s",
 936                        module_name, module_line, module_column, msgid);
 937       break;
 938     case IO_OUTPUT:
 939       gfc_fatal_error ("Writing module %s at line %d column %d: %s",
 940                        module_name, module_line, module_column, msgid);
 941       break;
 942     default:
 943       gfc_fatal_error ("Module %s at line %d column %d: %s",
 944                        module_name, module_line, module_column, msgid);
 945       break;
 946     }
 947 }
 948
 949
 950 /* Set the module's input pointer.  */
 951
 952 static void
 953 set_module_locus (module_locus *m)
 954 {
 955   module_column = m->column;
 956   module_line = m->line;
 957   fsetpos (module_fp, &m->pos);
 958 }
 959
 960
 961 /* Get the module's input pointer so that we can restore it later.  */
 962
 963 static void
 964 get_module_locus (module_locus *m)
 965 {
 966   m->column = module_column;
 967   m->line = module_line;
 968   fgetpos (module_fp, &m->pos);
 969 }
 970
 971
 972 /* Get the next character in the module, updating our reckoning of
 973    where we are.  */
 974
 975 static int
 976 module_char (void)
 977 {
 978   int c;
 979
 980   c = getc (module_fp);
 981
 982   if (c == EOF)
 983     bad_module ("Unexpected EOF");
 984
 985   if (c == '\n')
 986     {
 987       module_line++;
 988       module_column = 0;
 989     }
 990
 991   module_column++;
 992   return c;
 993 }
 994
 995
 996 /* Parse a string constant.  The delimiter is guaranteed to be a
 997    single quote.  */
 998
 999 static void
1000 parse_string (void)
1001 {
1002   module_locus start;
1003   int len, c;
1004   char *p;
1005
1006   get_module_locus (&start);
1007
1008   len = 0;
1009
1010   /* See how long the string is.  */
1011   for ( ; ; )
1012     {
1013       c = module_char ();
1014       if (c == EOF)
1015         bad_module ("Unexpected end of module in string constant");
1016
1017       if (c != '\'')
1018         {
1019           len++;
1020           continue;
1021         }
1022
1023       c = module_char ();
1024       if (c == '\'')
1025         {
1026           len++;
1027           continue;
1028         }
1029
1030       break;
1031     }
1032
1033   set_module_locus (&start);
1034
1035   atom_string = p = XCNEWVEC (char, len + 1);
1036
1037   for (; len > 0; len--)
1038     {
1039       c = module_char ();
1040       if (c == '\'')
1041         module_char ();         /* Guaranteed to be another \'.  */
1042       *p++ = c;
1043     }
1044
1045   module_char ();               /* Terminating \'.  */
1046   *p = '\0';                    /* C-style string for debug purposes.  */
1047 }
1048
1049
1050 /* Parse a small integer.  */
1051
1052 static void
1053 parse_integer (int c)
1054 {
1055   module_locus m;
1056
1057   atom_int = c - '0';
1058
1059   for (;;)
1060     {
1061       get_module_locus (&m);
1062
1063       c = module_char ();
1064       if (!ISDIGIT (c))
1065         break;
1066
1067       atom_int = 10 * atom_int + c - '0';
1068       if (atom_int > 99999999)
1069         bad_module ("Integer overflow");
1070     }
1071
1072   set_module_locus (&m);
1073 }
1074
1075
1076 /* Parse a name.  */
1077
1078 static void
1079 parse_name (int c)
1080 {
1081   module_locus m;
1082   char *p;
1083   int len;
1084
1085   p = atom_name;
1086
1087   *p++ = c;
1088   len = 1;
1089
1090   get_module_locus (&m);
1091
1092   for (;;)
1093     {
1094       c = module_char ();
1095       if (!ISALNUM (c) && c != '_' && c != '-')
1096         break;
1097
1098       *p++ = c;
1099       if (++len > GFC_MAX_SYMBOL_LEN)
1100         bad_module ("Name too long");
1101     }
1102
1103   *p = '\0';
1104
1105   fseek (module_fp, -1, SEEK_CUR);
1106   module_column = m.column + len - 1;
1107
1108   if (c == '\n')
1109     module_line--;
1110 }
1111
1112
1113 /* Read the next atom in the module's input stream.  */
1114
1115 static atom_type
1116 parse_atom (void)
1117 {
1118   int c;
1119
1120   do
1121     {
1122       c = module_char ();
1123     }
1124   while (c == ' ' || c == '\r' || c == '\n');
1125
1126   switch (c)
1127     {
1128     case '(':
1129       return ATOM_LPAREN;
1130
1131     case ')':
1132       return ATOM_RPAREN;
1133
1134     case '\'':
1135       parse_string ();
1136       return ATOM_STRING;
1137
1138     case '0':
1139     case '1':
1140     case '2':
1141     case '3':
1142     case '4':
1143     case '5':
1144     case '6':
1145     case '7':
1146     case '8':
1147     case '9':
1148       parse_integer (c);
1149       return ATOM_INTEGER;
1150
1151     case 'a':
1152     case 'b':
1153     case 'c':
1154     case 'd':
1155     case 'e':
1156     case 'f':
1157     case 'g':
1158     case 'h':
1159     case 'i':
1160     case 'j':
1161     case 'k':
1162     case 'l':
1163     case 'm':
1164     case 'n':
1165     case 'o':
1166     case 'p':
1167     case 'q':
1168     case 'r':
1169     case 's':
1170     case 't':
1171     case 'u':
1172     case 'v':
1173     case 'w':
1174     case 'x':
1175     case 'y':
1176     case 'z':
1177     case 'A':
1178     case 'B':
1179     case 'C':
1180     case 'D':
1181     case 'E':
1182     case 'F':
1183     case 'G':
1184     case 'H':
1185     case 'I':
1186     case 'J':
1187     case 'K':
1188     case 'L':
1189     case 'M':
1190     case 'N':
1191     case 'O':
1192     case 'P':
1193     case 'Q':
1194     case 'R':
1195     case 'S':
1196     case 'T':
1197     case 'U':
1198     case 'V':
1199     case 'W':
1200     case 'X':
1201     case 'Y':
1202     case 'Z':
1203       parse_name (c);
1204       return ATOM_NAME;
1205
1206     default:
1207       bad_module ("Bad name");
1208     }
1209
1210   /* Not reached.  */
1211 }
1212
1213
1214 /* Peek at the next atom on the input.  */
1215
1216 static atom_type
1217 peek_atom (void)
1218 {
1219   module_locus m;
1220   atom_type a;
1221
1222   get_module_locus (&m);
1223
1224   a = parse_atom ();
1225   if (a == ATOM_STRING)
1226     gfc_free (atom_string);
1227
1228   set_module_locus (&m);
1229   return a;
1230 }
1231
1232
1233 /* Read the next atom from the input, requiring that it be a
1234    particular kind.  */
1235
1236 static void
1237 require_atom (atom_type type)
1238 {
1239   module_locus m;
1240   atom_type t;
1241   const char *p;
1242
1243   get_module_locus (&m);
1244
1245   t = parse_atom ();
1246   if (t != type)
1247     {
1248       switch (type)
1249         {
1250         case ATOM_NAME:
1251           p = _("Expected name");
1252           break;
1253         case ATOM_LPAREN:
1254           p = _("Expected left parenthesis");
1255           break;
1256         case ATOM_RPAREN:
1257           p = _("Expected right parenthesis");
1258           break;
1259         case ATOM_INTEGER:
1260           p = _("Expected integer");
1261           break;
1262         case ATOM_STRING:
1263           p = _("Expected string");
1264           break;
1265         default:
1266           gfc_internal_error ("require_atom(): bad atom type required");
1267         }
1268
1269       set_module_locus (&m);
1270       bad_module (p);
1271     }
1272 }
1273
1274
1275 /* Given a pointer to an mstring array, require that the current input
1276    be one of the strings in the array.  We return the enum value.  */
1277
1278 static int
1279 find_enum (const mstring *m)
1280 {
1281   int i;
1282
1283   i = gfc_string2code (m, atom_name);
1284   if (i >= 0)
1285     return i;
1286
1287   bad_module ("find_enum(): Enum not found");
1288
1289   /* Not reached.  */
1290 }
1291
1292
1293 /**************** Module output subroutines ***************************/
1294
1295 /* Output a character to a module file.  */
1296
1297 static void
1298 write_char (char out)
1299 {
1300   if (putc (out, module_fp) == EOF)
1301     gfc_fatal_error ("Error writing modules file: %s", strerror (errno));
1302
1303   /* Add this to our MD5.  */
1304   md5_process_bytes (&out, sizeof (out), &ctx);
1305
1306   if (out != '\n')
1307     module_column++;
1308   else
1309     {
1310       module_column = 1;
1311       module_line++;
1312     }
1313 }
1314
1315
1316 /* Write an atom to a module.  The line wrapping isn't perfect, but it
1317    should work most of the time.  This isn't that big of a deal, since
1318    the file really isn't meant to be read by people anyway.  */
1319
1320 static void
1321 write_atom (atom_type atom, const void *v)
1322 {
1323   char buffer[20];
1324   int i, len;
1325   const char *p;
1326
1327   switch (atom)
1328     {
1329     case ATOM_STRING:
1330     case ATOM_NAME:
1331       p = (const char *) v;
1332       break;
1333
1334     case ATOM_LPAREN:
1335       p = "(";
1336       break;
1337
1338     case ATOM_RPAREN:
1339       p = ")";
1340       break;
1341
1342     case ATOM_INTEGER:
1343       i = *((const int *) v);
1344       if (i < 0)
1345         gfc_internal_error ("write_atom(): Writing negative integer");
1346
1347       sprintf (buffer, "%d", i);
1348       p = buffer;
1349       break;
1350
1351     default:
1352       gfc_internal_error ("write_atom(): Trying to write dab atom");
1353
1354     }
1355
1356   if(p == NULL || *p == '\0')
1357      len = 0;
1358   else
1359   len = strlen (p);
1360
1361   if (atom != ATOM_RPAREN)
1362     {
1363       if (module_column + len > 72)
1364         write_char ('\n');
1365       else
1366         {
1367
1368           if (last_atom != ATOM_LPAREN && module_column != 1)
1369             write_char (' ');
1370         }
1371     }
1372
1373   if (atom == ATOM_STRING)
1374     write_char ('\'');
1375
1376   while (p != NULL && *p)
1377     {
1378       if (atom == ATOM_STRING && *p == '\'')
1379         write_char ('\'');
1380       write_char (*p++);
1381     }
1382
1383   if (atom == ATOM_STRING)
1384     write_char ('\'');
1385
1386   last_atom = atom;
1387 }
1388
1389
1390
1391 /***************** Mid-level I/O subroutines *****************/
1392
1393 /* These subroutines let their caller read or write atoms without
1394    caring about which of the two is actually happening.  This lets a
1395    subroutine concentrate on the actual format of the data being
1396    written.  */
1397
1398 static void mio_expr (gfc_expr **);
1399 pointer_info *mio_symbol_ref (gfc_symbol **);
1400 pointer_info *mio_interface_rest (gfc_interface **);
1401 static void mio_symtree_ref (gfc_symtree **);
1402
1403 /* Read or write an enumerated value.  On writing, we return the input
1404    value for the convenience of callers.  We avoid using an integer
1405    pointer because enums are sometimes inside bitfields.  */
1406
1407 static int
1408 mio_name (int t, const mstring *m)
1409 {
1410   if (iomode == IO_OUTPUT)
1411     write_atom (ATOM_NAME, gfc_code2string (m, t));
1412   else
1413     {
1414       require_atom (ATOM_NAME);
1415       t = find_enum (m);
1416     }
1417
1418   return t;
1419 }
1420
1421 /* Specialization of mio_name.  */
1422
1423 #define DECL_MIO_NAME(TYPE) \
1424  static inline TYPE \
1425  MIO_NAME(TYPE) (TYPE t, const mstring *m) \
1426  { \
1427    return (TYPE) mio_name ((int) t, m); \
1428  }
1429 #define MIO_NAME(TYPE) mio_name_##TYPE
1430
1431 static void
1432 mio_lparen (void)
1433 {
1434   if (iomode == IO_OUTPUT)
1435     write_atom (ATOM_LPAREN, NULL);
1436   else
1437     require_atom (ATOM_LPAREN);
1438 }
1439
1440
1441 static void
1442 mio_rparen (void)
1443 {
1444   if (iomode == IO_OUTPUT)
1445     write_atom (ATOM_RPAREN, NULL);
1446   else
1447     require_atom (ATOM_RPAREN);
1448 }
1449
1450
1451 static void
1452 mio_integer (int *ip)
1453 {
1454   if (iomode == IO_OUTPUT)
1455     write_atom (ATOM_INTEGER, ip);
1456   else
1457     {
1458       require_atom (ATOM_INTEGER);
1459       *ip = atom_int;
1460     }
1461 }
1462
1463
1464 /* Read or write a character pointer that points to a string on the heap.  */
1465
1466 static const char *
1467 mio_allocated_string (const char *s)
1468 {
1469   if (iomode == IO_OUTPUT)
1470     {
1471       write_atom (ATOM_STRING, s);
1472       return s;
1473     }
1474   else
1475     {
1476       require_atom (ATOM_STRING);
1477       return atom_string;
1478     }
1479 }
1480
1481
1482 /* Functions for quoting and unquoting strings.  */
1483
1484 static char *
1485 quote_string (const gfc_char_t *s, const size_t slength)
1486 {
1487   const gfc_char_t *p;
1488   char *res, *q;
1489   size_t len = 0, i;
1490
1491   /* Calculate the length we'll need: a backslash takes two ("\\"),
1492      non-printable characters take 10 ("\Uxxxxxxxx") and others take 1.  */
1493   for (p = s, i = 0; i < slength; p++, i++)
1494     {
1495       if (*p == '\\')
1496         len += 2;
1497       else if (!gfc_wide_is_printable (*p))
1498         len += 10;
1499       else
1500         len++;
1501     }
1502
1503   q = res = XCNEWVEC (char, len + 1);
1504   for (p = s, i = 0; i < slength; p++, i++)
1505     {
1506       if (*p == '\\')
1507         *q++ = '\\', *q++ = '\\';
1508       else if (!gfc_wide_is_printable (*p))
1509         {
1510           sprintf (q, "\\U%08" HOST_WIDE_INT_PRINT "x",
1511                    (unsigned HOST_WIDE_INT) *p);
1512           q += 10;
1513         }
1514       else
1515         *q++ = (unsigned char) *p;
1516     }
1517
1518   res[len] = '\0';
1519   return res;
1520 }
1521
1522 static gfc_char_t *
1523 unquote_string (const char *s)
1524 {
1525   size_t len, i;
1526   const char *p;
1527   gfc_char_t *res;
1528
1529   for (p = s, len = 0; *p; p++, len++)
1530     {
1531       if (*p != '\\')
1532         continue;
1533
1534       if (p[1] == '\\')
1535         p++;
1536       else if (p[1] == 'U')
1537         p += 9; /* That is a "\U????????". */
1538       else
1539         gfc_internal_error ("unquote_string(): got bad string");
1540     }
1541
1542   res = gfc_get_wide_string (len + 1);
1543   for (i = 0, p = s; i < len; i++, p++)
1544     {
1545       gcc_assert (*p);
1546
1547       if (*p != '\\')
1548         res[i] = (unsigned char) *p;
1549       else if (p[1] == '\\')
1550         {
1551           res[i] = (unsigned char) '\\';
1552           p++;
1553         }
1554       else
1555         {
1556           /* We read the 8-digits hexadecimal constant that follows.  */
1557           int j;
1558           unsigned n;
1559           gfc_char_t c = 0;
1560
1561           gcc_assert (p[1] == 'U');
1562           for (j = 0; j < 8; j++)
1563             {
1564               c = c << 4;
1565               gcc_assert (sscanf (&p[j+2], "%01x", &n) == 1);
1566               c += n;
1567             }
1568
1569           res[i] = c;
1570           p += 9;
1571         }
1572     }
1573
1574   res[len] = '\0';
1575   return res;
1576 }
1577
1578
1579 /* Read or write a character pointer that points to a wide string on the
1580    heap, performing quoting/unquoting of nonprintable characters using the
1581    form \U???????? (where each ? is a hexadecimal digit).
1582    Length is the length of the string, only known and used in output mode.  */
1583
1584 static const gfc_char_t *
1585 mio_allocated_wide_string (const gfc_char_t *s, const size_t length)
1586 {
1587   if (iomode == IO_OUTPUT)
1588     {
1589       char *quoted = quote_string (s, length);
1590       write_atom (ATOM_STRING, quoted);
1591       gfc_free (quoted);
1592       return s;
1593     }
1594   else
1595     {
1596       gfc_char_t *unquoted;
1597
1598       require_atom (ATOM_STRING);
1599       unquoted = unquote_string (atom_string);
1600       gfc_free (atom_string);
1601       return unquoted;
1602     }
1603 }
1604
1605
1606 /* Read or write a string that is in static memory.  */
1607
1608 static void
1609 mio_pool_string (const char **stringp)
1610 {
1611   /* TODO: one could write the string only once, and refer to it via a
1612      fixup pointer.  */
1613
1614   /* As a special case we have to deal with a NULL string.  This
1615      happens for the 'module' member of 'gfc_symbol's that are not in a
1616      module.  We read / write these as the empty string.  */
1617   if (iomode == IO_OUTPUT)
1618     {
1619       const char *p = *stringp == NULL ? "" : *stringp;
1620       write_atom (ATOM_STRING, p);
1621     }
1622   else
1623     {
1624       require_atom (ATOM_STRING);
1625       *stringp = atom_string[0] == '\0' ? NULL : gfc_get_string (atom_string);
1626       gfc_free (atom_string);
1627     }
1628 }
1629
1630
1631 /* Read or write a string that is inside of some already-allocated
1632    structure.  */
1633
1634 static void
1635 mio_internal_string (char *string)
1636 {
1637   if (iomode == IO_OUTPUT)
1638     write_atom (ATOM_STRING, string);
1639   else
1640     {
1641       require_atom (ATOM_STRING);
1642       strcpy (string, atom_string);
1643       gfc_free (atom_string);
1644     }
1645 }
1646
1647
1648 typedef enum
1649 { AB_ALLOCATABLE, AB_DIMENSION, AB_EXTERNAL, AB_INTRINSIC, AB_OPTIONAL,
1650   AB_POINTER, AB_TARGET, AB_DUMMY, AB_RESULT, AB_DATA,
1651   AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE,
1652   AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
1653   AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
1654   AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
1655   AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
1656   AB_EXTENSION, AB_PROCEDURE, AB_PROC_POINTER
1657 }
1658 ab_attribute;
1659
1660 static const mstring attr_bits[] =
1661 {
1662     minit ("ALLOCATABLE", AB_ALLOCATABLE),
1663     minit ("DIMENSION", AB_DIMENSION),
1664     minit ("EXTERNAL", AB_EXTERNAL),
1665     minit ("INTRINSIC", AB_INTRINSIC),
1666     minit ("OPTIONAL", AB_OPTIONAL),
1667     minit ("POINTER", AB_POINTER),
1668     minit ("VOLATILE", AB_VOLATILE),
1669     minit ("TARGET", AB_TARGET),
1670     minit ("THREADPRIVATE", AB_THREADPRIVATE),
1671     minit ("DUMMY", AB_DUMMY),
1672     minit ("RESULT", AB_RESULT),
1673     minit ("DATA", AB_DATA),
1674     minit ("IN_NAMELIST", AB_IN_NAMELIST),
1675     minit ("IN_COMMON", AB_IN_COMMON),
1676     minit ("FUNCTION", AB_FUNCTION),
1677     minit ("SUBROUTINE", AB_SUBROUTINE),
1678     minit ("SEQUENCE", AB_SEQUENCE),
1679     minit ("ELEMENTAL", AB_ELEMENTAL),
1680     minit ("PURE", AB_PURE),
1681     minit ("RECURSIVE", AB_RECURSIVE),
1682     minit ("GENERIC", AB_GENERIC),
1683     minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
1684     minit ("CRAY_POINTER", AB_CRAY_POINTER),
1685     minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
1686     minit ("IS_BIND_C", AB_IS_BIND_C),
1687     minit ("IS_C_INTEROP", AB_IS_C_INTEROP),
1688     minit ("IS_ISO_C", AB_IS_ISO_C),
1689     minit ("VALUE", AB_VALUE),
1690     minit ("ALLOC_COMP", AB_ALLOC_COMP),
1691     minit ("POINTER_COMP", AB_POINTER_COMP),
1692     minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
1693     minit ("ZERO_COMP", AB_ZERO_COMP),
1694     minit ("PROTECTED", AB_PROTECTED),
1695     minit ("ABSTRACT", AB_ABSTRACT),
1696     minit ("EXTENSION", AB_EXTENSION),
1697     minit ("PROCEDURE", AB_PROCEDURE),
1698     minit ("PROC_POINTER", AB_PROC_POINTER),
1699     minit (NULL, -1)
1700 };
1701
1702 /* For binding attributes.  */
1703 static const mstring binding_passing[] =
1704 {
1705     minit ("PASS", 0),
1706     minit ("NOPASS", 1),
1707     minit (NULL, -1)
1708 };
1709 static const mstring binding_overriding[] =
1710 {
1711     minit ("OVERRIDABLE", 0),
1712     minit ("NON_OVERRIDABLE", 1),
1713     minit ("DEFERRED", 2),
1714     minit (NULL, -1)
1715 };
1716 static const mstring binding_generic[] =
1717 {
1718     minit ("SPECIFIC", 0),
1719     minit ("GENERIC", 1),
1720     minit (NULL, -1)
1721 };
1722 static const mstring binding_ppc[] =
1723 {
1724     minit ("NO_PPC", 0),
1725     minit ("PPC", 1),
1726     minit (NULL, -1)
1727 };
1728
1729 /* Specialization of mio_name.  */
1730 DECL_MIO_NAME (ab_attribute)
1731 DECL_MIO_NAME (ar_type)
1732 DECL_MIO_NAME (array_type)
1733 DECL_MIO_NAME (bt)
1734 DECL_MIO_NAME (expr_t)
1735 DECL_MIO_NAME (gfc_access)
1736 DECL_MIO_NAME (gfc_intrinsic_op)
1737 DECL_MIO_NAME (ifsrc)
1738 DECL_MIO_NAME (save_state)
1739 DECL_MIO_NAME (procedure_type)
1740 DECL_MIO_NAME (ref_type)
1741 DECL_MIO_NAME (sym_flavor)
1742 DECL_MIO_NAME (sym_intent)
1743 #undef DECL_MIO_NAME
1744
1745 /* Symbol attributes are stored in list with the first three elements
1746    being the enumerated fields, while the remaining elements (if any)
1747    indicate the individual attribute bits.  The access field is not
1748    saved-- it controls what symbols are exported when a module is
1749    written.  */
1750
1751 static void
1752 mio_symbol_attribute (symbol_attribute *attr)
1753 {
1754   atom_type t;
1755   unsigned ext_attr;
1756
1757   mio_lparen ();
1758
1759   attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors);
1760   attr->intent = MIO_NAME (sym_intent) (attr->intent, intents);
1761   attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
1762   attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
1763   attr->save = MIO_NAME (save_state) (attr->save, save_status);
1764   ext_attr = attr->ext_attr;
1765   mio_integer ((int *) &ext_attr);
1766   attr->ext_attr = ext_attr;
1767
1768   if (iomode == IO_OUTPUT)
1769     {
1770       if (attr->allocatable)
1771         MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
1772       if (attr->dimension)
1773         MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
1774       if (attr->external)
1775         MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
1776       if (attr->intrinsic)
1777         MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits);
1778       if (attr->optional)
1779         MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits);
1780       if (attr->pointer)
1781         MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
1782       if (attr->is_protected)
1783         MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits);
1784       if (attr->value)
1785         MIO_NAME (ab_attribute) (AB_VALUE, attr_bits);
1786       if (attr->volatile_)
1787         MIO_NAME (ab_attribute) (AB_VOLATILE, attr_bits);
1788       if (attr->target)
1789         MIO_NAME (ab_attribute) (AB_TARGET, attr_bits);
1790       if (attr->threadprivate)
1791         MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits);
1792       if (attr->dummy)
1793         MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits);
1794       if (attr->result)
1795         MIO_NAME (ab_attribute) (AB_RESULT, attr_bits);
1796       /* We deliberately don't preserve the "entry" flag.  */
1797
1798       if (attr->data)
1799         MIO_NAME (ab_attribute) (AB_DATA, attr_bits);
1800       if (attr->in_namelist)
1801         MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits);
1802       if (attr->in_common)
1803         MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits);
1804
1805       if (attr->function)
1806         MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits);
1807       if (attr->subroutine)
1808         MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits);
1809       if (attr->generic)
1810         MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits);
1811       if (attr->abstract)
1812         MIO_NAME (ab_attribute) (AB_ABSTRACT, attr_bits);
1813
1814       if (attr->sequence)
1815         MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits);
1816       if (attr->elemental)
1817         MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
1818       if (attr->pure)
1819         MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
1820       if (attr->recursive)
1821         MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
1822       if (attr->always_explicit)
1823         MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
1824       if (attr->cray_pointer)
1825         MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits);
1826       if (attr->cray_pointee)
1827         MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits);
1828       if (attr->is_bind_c)
1829         MIO_NAME(ab_attribute) (AB_IS_BIND_C, attr_bits);
1830       if (attr->is_c_interop)
1831         MIO_NAME(ab_attribute) (AB_IS_C_INTEROP, attr_bits);
1832       if (attr->is_iso_c)
1833         MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits);
1834       if (attr->alloc_comp)
1835         MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
1836       if (attr->pointer_comp)
1837         MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits);
1838       if (attr->private_comp)
1839         MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
1840       if (attr->zero_comp)
1841         MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
1842       if (attr->extension)
1843         MIO_NAME (ab_attribute) (AB_EXTENSION, attr_bits);
1844       if (attr->procedure)
1845         MIO_NAME (ab_attribute) (AB_PROCEDURE, attr_bits);
1846       if (attr->proc_pointer)
1847         MIO_NAME (ab_attribute) (AB_PROC_POINTER, attr_bits);
1848
1849       mio_rparen ();
1850
1851     }
1852   else
1853     {
1854       for (;;)
1855         {
1856           t = parse_atom ();
1857           if (t == ATOM_RPAREN)
1858             break;
1859           if (t != ATOM_NAME)
1860             bad_module ("Expected attribute bit name");
1861
1862           switch ((ab_attribute) find_enum (attr_bits))
1863             {
1864             case AB_ALLOCATABLE:
1865               attr->allocatable = 1;
1866               break;
1867             case AB_DIMENSION:
1868               attr->dimension = 1;
1869               break;
1870             case AB_EXTERNAL:
1871               attr->external = 1;
1872               break;
1873             case AB_INTRINSIC:
1874               attr->intrinsic = 1;
1875               break;
1876             case AB_OPTIONAL:
1877               attr->optional = 1;
1878               break;
1879             case AB_POINTER:
1880               attr->pointer = 1;
1881               break;
1882             case AB_PROTECTED:
1883               attr->is_protected = 1;
1884               break;
1885             case AB_VALUE:
1886               attr->value = 1;
1887               break;
1888             case AB_VOLATILE:
1889               attr->volatile_ = 1;
1890               break;
1891             case AB_TARGET:
1892               attr->target = 1;
1893               break;
1894             case AB_THREADPRIVATE:
1895               attr->threadprivate = 1;
1896               break;
1897             case AB_DUMMY:
1898               attr->dummy = 1;
1899               break;
1900             case AB_RESULT:
1901               attr->result = 1;
1902               break;
1903             case AB_DATA:
1904               attr->data = 1;
1905               break;
1906             case AB_IN_NAMELIST:
1907               attr->in_namelist = 1;
1908               break;
1909             case AB_IN_COMMON:
1910               attr->in_common = 1;
1911               break;
1912             case AB_FUNCTION:
1913               attr->function = 1;
1914               break;
1915             case AB_SUBROUTINE:
1916               attr->subroutine = 1;
1917               break;
1918             case AB_GENERIC:
1919               attr->generic = 1;
1920               break;
1921             case AB_ABSTRACT:
1922               attr->abstract = 1;
1923               break;
1924             case AB_SEQUENCE:
1925               attr->sequence = 1;
1926               break;
1927             case AB_ELEMENTAL:
1928               attr->elemental = 1;
1929               break;
1930             case AB_PURE:
1931               attr->pure = 1;
1932               break;
1933             case AB_RECURSIVE:
1934               attr->recursive = 1;
1935               break;
1936             case AB_ALWAYS_EXPLICIT:
1937               attr->always_explicit = 1;
1938               break;
1939             case AB_CRAY_POINTER:
1940               attr->cray_pointer = 1;
1941               break;
1942             case AB_CRAY_POINTEE:
1943               attr->cray_pointee = 1;
1944               break;
1945             case AB_IS_BIND_C:
1946               attr->is_bind_c = 1;
1947               break;
1948             case AB_IS_C_INTEROP:
1949               attr->is_c_interop = 1;
1950               break;
1951             case AB_IS_ISO_C:
1952               attr->is_iso_c = 1;
1953               break;
1954             case AB_ALLOC_COMP:
1955               attr->alloc_comp = 1;
1956               break;
1957             case AB_POINTER_COMP:
1958               attr->pointer_comp = 1;
1959               break;
1960             case AB_PRIVATE_COMP:
1961               attr->private_comp = 1;
1962               break;
1963             case AB_ZERO_COMP:
1964               attr->zero_comp = 1;
1965               break;
1966             case AB_EXTENSION:
1967               attr->extension = 1;
1968               break;
1969             case AB_PROCEDURE:
1970               attr->procedure = 1;
1971               break;
1972             case AB_PROC_POINTER:
1973               attr->proc_pointer = 1;
1974               break;
1975             }
1976         }
1977     }
1978 }
1979
1980
1981 static const mstring bt_types[] = {
1982     minit ("INTEGER", BT_INTEGER),
1983     minit ("REAL", BT_REAL),
1984     minit ("COMPLEX", BT_COMPLEX),
1985     minit ("LOGICAL", BT_LOGICAL),
1986     minit ("CHARACTER", BT_CHARACTER),
1987     minit ("DERIVED", BT_DERIVED),
1988     minit ("PROCEDURE", BT_PROCEDURE),
1989     minit ("UNKNOWN", BT_UNKNOWN),
1990     minit ("VOID", BT_VOID),
1991     minit (NULL, -1)
1992 };
1993
1994
1995 static void
1996 mio_charlen (gfc_charlen **clp)
1997 {
1998   gfc_charlen *cl;
1999
2000   mio_lparen ();
2001
2002   if (iomode == IO_OUTPUT)
2003     {
2004       cl = *clp;
2005       if (cl != NULL)
2006         mio_expr (&cl->length);
2007     }
2008   else
2009     {
2010       if (peek_atom () != ATOM_RPAREN)
2011         {
2012           cl = gfc_new_charlen (gfc_current_ns);
2013           mio_expr (&cl->length);
2014           *clp = cl;
2015         }
2016     }
2017
2018   mio_rparen ();
2019 }
2020
2021
2022 /* See if a name is a generated name.  */
2023
2024 static int
2025 check_unique_name (const char *name)
2026 {
2027   return *name == '@';
2028 }
2029
2030
2031 static void
2032 mio_typespec (gfc_typespec *ts)
2033 {
2034   mio_lparen ();
2035
2036   ts->type = MIO_NAME (bt) (ts->type, bt_types);
2037
2038   if (ts->type != BT_DERIVED)
2039     mio_integer (&ts->kind);
2040   else
2041     mio_symbol_ref (&ts->u.derived);
2042
2043   /* Add info for C interop and is_iso_c.  */
2044   mio_integer (&ts->is_c_interop);
2045   mio_integer (&ts->is_iso_c);
2046
2047   /* If the typespec is for an identifier either from iso_c_binding, or
2048      a constant that was initialized to an identifier from it, use the
2049      f90_type.  Otherwise, use the ts->type, since it shouldn't matter.  */
2050   if (ts->is_iso_c)
2051     ts->f90_type = MIO_NAME (bt) (ts->f90_type, bt_types);
2052   else
2053     ts->f90_type = MIO_NAME (bt) (ts->type, bt_types);
2054
2055   if (ts->type != BT_CHARACTER)
2056     {
2057       /* ts->u.cl is only valid for BT_CHARACTER.  */
2058       mio_lparen ();
2059       mio_rparen ();
2060     }
2061   else
2062     mio_charlen (&ts->u.cl);
2063
2064   mio_rparen ();
2065 }
2066
2067
2068 static const mstring array_spec_types[] = {
2069     minit ("EXPLICIT", AS_EXPLICIT),
2070     minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
2071     minit ("DEFERRED", AS_DEFERRED),
2072     minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
2073     minit (NULL, -1)
2074 };
2075
2076
2077 static void
2078 mio_array_spec (gfc_array_spec **asp)
2079 {
2080   gfc_array_spec *as;
2081   int i;
2082
2083   mio_lparen ();
2084
2085   if (iomode == IO_OUTPUT)
2086     {
2087       if (*asp == NULL)
2088         goto done;
2089       as = *asp;
2090     }
2091   else
2092     {
2093       if (peek_atom () == ATOM_RPAREN)
2094         {
2095           *asp = NULL;
2096           goto done;
2097         }
2098
2099       *asp = as = gfc_get_array_spec ();
2100     }
2101
2102   mio_integer (&as->rank);
2103   as->type = MIO_NAME (array_type) (as->type, array_spec_types);
2104
2105   for (i = 0; i < as->rank; i++)
2106     {
2107       mio_expr (&as->lower[i]);
2108       mio_expr (&as->upper[i]);
2109     }
2110
2111 done:
2112   mio_rparen ();
2113 }
2114
2115
2116 /* Given a pointer to an array reference structure (which lives in a
2117    gfc_ref structure), find the corresponding array specification
2118    structure.  Storing the pointer in the ref structure doesn't quite
2119    work when loading from a module. Generating code for an array
2120    reference also needs more information than just the array spec.  */
2121
2122 static const mstring array_ref_types[] = {
2123     minit ("FULL", AR_FULL),
2124     minit ("ELEMENT", AR_ELEMENT),
2125     minit ("SECTION", AR_SECTION),
2126     minit (NULL, -1)
2127 };
2128
2129
2130 static void
2131 mio_array_ref (gfc_array_ref *ar)
2132 {
2133   int i;
2134
2135   mio_lparen ();
2136   ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types);
2137   mio_integer (&ar->dimen);
2138
2139   switch (ar->type)
2140     {
2141     case AR_FULL:
2142       break;
2143
2144     case AR_ELEMENT:
2145       for (i = 0; i < ar->dimen; i++)
2146         mio_expr (&ar->start[i]);
2147
2148       break;
2149
2150     case AR_SECTION:
2151       for (i = 0; i < ar->dimen; i++)
2152         {
2153           mio_expr (&ar->start[i]);
2154           mio_expr (&ar->end[i]);
2155           mio_expr (&ar->stride[i]);
2156         }
2157
2158       break;
2159
2160     case AR_UNKNOWN:
2161       gfc_internal_error ("mio_array_ref(): Unknown array ref");
2162     }
2163
2164   /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
2165      we can't call mio_integer directly.  Instead loop over each element
2166      and cast it to/from an integer.  */
2167   if (iomode == IO_OUTPUT)
2168     {
2169       for (i = 0; i < ar->dimen; i++)
2170         {
2171           int tmp = (int)ar->dimen_type[i];
2172           write_atom (ATOM_INTEGER, &tmp);
2173         }
2174     }
2175   else
2176     {
2177       for (i = 0; i < ar->dimen; i++)
2178         {
2179           require_atom (ATOM_INTEGER);
2180           ar->dimen_type[i] = (enum gfc_array_ref_dimen_type) atom_int;
2181         }
2182     }
2183
2184   if (iomode == IO_INPUT)
2185     {
2186       ar->where = gfc_current_locus;
2187
2188       for (i = 0; i < ar->dimen; i++)
2189         ar->c_where[i] = gfc_current_locus;
2190     }
2191
2192   mio_rparen ();
2193 }
2194
2195
2196 /* Saves or restores a pointer.  The pointer is converted back and
2197    forth from an integer.  We return the pointer_info pointer so that
2198    the caller can take additional action based on the pointer type.  */
2199
2200 static pointer_info *
2201 mio_pointer_ref (void *gp)
2202 {
2203   pointer_info *p;
2204
2205   if (iomode == IO_OUTPUT)
2206     {
2207       p = get_pointer (*((char **) gp));
2208       write_atom (ATOM_INTEGER, &p->integer);
2209     }
2210   else
2211     {
2212       require_atom (ATOM_INTEGER);
2213       p = add_fixup (atom_int, gp);
2214     }
2215
2216   return p;
2217 }
2218
2219
2220 /* Save and load references to components that occur within
2221    expressions.  We have to describe these references by a number and
2222    by name.  The number is necessary for forward references during
2223    reading, and the name is necessary if the symbol already exists in
2224    the namespace and is not loaded again.  */
2225
2226 static void
2227 mio_component_ref (gfc_component **cp, gfc_symbol *sym)
2228 {
2229   char name[GFC_MAX_SYMBOL_LEN + 1];
2230   gfc_component *q;
2231   pointer_info *p;
2232
2233   p = mio_pointer_ref (cp);
2234   if (p->type == P_UNKNOWN)
2235     p->type = P_COMPONENT;
2236
2237   if (iomode == IO_OUTPUT)
2238     mio_pool_string (&(*cp)->name);
2239   else
2240     {
2241       mio_internal_string (name);
2242
2243       /* It can happen that a component reference can be read before the
2244          associated derived type symbol has been loaded. Return now and
2245          wait for a later iteration of load_needed.  */
2246       if (sym == NULL)
2247         return;
2248
2249       if (sym->components != NULL && p->u.pointer == NULL)
2250         {
2251           /* Symbol already loaded, so search by name.  */
2252           for (q = sym->components; q; q = q->next)
2253             if (strcmp (q->name, name) == 0)
2254               break;
2255
2256           if (q == NULL)
2257             gfc_internal_error ("mio_component_ref(): Component not found");
2258
2259           associate_integer_pointer (p, q);
2260         }
2261
2262       /* Make sure this symbol will eventually be loaded.  */
2263       p = find_pointer2 (sym);
2264       if (p->u.rsym.state == UNUSED)
2265         p->u.rsym.state = NEEDED;
2266     }
2267 }
2268
2269
2270 static void mio_namespace_ref (gfc_namespace **nsp);
2271 static void mio_formal_arglist (gfc_formal_arglist **formal);
2272 static void mio_typebound_proc (gfc_typebound_proc** proc);
2273
2274 static void
2275 mio_component (gfc_component *c)
2276 {
2277   pointer_info *p;
2278   int n;
2279   gfc_formal_arglist *formal;
2280
2281   mio_lparen ();
2282
2283   if (iomode == IO_OUTPUT)
2284     {
2285       p = get_pointer (c);
2286       mio_integer (&p->integer);
2287     }
2288   else
2289     {
2290       mio_integer (&n);
2291       p = get_integer (n);
2292       associate_integer_pointer (p, c);
2293     }
2294
2295   if (p->type == P_UNKNOWN)
2296     p->type = P_COMPONENT;
2297
2298   mio_pool_string (&c->name);
2299   mio_typespec (&c->ts);
2300   mio_array_spec (&c->as);
2301
2302   mio_symbol_attribute (&c->attr);
2303   c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types);
2304
2305   mio_expr (&c->initializer);
2306
2307   if (c->attr.proc_pointer)
2308     {
2309       if (iomode == IO_OUTPUT)
2310         {
2311           formal = c->formal;
2312           while (formal && !formal->sym)
2313             formal = formal->next;
2314
2315           if (formal)
2316             mio_namespace_ref (&formal->sym->ns);
2317           else
2318             mio_namespace_ref (&c->formal_ns);
2319         }
2320       else
2321         {
2322           mio_namespace_ref (&c->formal_ns);
2323           /* TODO: if (c->formal_ns)
2324             {
2325               c->formal_ns->proc_name = c;
2326               c->refs++;
2327             }*/
2328         }
2329
2330       mio_formal_arglist (&c->formal);
2331
2332       mio_typebound_proc (&c->tb);
2333     }
2334
2335   mio_rparen ();
2336 }
2337
2338
2339 static void
2340 mio_component_list (gfc_component **cp)
2341 {
2342   gfc_component *c, *tail;
2343
2344   mio_lparen ();
2345
2346   if (iomode == IO_OUTPUT)
2347     {
2348       for (c = *cp; c; c = c->next)
2349         mio_component (c);
2350     }
2351   else
2352     {
2353       *cp = NULL;
2354       tail = NULL;
2355
2356       for (;;)
2357         {
2358           if (peek_atom () == ATOM_RPAREN)
2359             break;
2360
2361           c = gfc_get_component ();
2362           mio_component (c);
2363
2364           if (tail == NULL)
2365             *cp = c;
2366           else
2367             tail->next = c;
2368
2369           tail = c;
2370         }
2371     }
2372
2373   mio_rparen ();
2374 }
2375
2376
2377 static void
2378 mio_actual_arg (gfc_actual_arglist *a)
2379 {
2380   mio_lparen ();
2381   mio_pool_string (&a->name);
2382   mio_expr (&a->expr);
2383   mio_rparen ();
2384 }
2385
2386
2387 static void
2388 mio_actual_arglist (gfc_actual_arglist **ap)
2389 {
2390   gfc_actual_arglist *a, *tail;
2391
2392   mio_lparen ();
2393
2394   if (iomode == IO_OUTPUT)
2395     {
2396       for (a = *ap; a; a = a->next)
2397         mio_actual_arg (a);
2398
2399     }
2400   else
2401     {
2402       tail = NULL;
2403
2404       for (;;)
2405         {
2406           if (peek_atom () != ATOM_LPAREN)
2407             break;
2408
2409           a = gfc_get_actual_arglist ();
2410
2411           if (tail == NULL)
2412             *ap = a;
2413           else
2414             tail->next = a;
2415
2416           tail = a;
2417           mio_actual_arg (a);
2418         }
2419     }
2420
2421   mio_rparen ();
2422 }
2423
2424
2425 /* Read and write formal argument lists.  */
2426
2427 static void
2428 mio_formal_arglist (gfc_formal_arglist **formal)
2429 {
2430   gfc_formal_arglist *f, *tail;
2431
2432   mio_lparen ();
2433
2434   if (iomode == IO_OUTPUT)
2435     {
2436       for (f = *formal; f; f = f->next)
2437         mio_symbol_ref (&f->sym);
2438     }
2439   else
2440     {
2441       *formal = tail = NULL;
2442
2443       while (peek_atom () != ATOM_RPAREN)
2444         {
2445           f = gfc_get_formal_arglist ();
2446           mio_symbol_ref (&f->sym);
2447
2448           if (*formal == NULL)
2449             *formal = f;
2450           else
2451             tail->next = f;
2452
2453           tail = f;
2454         }
2455     }
2456
2457   mio_rparen ();
2458 }
2459
2460
2461 /* Save or restore a reference to a symbol node.  */
2462
2463 pointer_info *
2464 mio_symbol_ref (gfc_symbol **symp)
2465 {
2466   pointer_info *p;
2467
2468   p = mio_pointer_ref (symp);
2469   if (p->type == P_UNKNOWN)
2470     p->type = P_SYMBOL;
2471
2472   if (iomode == IO_OUTPUT)
2473     {
2474       if (p->u.wsym.state == UNREFERENCED)
2475         p->u.wsym.state = NEEDS_WRITE;
2476     }
2477   else
2478     {
2479       if (p->u.rsym.state == UNUSED)
2480         p->u.rsym.state = NEEDED;
2481     }
2482   return p;
2483 }
2484
2485
2486 /* Save or restore a reference to a symtree node.  */
2487
2488 static void
2489 mio_symtree_ref (gfc_symtree **stp)
2490 {
2491   pointer_info *p;
2492   fixup_t *f;
2493
2494   if (iomode == IO_OUTPUT)
2495     mio_symbol_ref (&(*stp)->n.sym);
2496   else
2497     {
2498       require_atom (ATOM_INTEGER);
2499       p = get_integer (atom_int);
2500
2501       /* An unused equivalence member; make a symbol and a symtree
2502          for it.  */
2503       if (in_load_equiv && p->u.rsym.symtree == NULL)
2504         {
2505           /* Since this is not used, it must have a unique name.  */
2506           p->u.rsym.symtree = gfc_get_unique_symtree (gfc_current_ns);
2507
2508           /* Make the symbol.  */
2509           if (p->u.rsym.sym == NULL)
2510             {
2511               p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name,
2512                                               gfc_current_ns);
2513               p->u.rsym.sym->module = gfc_get_string (p->u.rsym.module);
2514             }
2515
2516           p->u.rsym.symtree->n.sym = p->u.rsym.sym;
2517           p->u.rsym.symtree->n.sym->refs++;
2518           p->u.rsym.referenced = 1;
2519
2520           /* If the symbol is PRIVATE and in COMMON, load_commons will
2521              generate a fixup symbol, which must be associated.  */
2522           if (p->fixup)
2523             resolve_fixups (p->fixup, p->u.rsym.sym);
2524           p->fixup = NULL;
2525         }
2526
2527       if (p->type == P_UNKNOWN)
2528         p->type = P_SYMBOL;
2529
2530       if (p->u.rsym.state == UNUSED)
2531         p->u.rsym.state = NEEDED;
2532
2533       if (p->u.rsym.symtree != NULL)
2534         {
2535           *stp = p->u.rsym.symtree;
2536         }
2537       else
2538         {
2539           f = XCNEW (fixup_t);
2540
2541           f->next = p->u.rsym.stfixup;
2542           p->u.rsym.stfixup = f;
2543
2544           f->pointer = (void **) stp;
2545         }
2546     }
2547 }
2548
2549
2550 static void
2551 mio_iterator (gfc_iterator **ip)
2552 {
2553   gfc_iterator *iter;
2554
2555   mio_lparen ();
2556
2557   if (iomode == IO_OUTPUT)
2558     {
2559       if (*ip == NULL)
2560         goto done;
2561     }
2562   else
2563     {
2564       if (peek_atom () == ATOM_RPAREN)
2565         {
2566           *ip = NULL;
2567           goto done;
2568         }
2569
2570       *ip = gfc_get_iterator ();
2571     }
2572
2573   iter = *ip;
2574
2575   mio_expr (&iter->var);
2576   mio_expr (&iter->start);
2577   mio_expr (&iter->end);
2578   mio_expr (&iter->step);
2579
2580 done:
2581   mio_rparen ();
2582 }
2583
2584
2585 static void
2586 mio_constructor (gfc_constructor **cp)
2587 {
2588   gfc_constructor *c, *tail;
2589
2590   mio_lparen ();
2591
2592   if (iomode == IO_OUTPUT)
2593     {
2594       for (c = *cp; c; c = c->next)
2595         {
2596           mio_lparen ();
2597           mio_expr (&c->expr);
2598           mio_iterator (&c->iterator);
2599           mio_rparen ();
2600         }
2601     }
2602   else
2603     {
2604       *cp = NULL;
2605       tail = NULL;
2606
2607       while (peek_atom () != ATOM_RPAREN)
2608         {
2609           c = gfc_get_constructor ();
2610
2611           if (tail == NULL)
2612             *cp = c;
2613           else
2614             tail->next = c;
2615
2616           tail = c;
2617
2618           mio_lparen ();
2619           mio_expr (&c->expr);
2620           mio_iterator (&c->iterator);
2621           mio_rparen ();
2622         }
2623     }
2624
2625   mio_rparen ();
2626 }
2627
2628
2629 static const mstring ref_types[] = {
2630     minit ("ARRAY", REF_ARRAY),
2631     minit ("COMPONENT", REF_COMPONENT),
2632     minit ("SUBSTRING", REF_SUBSTRING),
2633     minit (NULL, -1)
2634 };
2635
2636
2637 static void
2638 mio_ref (gfc_ref **rp)
2639 {
2640   gfc_ref *r;
2641
2642   mio_lparen ();
2643
2644   r = *rp;
2645   r->type = MIO_NAME (ref_type) (r->type, ref_types);
2646
2647   switch (r->type)
2648     {
2649     case REF_ARRAY:
2650       mio_array_ref (&r->u.ar);
2651       break;
2652
2653     case REF_COMPONENT:
2654       mio_symbol_ref (&r->u.c.sym);
2655       mio_component_ref (&r->u.c.component, r->u.c.sym);
2656       break;
2657
2658     case REF_SUBSTRING:
2659       mio_expr (&r->u.ss.start);
2660       mio_expr (&r->u.ss.end);
2661       mio_charlen (&r->u.ss.length);
2662       break;
2663     }
2664
2665   mio_rparen ();
2666 }
2667
2668
2669 static void
2670 mio_ref_list (gfc_ref **rp)
2671 {
2672   gfc_ref *ref, *head, *tail;
2673
2674   mio_lparen ();
2675
2676   if (iomode == IO_OUTPUT)
2677     {
2678       for (ref = *rp; ref; ref = ref->next)
2679         mio_ref (&ref);
2680     }
2681   else
2682     {
2683       head = tail = NULL;
2684
2685       while (peek_atom () != ATOM_RPAREN)
2686         {
2687           if (head == NULL)
2688             head = tail = gfc_get_ref ();
2689           else
2690             {
2691               tail->next = gfc_get_ref ();
2692               tail = tail->next;
2693             }
2694
2695           mio_ref (&tail);
2696         }
2697
2698       *rp = head;
2699     }
2700
2701   mio_rparen ();
2702 }
2703
2704
2705 /* Read and write an integer value.  */
2706
2707 static void
2708 mio_gmp_integer (mpz_t *integer)
2709 {
2710   char *p;
2711
2712   if (iomode == IO_INPUT)
2713     {
2714       if (parse_atom () != ATOM_STRING)
2715         bad_module ("Expected integer string");
2716
2717       mpz_init (*integer);
2718       if (mpz_set_str (*integer, atom_string, 10))
2719         bad_module ("Error converting integer");
2720
2721       gfc_free (atom_string);
2722     }
2723   else
2724     {
2725       p = mpz_get_str (NULL, 10, *integer);
2726       write_atom (ATOM_STRING, p);
2727       gfc_free (p);
2728     }
2729 }
2730
2731
2732 static void
2733 mio_gmp_real (mpfr_t *real)
2734 {
2735   mp_exp_t exponent;
2736   char *p;
2737
2738   if (iomode == IO_INPUT)
2739     {
2740       if (parse_atom () != ATOM_STRING)
2741         bad_module ("Expected real string");
2742
2743       mpfr_init (*real);
2744       mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
2745       gfc_free (atom_string);
2746     }
2747   else
2748     {
2749       p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE);
2750
2751       if (mpfr_nan_p (*real) || mpfr_inf_p (*real))
2752         {
2753           write_atom (ATOM_STRING, p);
2754           gfc_free (p);
2755           return;
2756         }
2757
2758       atom_string = XCNEWVEC (char, strlen (p) + 20);
2759
2760       sprintf (atom_string, "0.%s@%ld", p, exponent);
2761
2762       /* Fix negative numbers.  */
2763       if (atom_string[2] == '-')
2764         {
2765           atom_string[0] = '-';
2766           atom_string[1] = '0';
2767           atom_string[2] = '.';
2768         }
2769
2770       write_atom (ATOM_STRING, atom_string);
2771
2772       gfc_free (atom_string);
2773       gfc_free (p);
2774     }
2775 }
2776
2777
2778 /* Save and restore the shape of an array constructor.  */
2779
2780 static void
2781 mio_shape (mpz_t **pshape, int rank)
2782 {
2783   mpz_t *shape;
2784   atom_type t;
2785   int n;
2786
2787   /* A NULL shape is represented by ().  */
2788   mio_lparen ();
2789
2790   if (iomode == IO_OUTPUT)
2791     {
2792       shape = *pshape;
2793       if (!shape)
2794         {
2795           mio_rparen ();
2796           return;
2797         }
2798     }
2799   else
2800     {
2801       t = peek_atom ();
2802       if (t == ATOM_RPAREN)
2803         {
2804           *pshape = NULL;
2805           mio_rparen ();
2806           return;
2807         }
2808
2809       shape = gfc_get_shape (rank);
2810       *pshape = shape;
2811     }
2812
2813   for (n = 0; n < rank; n++)
2814     mio_gmp_integer (&shape[n]);
2815
2816   mio_rparen ();
2817 }
2818
2819
2820 static const mstring expr_types[] = {
2821     minit ("OP", EXPR_OP),
2822     minit ("FUNCTION", EXPR_FUNCTION),
2823     minit ("CONSTANT", EXPR_CONSTANT),
2824     minit ("VARIABLE", EXPR_VARIABLE),
2825     minit ("SUBSTRING", EXPR_SUBSTRING),
2826     minit ("STRUCTURE", EXPR_STRUCTURE),
2827     minit ("ARRAY", EXPR_ARRAY),
2828     minit ("NULL", EXPR_NULL),
2829     minit ("COMPCALL", EXPR_COMPCALL),
2830     minit (NULL, -1)
2831 };
2832
2833 /* INTRINSIC_ASSIGN is missing because it is used as an index for
2834    generic operators, not in expressions.  INTRINSIC_USER is also
2835    replaced by the correct function name by the time we see it.  */
2836
2837 static const mstring intrinsics[] =
2838 {
2839     minit ("UPLUS", INTRINSIC_UPLUS),
2840     minit ("UMINUS", INTRINSIC_UMINUS),
2841     minit ("PLUS", INTRINSIC_PLUS),
2842     minit ("MINUS", INTRINSIC_MINUS),
2843     minit ("TIMES", INTRINSIC_TIMES),
2844     minit ("DIVIDE", INTRINSIC_DIVIDE),
2845     minit ("POWER", INTRINSIC_POWER),
2846     minit ("CONCAT", INTRINSIC_CONCAT),
2847     minit ("AND", INTRINSIC_AND),
2848     minit ("OR", INTRINSIC_OR),
2849     minit ("EQV", INTRINSIC_EQV),
2850     minit ("NEQV", INTRINSIC_NEQV),
2851     minit ("EQ_SIGN", INTRINSIC_EQ),
2852     minit ("EQ", INTRINSIC_EQ_OS),
2853     minit ("NE_SIGN", INTRINSIC_NE),
2854     minit ("NE", INTRINSIC_NE_OS),
2855     minit ("GT_SIGN", INTRINSIC_GT),
2856     minit ("GT", INTRINSIC_GT_OS),
2857     minit ("GE_SIGN", INTRINSIC_GE),
2858     minit ("GE", INTRINSIC_GE_OS),
2859     minit ("LT_SIGN", INTRINSIC_LT),
2860     minit ("LT", INTRINSIC_LT_OS),
2861     minit ("LE_SIGN", INTRINSIC_LE),
2862     minit ("LE", INTRINSIC_LE_OS),
2863     minit ("NOT", INTRINSIC_NOT),
2864     minit ("PARENTHESES", INTRINSIC_PARENTHESES),
2865     minit (NULL, -1)
2866 };
2867
2868
2869 /* Remedy a couple of situations where the gfc_expr's can be defective.  */
2870
2871 static void
2872 fix_mio_expr (gfc_expr *e)
2873 {
2874   gfc_symtree *ns_st = NULL;
2875   const char *fname;
2876
2877   if (iomode != IO_OUTPUT)
2878     return;
2879
2880   if (e->symtree)
2881     {
2882       /* If this is a symtree for a symbol that came from a contained module
2883          namespace, it has a unique name and we should look in the current
2884          namespace to see if the required, non-contained symbol is available
2885          yet. If so, the latter should be written.  */
2886       if (e->symtree->n.sym && check_unique_name (e->symtree->name))
2887         ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
2888                                   e->symtree->n.sym->name);
2889
2890       /* On the other hand, if the existing symbol is the module name or the
2891          new symbol is a dummy argument, do not do the promotion.  */
2892       if (ns_st && ns_st->n.sym
2893           && ns_st->n.sym->attr.flavor != FL_MODULE
2894           && !e->symtree->n.sym->attr.dummy)
2895         e->symtree = ns_st;
2896     }
2897   else if (e->expr_type == EXPR_FUNCTION && e->value.function.name)
2898     {
2899       /* In some circumstances, a function used in an initialization
2900          expression, in one use associated module, can fail to be
2901          coupled to its symtree when used in a specification
2902          expression in another module.  */
2903       fname = e->value.function.esym ? e->value.function.esym->name
2904                                      : e->value.function.isym->name;
2905       e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
2906     }
2907 }
2908
2909
2910 /* Read and write expressions.  The form "()" is allowed to indicate a
2911    NULL expression.  */
2912
2913 static void
2914 mio_expr (gfc_expr **ep)
2915 {
2916   gfc_expr *e;
2917   atom_type t;
2918   int flag;
2919
2920   mio_lparen ();
2921
2922   if (iomode == IO_OUTPUT)
2923     {
2924       if (*ep == NULL)
2925         {
2926           mio_rparen ();
2927           return;
2928         }
2929
2930       e = *ep;
2931       MIO_NAME (expr_t) (e->expr_type, expr_types);
2932     }
2933   else
2934     {
2935       t = parse_atom ();
2936       if (t == ATOM_RPAREN)
2937         {
2938           *ep = NULL;
2939           return;
2940         }
2941
2942       if (t != ATOM_NAME)
2943         bad_module ("Expected expression type");
2944
2945       e = *ep = gfc_get_expr ();
2946       e->where = gfc_current_locus;
2947       e->expr_type = (expr_t) find_enum (expr_types);
2948     }
2949
2950   mio_typespec (&e->ts);
2951   mio_integer (&e->rank);
2952
2953   fix_mio_expr (e);
2954
2955   switch (e->expr_type)
2956     {
2957     case EXPR_OP:
2958       e->value.op.op
2959         = MIO_NAME (gfc_intrinsic_op) (e->value.op.op, intrinsics);
2960
2961       switch (e->value.op.op)
2962         {
2963         case INTRINSIC_UPLUS:
2964         case INTRINSIC_UMINUS:
2965         case INTRINSIC_NOT:
2966         case INTRINSIC_PARENTHESES:
2967           mio_expr (&e->value.op.op1);
2968           break;
2969
2970         case INTRINSIC_PLUS:
2971         case INTRINSIC_MINUS:
2972         case INTRINSIC_TIMES:
2973         case INTRINSIC_DIVIDE:
2974         case INTRINSIC_POWER:
2975         case INTRINSIC_CONCAT:
2976         case INTRINSIC_AND:
2977         case INTRINSIC_OR:
2978         case INTRINSIC_EQV:
2979         case INTRINSIC_NEQV:
2980         case INTRINSIC_EQ:
2981         case INTRINSIC_EQ_OS:
2982         case INTRINSIC_NE:
2983         case INTRINSIC_NE_OS:
2984         case INTRINSIC_GT:
2985         case INTRINSIC_GT_OS:
2986         case INTRINSIC_GE:
2987         case INTRINSIC_GE_OS:
2988         case INTRINSIC_LT:
2989         case INTRINSIC_LT_OS:
2990         case INTRINSIC_LE:
2991         case INTRINSIC_LE_OS:
2992           mio_expr (&e->value.op.op1);
2993           mio_expr (&e->value.op.op2);
2994           break;
2995
2996         default:
2997           bad_module ("Bad operator");
2998         }
2999
3000       break;
3001
3002     case EXPR_FUNCTION:
3003       mio_symtree_ref (&e->symtree);
3004       mio_actual_arglist (&e->value.function.actual);
3005
3006       if (iomode == IO_OUTPUT)
3007         {
3008           e->value.function.name
3009             = mio_allocated_string (e->value.function.name);
3010           flag = e->value.function.esym != NULL;
3011           mio_integer (&flag);
3012           if (flag)
3013             mio_symbol_ref (&e->value.function.esym);
3014           else
3015             write_atom (ATOM_STRING, e->value.function.isym->name);
3016         }
3017       else
3018         {
3019           require_atom (ATOM_STRING);
3020           e->value.function.name = gfc_get_string (atom_string);
3021           gfc_free (atom_string);
3022
3023           mio_integer (&flag);
3024           if (flag)
3025             mio_symbol_ref (&e->value.function.esym);
3026           else
3027             {
3028               require_atom (ATOM_STRING);
3029               e->value.function.isym = gfc_find_function (atom_string);
3030               gfc_free (atom_string);
3031             }
3032         }
3033
3034       break;
3035
3036     case EXPR_VARIABLE:
3037       mio_symtree_ref (&e->symtree);
3038       mio_ref_list (&e->ref);
3039       break;
3040
3041     case EXPR_SUBSTRING:
3042       e->value.character.string
3043         = CONST_CAST (gfc_char_t *,
3044                       mio_allocated_wide_string (e->value.character.string,
3045                                                  e->value.character.length));
3046       mio_ref_list (&e->ref);
3047       break;
3048
3049     case EXPR_STRUCTURE:
3050     case EXPR_ARRAY:
3051       mio_constructor (&e->value.constructor);
3052       mio_shape (&e->shape, e->rank);
3053       break;
3054
3055     case EXPR_CONSTANT:
3056       switch (e->ts.type)
3057         {
3058         case BT_INTEGER:
3059           mio_gmp_integer (&e->value.integer);
3060           break;
3061
3062         case BT_REAL:
3063           gfc_set_model_kind (e->ts.kind);
3064           mio_gmp_real (&e->value.real);
3065           break;
3066
3067         case BT_COMPLEX:
3068           gfc_set_model_kind (e->ts.kind);
3069           mio_gmp_real (&mpc_realref (e->value.complex));
3070           mio_gmp_real (&mpc_imagref (e->value.complex));
3071           break;
3072
3073         case BT_LOGICAL:
3074           mio_integer (&e->value.logical);
3075           break;
3076
3077         case BT_CHARACTER:
3078           mio_integer (&e->value.character.length);
3079           e->value.character.string
3080             = CONST_CAST (gfc_char_t *,
3081                           mio_allocated_wide_string (e->value.character.string,
3082                                                      e->value.character.length));
3083           break;
3084
3085         default:
3086           bad_module ("Bad type in constant expression");
3087         }
3088
3089       break;
3090
3091     case EXPR_NULL:
3092       break;
3093
3094     case EXPR_COMPCALL:
3095     case EXPR_PPC:
3096       gcc_unreachable ();
3097       break;
3098     }
3099
3100   mio_rparen ();
3101 }
3102
3103
3104 /* Read and write namelists.  */
3105
3106 static void
3107 mio_namelist (gfc_symbol *sym)
3108 {
3109   gfc_namelist *n, *m;
3110   const char *check_name;
3111
3112   mio_lparen ();
3113
3114   if (iomode == IO_OUTPUT)
3115     {
3116       for (n = sym->namelist; n; n = n->next)
3117         mio_symbol_ref (&n->sym);
3118     }
3119   else
3120     {
3121       /* This departure from the standard is flagged as an error.
3122          It does, in fact, work correctly. TODO: Allow it
3123          conditionally?  */
3124       if (sym->attr.flavor == FL_NAMELIST)
3125         {
3126           check_name = find_use_name (sym->name, false);
3127           if (check_name && strcmp (check_name, sym->name) != 0)
3128             gfc_error ("Namelist %s cannot be renamed by USE "
3129                        "association to %s", sym->name, check_name);
3130         }
3131
3132       m = NULL;
3133       while (peek_atom () != ATOM_RPAREN)
3134         {
3135           n = gfc_get_namelist ();
3136           mio_symbol_ref (&n->sym);
3137
3138           if (sym->namelist == NULL)
3139             sym->namelist = n;
3140           else
3141             m->next = n;
3142
3143           m = n;
3144         }
3145       sym->namelist_tail = m;
3146     }
3147
3148   mio_rparen ();
3149 }
3150
3151
3152 /* Save/restore lists of gfc_interface structures.  When loading an
3153    interface, we are really appending to the existing list of
3154    interfaces.  Checking for duplicate and ambiguous interfaces has to
3155    be done later when all symbols have been loaded.  */
3156
3157 pointer_info *
3158 mio_interface_rest (gfc_interface **ip)
3159 {
3160   gfc_interface *tail, *p;
3161   pointer_info *pi = NULL;
3162
3163   if (iomode == IO_OUTPUT)
3164     {
3165       if (ip != NULL)
3166         for (p = *ip; p; p = p->next)
3167           mio_symbol_ref (&p->sym);
3168     }
3169   else
3170     {
3171       if (*ip == NULL)
3172         tail = NULL;
3173       else
3174         {
3175           tail = *ip;
3176           while (tail->next)
3177             tail = tail->next;
3178         }
3179
3180       for (;;)
3181         {
3182           if (peek_atom () == ATOM_RPAREN)
3183             break;
3184
3185           p = gfc_get_interface ();
3186           p->where = gfc_current_locus;
3187           pi = mio_symbol_ref (&p->sym);
3188
3189           if (tail == NULL)
3190             *ip = p;
3191           else
3192             tail->next = p;
3193
3194           tail = p;
3195         }
3196     }
3197
3198   mio_rparen ();
3199   return pi;
3200 }
3201
3202
3203 /* Save/restore a nameless operator interface.  */
3204
3205 static void
3206 mio_interface (gfc_interface **ip)
3207 {
3208   mio_lparen ();
3209   mio_interface_rest (ip);
3210 }
3211
3212
3213 /* Save/restore a named operator interface.  */
3214
3215 static void
3216 mio_symbol_interface (const char **name, const char **module,
3217                       gfc_interface **ip)
3218 {
3219   mio_lparen ();
3220   mio_pool_string (name);
3221   mio_pool_string (module);
3222   mio_interface_rest (ip);
3223 }
3224
3225
3226 static void
3227 mio_namespace_ref (gfc_namespace **nsp)
3228 {
3229   gfc_namespace *ns;
3230   pointer_info *p;
3231
3232   p = mio_pointer_ref (nsp);
3233
3234   if (p->type == P_UNKNOWN)
3235     p->type = P_NAMESPACE;
3236
3237   if (iomode == IO_INPUT && p->integer != 0)
3238     {
3239       ns = (gfc_namespace *) p->u.pointer;
3240       if (ns == NULL)
3241         {
3242           ns = gfc_get_namespace (NULL, 0);
3243           associate_integer_pointer (p, ns);
3244         }
3245       else
3246         ns->refs++;
3247     }
3248 }
3249
3250
3251 /* Save/restore the f2k_derived namespace of a derived-type symbol.  */
3252
3253 static gfc_namespace* current_f2k_derived;
3254
3255 static void
3256 mio_typebound_proc (gfc_typebound_proc** proc)
3257 {
3258   int flag;
3259   int overriding_flag;
3260
3261   if (iomode == IO_INPUT)
3262     {
3263       *proc = gfc_get_typebound_proc ();
3264       (*proc)->where = gfc_current_locus;
3265     }
3266   gcc_assert (*proc);
3267
3268   mio_lparen ();
3269
3270   (*proc)->access = MIO_NAME (gfc_access) ((*proc)->access, access_types);
3271
3272   /* IO the NON_OVERRIDABLE/DEFERRED combination.  */
3273   gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
3274   overriding_flag = ((*proc)->deferred << 1) | (*proc)->non_overridable;
3275   overriding_flag = mio_name (overriding_flag, binding_overriding);
3276   (*proc)->deferred = ((overriding_flag & 2) != 0);
3277   (*proc)->non_overridable = ((overriding_flag & 1) != 0);
3278   gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
3279
3280   (*proc)->nopass = mio_name ((*proc)->nopass, binding_passing);
3281   (*proc)->is_generic = mio_name ((*proc)->is_generic, binding_generic);
3282   (*proc)->ppc = mio_name((*proc)->ppc, binding_ppc);
3283
3284   mio_pool_string (&((*proc)->pass_arg));
3285
3286   flag = (int) (*proc)->pass_arg_num;
3287   mio_integer (&flag);
3288   (*proc)->pass_arg_num = (unsigned) flag;
3289
3290   if ((*proc)->is_generic)
3291     {
3292       gfc_tbp_generic* g;
3293
3294       mio_lparen ();
3295
3296       if (iomode == IO_OUTPUT)
3297         for (g = (*proc)->u.generic; g; g = g->next)
3298           mio_allocated_string (g->specific_st->name);
3299       else
3300         {
3301           (*proc)->u.generic = NULL;
3302           while (peek_atom () != ATOM_RPAREN)
3303             {
3304               gfc_symtree** sym_root;
3305
3306               g = gfc_get_tbp_generic ();
3307               g->specific = NULL;
3308
3309               require_atom (ATOM_STRING);
3310               sym_root = &current_f2k_derived->tb_sym_root;
3311               g->specific_st = gfc_get_tbp_symtree (sym_root, atom_string);
3312               gfc_free (atom_string);
3313
3314               g->next = (*proc)->u.generic;
3315               (*proc)->u.generic = g;
3316             }
3317         }
3318
3319       mio_rparen ();
3320     }
3321   else if (!(*proc)->ppc)
3322     mio_symtree_ref (&(*proc)->u.specific);
3323
3324   mio_rparen ();
3325 }
3326
3327 static void
3328 mio_typebound_symtree (gfc_symtree* st)
3329 {
3330   if (iomode == IO_OUTPUT && !st->n.tb)
3331     return;
3332
3333   if (iomode == IO_OUTPUT)
3334     {
3335       mio_lparen ();
3336       mio_allocated_string (st->name);
3337     }
3338   /* For IO_INPUT, the above is done in mio_f2k_derived.  */
3339
3340   mio_typebound_proc (&st->n.tb);
3341   mio_rparen ();
3342 }
3343
3344 static void
3345 mio_finalizer (gfc_finalizer **f)
3346 {
3347   if (iomode == IO_OUTPUT)
3348     {
3349       gcc_assert (*f);
3350       gcc_assert ((*f)->proc_tree); /* Should already be resolved.  */
3351       mio_symtree_ref (&(*f)->proc_tree);
3352     }
3353   else
3354     {
3355       *f = gfc_get_finalizer ();
3356       (*f)->where = gfc_current_locus; /* Value should not matter.  */
3357       (*f)->next = NULL;
3358
3359       mio_symtree_ref (&(*f)->proc_tree);
3360       (*f)->proc_sym = NULL;
3361     }
3362 }
3363
3364 static void
3365 mio_f2k_derived (gfc_namespace *f2k)
3366 {
3367   current_f2k_derived = f2k;
3368
3369   /* Handle the list of finalizer procedures.  */
3370   mio_lparen ();
3371   if (iomode == IO_OUTPUT)
3372     {
3373       gfc_finalizer *f;
3374       for (f = f2k->finalizers; f; f = f->next)
3375         mio_finalizer (&f);
3376     }
3377   else
3378     {
3379       f2k->finalizers = NULL;
3380       while (peek_atom () != ATOM_RPAREN)
3381         {
3382           gfc_finalizer *cur = NULL;
3383           mio_finalizer (&cur);
3384           cur->next = f2k->finalizers;
3385           f2k->finalizers = cur;
3386         }
3387     }
3388   mio_rparen ();
3389
3390   /* Handle type-bound procedures.  */
3391   mio_lparen ();
3392   if (iomode == IO_OUTPUT)
3393     gfc_traverse_symtree (f2k->tb_sym_root, &mio_typebound_symtree);
3394   else
3395     {
3396       while (peek_atom () == ATOM_LPAREN)
3397         {
3398           gfc_symtree* st;
3399
3400           mio_lparen ();
3401
3402           require_atom (ATOM_STRING);
3403           st = gfc_get_tbp_symtree (&f2k->tb_sym_root, atom_string);
3404           gfc_free (atom_string);
3405
3406           mio_typebound_symtree (st);
3407         }
3408     }
3409   mio_rparen ();
3410 }
3411
3412 static void
3413 mio_full_f2k_derived (gfc_symbol *sym)
3414 {
3415   mio_lparen ();
3416
3417   if (iomode == IO_OUTPUT)
3418     {
3419       if (sym->f2k_derived)
3420         mio_f2k_derived (sym->f2k_derived);
3421     }
3422   else
3423     {
3424       if (peek_atom () != ATOM_RPAREN)
3425         {
3426           sym->f2k_derived = gfc_get_namespace (NULL, 0);
3427           mio_f2k_derived (sym->f2k_derived);
3428         }
3429       else
3430         gcc_assert (!sym->f2k_derived);
3431     }
3432
3433   mio_rparen ();
3434 }
3435
3436
3437 /* Unlike most other routines, the address of the symbol node is already
3438    fixed on input and the name/module has already been filled in.  */
3439
3440 static void
3441 mio_symbol (gfc_symbol *sym)
3442 {
3443   int intmod = INTMOD_NONE;
3444
3445   mio_lparen ();
3446
3447   mio_symbol_attribute (&sym->attr);
3448   mio_typespec (&sym->ts);
3449
3450   if (iomode == IO_OUTPUT)
3451     mio_namespace_ref (&sym->formal_ns);
3452   else
3453     {
3454       mio_namespace_ref (&sym->formal_ns);
3455       if (sym->formal_ns)
3456         {
3457           sym->formal_ns->proc_name = sym;
3458           sym->refs++;
3459         }
3460     }
3461
3462   /* Save/restore common block links.  */
3463   mio_symbol_ref (&sym->common_next);
3464
3465   mio_formal_arglist (&sym->formal);
3466
3467   if (sym->attr.flavor == FL_PARAMETER)
3468     mio_expr (&sym->value);
3469
3470   mio_array_spec (&sym->as);
3471
3472   mio_symbol_ref (&sym->result);
3473
3474   if (sym->attr.cray_pointee)
3475     mio_symbol_ref (&sym->cp_pointer);
3476
3477   /* Note that components are always saved, even if they are supposed
3478      to be private.  Component access is checked during searching.  */
3479
3480   mio_component_list (&sym->components);
3481
3482   if (sym->components != NULL)
3483     sym->component_access
3484       = MIO_NAME (gfc_access) (sym->component_access, access_types);
3485
3486   /* Load/save the f2k_derived namespace of a derived-type symbol.  */
3487   mio_full_f2k_derived (sym);
3488
3489   mio_namelist (sym);
3490
3491   /* Add the fields that say whether this is from an intrinsic module,
3492      and if so, what symbol it is within the module.  */
3493 /*   mio_integer (&(sym->from_intmod)); */
3494   if (iomode == IO_OUTPUT)
3495     {
3496       intmod = sym->from_intmod;
3497       mio_integer (&intmod);
3498     }
3499   else
3500     {
3501       mio_integer (&intmod);
3502       sym->from_intmod = (intmod_id) intmod;
3503     }
3504
3505   mio_integer (&(sym->intmod_sym_id));
3506
3507   mio_rparen ();
3508 }
3509
3510
3511 /************************* Top level subroutines *************************/
3512
3513 /* Given a root symtree node and a symbol, try to find a symtree that
3514    references the symbol that is not a unique name.  */
3515
3516 static gfc_symtree *
3517 find_symtree_for_symbol (gfc_symtree *st, gfc_symbol *sym)
3518 {
3519   gfc_symtree *s = NULL;
3520
3521   if (st == NULL)
3522     return s;
3523
3524   s = find_symtree_for_symbol (st->right, sym);
3525   if (s != NULL)
3526     return s;
3527   s = find_symtree_for_symbol (st->left, sym);
3528   if (s != NULL)
3529     return s;
3530
3531   if (st->n.sym == sym && !check_unique_name (st->name))
3532     return st;
3533
3534   return s;
3535 }
3536
3537
3538 /* A recursive function to look for a specific symbol by name and by
3539    module.  Whilst several symtrees might point to one symbol, its
3540    is sufficient for the purposes here than one exist.  Note that
3541    generic interfaces are distinguished as are symbols that have been
3542    renamed in another module.  */
3543 static gfc_symtree *
3544 find_symbol (gfc_symtree *st, const char *name,
3545              const char *module, int generic)
3546 {
3547   int c;
3548   gfc_symtree *retval, *s;
3549
3550   if (st == NULL || st->n.sym == NULL)
3551     return NULL;
3552
3553   c = strcmp (name, st->n.sym->name);
3554   if (c == 0 && st->n.sym->module
3555              && strcmp (module, st->n.sym->module) == 0
3556              && !check_unique_name (st->name))
3557     {
3558       s = gfc_find_symtree (gfc_current_ns->sym_root, name);
3559
3560       /* Detect symbols that are renamed by use association in another
3561          module by the absence of a symtree and null attr.use_rename,
3562          since the latter is not transmitted in the module file.  */
3563       if (((!generic && !st->n.sym->attr.generic)
3564                 || (generic && st->n.sym->attr.generic))
3565             && !(s == NULL && !st->n.sym->attr.use_rename))
3566         return st;
3567     }
3568
3569   retval = find_symbol (st->left, name, module, generic);
3570
3571   if (retval == NULL)
3572     retval = find_symbol (st->right, name, module, generic);
3573
3574   return retval;
3575 }
3576
3577
3578 /* Skip a list between balanced left and right parens.  */
3579
3580 static void
3581 skip_list (void)
3582 {
3583   int level;
3584
3585   level = 0;
3586   do
3587     {
3588       switch (parse_atom ())
3589         {
3590         case ATOM_LPAREN:
3591           level++;
3592           break;
3593
3594         case ATOM_RPAREN:
3595           level--;
3596           break;
3597
3598         case ATOM_STRING:
3599           gfc_free (atom_string);
3600           break;
3601
3602         case ATOM_NAME:
3603         case ATOM_INTEGER:
3604           break;
3605         }
3606     }
3607   while (level > 0);
3608 }
3609
3610
3611 /* Load operator interfaces from the module.  Interfaces are unusual
3612    in that they attach themselves to existing symbols.  */
3613
3614 static void
3615 load_operator_interfaces (void)
3616 {
3617   const char *p;
3618   char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3619   gfc_user_op *uop;
3620   pointer_info *pi = NULL;
3621   int n, i;
3622
3623   mio_lparen ();
3624
3625   while (peek_atom () != ATOM_RPAREN)
3626     {
3627       mio_lparen ();
3628
3629       mio_internal_string (name);
3630       mio_internal_string (module);
3631
3632       n = number_use_names (name, true);
3633       n = n ? n : 1;
3634
3635       for (i = 1; i <= n; i++)
3636         {
3637           /* Decide if we need to load this one or not.  */
3638           p = find_use_name_n (name, &i, true);
3639
3640           if (p == NULL)
3641             {
3642               while (parse_atom () != ATOM_RPAREN);
3643               continue;
3644             }
3645
3646           if (i == 1)
3647             {
3648               uop = gfc_get_uop (p);
3649               pi = mio_interface_rest (&uop->op);
3650             }
3651           else
3652             {
3653               if (gfc_find_uop (p, NULL))
3654                 continue;
3655               uop = gfc_get_uop (p);
3656               uop->op = gfc_get_interface ();
3657               uop->op->where = gfc_current_locus;
3658               add_fixup (pi->integer, &uop->op->sym);
3659             }
3660         }
3661     }
3662
3663   mio_rparen ();
3664 }
3665
3666
3667 /* Load interfaces from the module.  Interfaces are unusual in that
3668    they attach themselves to existing symbols.  */
3669
3670 static void
3671 load_generic_interfaces (void)
3672 {
3673   const char *p;
3674   char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3675   gfc_symbol *sym;
3676   gfc_interface *generic = NULL;
3677   int n, i, renamed;
3678
3679   mio_lparen ();
3680
3681   while (peek_atom () != ATOM_RPAREN)
3682     {
3683       mio_lparen ();
3684
3685       mio_internal_string (name);
3686       mio_internal_string (module);
3687
3688       n = number_use_names (name, false);
3689       renamed = n ? 1 : 0;
3690       n = n ? n : 1;
3691
3692       for (i = 1; i <= n; i++)
3693         {
3694           gfc_symtree *st;
3695           /* Decide if we need to load this one or not.  */
3696           p = find_use_name_n (name, &i, false);
3697
3698           st = find_symbol (gfc_current_ns->sym_root,
3699                             name, module_name, 1);
3700
3701           if (!p || gfc_find_symbol (p, NULL, 0, &sym))
3702             {
3703               /* Skip the specific names for these cases.  */
3704               while (i == 1 && parse_atom () != ATOM_RPAREN);
3705
3706               continue;
3707             }
3708
3709           /* If the symbol exists already and is being USEd without being
3710              in an ONLY clause, do not load a new symtree(11.3.2).  */
3711           if (!only_flag && st)
3712             sym = st->n.sym;
3713
3714           if (!sym)
3715             {
3716               /* Make the symbol inaccessible if it has been added by a USE
3717                  statement without an ONLY(11.3.2).  */
3718               if (st && only_flag
3719                      && !st->n.sym->attr.use_only
3720                      && !st->n.sym->attr.use_rename
3721                      && strcmp (st->n.sym->module, module_name) == 0)
3722                 {
3723                   sym = st->n.sym;
3724                   gfc_delete_symtree (&gfc_current_ns->sym_root, name);
3725                   st = gfc_get_unique_symtree (gfc_current_ns);
3726                   st->n.sym = sym;
3727                   sym = NULL;
3728                 }
3729               else if (st)
3730                 {
3731                   sym = st->n.sym;
3732                   if (strcmp (st->name, p) != 0)
3733                     {
3734                       st = gfc_new_symtree (&gfc_current_ns->sym_root, p);
3735                       st->n.sym = sym;
3736                       sym->refs++;
3737                     }
3738                 }
3739
3740               /* Since we haven't found a valid generic interface, we had
3741                  better make one.  */
3742               if (!sym)
3743                 {
3744                   gfc_get_symbol (p, NULL, &sym);
3745                   sym->name = gfc_get_string (name);
3746                   sym->module = gfc_get_string (module_name);
3747                   sym->attr.flavor = FL_PROCEDURE;
3748                   sym->attr.generic = 1;
3749                   sym->attr.use_assoc = 1;
3750                 }
3751             }
3752           else
3753             {
3754               /* Unless sym is a generic interface, this reference
3755                  is ambiguous.  */
3756               if (st == NULL)
3757                 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
3758
3759               sym = st->n.sym;
3760
3761               if (st && !sym->attr.generic
3762                      && sym->module
3763                      && strcmp(module, sym->module))
3764                 st->ambiguous = 1;
3765             }
3766
3767           sym->attr.use_only = only_flag;
3768           sym->attr.use_rename = renamed;
3769
3770           if (i == 1)
3771             {
3772               mio_interface_rest (&sym->generic);
3773               generic = sym->generic;
3774             }
3775           else if (!sym->generic)
3776             {
3777               sym->generic = generic;
3778               sym->attr.generic_copy = 1;
3779             }
3780         }
3781     }
3782
3783   mio_rparen ();
3784 }
3785
3786
3787 /* Load common blocks.  */
3788
3789 static void
3790 load_commons (void)
3791 {
3792   char name[GFC_MAX_SYMBOL_LEN + 1];
3793   gfc_common_head *p;
3794
3795   mio_lparen ();
3796
3797   while (peek_atom () != ATOM_RPAREN)
3798     {
3799       int flags;
3800       mio_lparen ();
3801       mio_internal_string (name);
3802
3803       p = gfc_get_common (name, 1);
3804
3805       mio_symbol_ref (&p->head);
3806       mio_integer (&flags);
3807       if (flags & 1)
3808         p->saved = 1;
3809       if (flags & 2)
3810         p->threadprivate = 1;
3811       p->use_assoc = 1;
3812
3813       /* Get whether this was a bind(c) common or not.  */
3814       mio_integer (&p->is_bind_c);
3815       /* Get the binding label.  */
3816       mio_internal_string (p->binding_label);
3817
3818       mio_rparen ();
3819     }
3820
3821   mio_rparen ();
3822 }
3823
3824
3825 /* Load equivalences.  The flag in_load_equiv informs mio_expr_ref of this
3826    so that unused variables are not loaded and so that the expression can
3827    be safely freed.  */
3828
3829 static void
3830 load_equiv (void)
3831 {
3832   gfc_equiv *head, *tail, *end, *eq;
3833   bool unused;
3834
3835   mio_lparen ();
3836   in_load_equiv = true;
3837
3838   end = gfc_current_ns->equiv;
3839   while (end != NULL && end->next != NULL)
3840     end = end->next;
3841
3842   while (peek_atom () != ATOM_RPAREN) {
3843     mio_lparen ();
3844     head = tail = NULL;
3845
3846     while(peek_atom () != ATOM_RPAREN)
3847       {
3848         if (head == NULL)
3849           head = tail = gfc_get_equiv ();
3850         else
3851           {
3852             tail->eq = gfc_get_equiv ();
3853             tail = tail->eq;
3854           }
3855
3856         mio_pool_string (&tail->module);
3857         mio_expr (&tail->expr);
3858       }
3859
3860     /* Unused equivalence members have a unique name.  In addition, it
3861        must be checked that the symbols are from the same module.  */
3862     unused = true;
3863     for (eq = head; eq; eq = eq->eq)
3864       {
3865         if (eq->expr->symtree->n.sym->module
3866               && head->expr->symtree->n.sym->module
3867               && strcmp (head->expr->symtree->n.sym->module,
3868                          eq->expr->symtree->n.sym->module) == 0
3869               && !check_unique_name (eq->expr->symtree->name))
3870           {
3871             unused = false;
3872             break;
3873           }
3874       }
3875
3876     if (unused)
3877       {
3878         for (eq = head; eq; eq = head)
3879           {
3880             head = eq->eq;
3881             gfc_free_expr (eq->expr);
3882             gfc_free (eq);
3883           }
3884       }
3885
3886     if (end == NULL)
3887       gfc_current_ns->equiv = head;
3888     else
3889       end->next = head;
3890
3891     if (head != NULL)
3892       end = head;
3893
3894     mio_rparen ();
3895   }
3896
3897   mio_rparen ();
3898   in_load_equiv = false;
3899 }
3900
3901
3902 /* Recursive function to traverse the pointer_info tree and load a
3903    needed symbol.  We return nonzero if we load a symbol and stop the
3904    traversal, because the act of loading can alter the tree.  */
3905
3906 static int
3907 load_needed (pointer_info *p)
3908 {
3909   gfc_namespace *ns;
3910   pointer_info *q;
3911   gfc_symbol *sym;
3912   int rv;
3913
3914   rv = 0;
3915   if (p == NULL)
3916     return rv;
3917
3918   rv |= load_needed (p->left);
3919   rv |= load_needed (p->right);
3920
3921   if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED)
3922     return rv;
3923
3924   p->u.rsym.state = USED;
3925
3926   set_module_locus (&p->u.rsym.where);
3927
3928   sym = p->u.rsym.sym;
3929   if (sym == NULL)
3930     {
3931       q = get_integer (p->u.rsym.ns);
3932
3933       ns = (gfc_namespace *) q->u.pointer;
3934       if (ns == NULL)
3935         {
3936           /* Create an interface namespace if necessary.  These are
3937              the namespaces that hold the formal parameters of module
3938              procedures.  */
3939
3940           ns = gfc_get_namespace (NULL, 0);
3941           associate_integer_pointer (q, ns);
3942         }
3943
3944       /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
3945          doesn't go pear-shaped if the symbol is used.  */
3946       if (!ns->proc_name)
3947         gfc_find_symbol (p->u.rsym.module, gfc_current_ns,
3948                                  1, &ns->proc_name);
3949
3950       sym = gfc_new_symbol (p->u.rsym.true_name, ns);
3951       sym->module = gfc_get_string (p->u.rsym.module);
3952       strcpy (sym->binding_label, p->u.rsym.binding_label);
3953
3954       associate_integer_pointer (p, sym);
3955     }
3956
3957   mio_symbol (sym);
3958   sym->attr.use_assoc = 1;
3959   if (only_flag)
3960     sym->attr.use_only = 1;
3961   if (p->u.rsym.renamed)
3962     sym->attr.use_rename = 1;
3963
3964   return 1;
3965 }
3966
3967
3968 /* Recursive function for cleaning up things after a module has been read.  */
3969
3970 static void
3971 read_cleanup (pointer_info *p)
3972 {
3973   gfc_symtree *st;
3974   pointer_info *q;
3975
3976   if (p == NULL)
3977     return;
3978
3979   read_cleanup (p->left);
3980   read_cleanup (p->right);
3981
3982   if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
3983     {
3984       /* Add hidden symbols to the symtree.  */
3985       q = get_integer (p->u.rsym.ns);
3986       st = gfc_get_unique_symtree ((gfc_namespace *) q->u.pointer);
3987
3988       st->n.sym = p->u.rsym.sym;
3989       st->n.sym->refs++;
3990
3991       /* Fixup any symtree references.  */
3992       p->u.rsym.symtree = st;
3993       resolve_fixups (p->u.rsym.stfixup, st);
3994       p->u.rsym.stfixup = NULL;
3995     }
3996
3997   /* Free unused symbols.  */
3998   if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED)
3999     gfc_free_symbol (p->u.rsym.sym);
4000 }
4001
4002
4003 /* It is not quite enough to check for ambiguity in the symbols by
4004    the loaded symbol and the new symbol not being identical.  */
4005 static bool
4006 check_for_ambiguous (gfc_symbol *st_sym, pointer_info *info)
4007 {
4008   gfc_symbol *rsym;
4009   module_locus locus;
4010   symbol_attribute attr;
4011
4012   rsym = info->u.rsym.sym;
4013   if (st_sym == rsym)
4014     return false;
4015
4016   /* If the existing symbol is generic from a different module and
4017      the new symbol is generic there can be no ambiguity.  */
4018   if (st_sym->attr.generic
4019         && st_sym->module
4020         && strcmp (st_sym->module, module_name))
4021     {
4022       /* The new symbol's attributes have not yet been read.  Since
4023          we need attr.generic, read it directly.  */
4024       get_module_locus (&locus);
4025       set_module_locus (&info->u.rsym.where);
4026       mio_lparen ();
4027       attr.generic = 0;
4028       mio_symbol_attribute (&attr);
4029       set_module_locus (&locus);
4030       if (attr.generic)
4031         return false;
4032     }
4033
4034   return true;
4035 }
4036
4037
4038 /* Read a module file.  */
4039
4040 static void
4041 read_module (void)
4042 {
4043   module_locus operator_interfaces, user_operators;
4044   const char *p;
4045   char name[GFC_MAX_SYMBOL_LEN + 1];
4046   int i;
4047   int ambiguous, j, nuse, symbol;
4048   pointer_info *info, *q;
4049   gfc_use_rename *u;
4050   gfc_symtree *st;
4051   gfc_symbol *sym;
4052
4053   get_module_locus (&operator_interfaces);      /* Skip these for now.  */
4054   skip_list ();
4055
4056   get_module_locus (&user_operators);
4057   skip_list ();
4058   skip_list ();
4059
4060   /* Skip commons and equivalences for now.  */
4061   skip_list ();
4062   skip_list ();
4063
4064   mio_lparen ();
4065
4066   /* Create the fixup nodes for all the symbols.  */
4067
4068   while (peek_atom () != ATOM_RPAREN)
4069     {
4070       require_atom (ATOM_INTEGER);
4071       info = get_integer (atom_int);
4072
4073       info->type = P_SYMBOL;
4074       info->u.rsym.state = UNUSED;
4075
4076       mio_internal_string (info->u.rsym.true_name);
4077       mio_internal_string (info->u.rsym.module);
4078       mio_internal_string (info->u.rsym.binding_label);
4079
4080
4081       require_atom (ATOM_INTEGER);
4082       info->u.rsym.ns = atom_int;
4083
4084       get_module_locus (&info->u.rsym.where);
4085       skip_list ();
4086
4087       /* See if the symbol has already been loaded by a previous module.
4088          If so, we reference the existing symbol and prevent it from
4089          being loaded again.  This should not happen if the symbol being
4090          read is an index for an assumed shape dummy array (ns != 1).  */
4091
4092       sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
4093
4094       if (sym == NULL
4095           || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
4096         continue;
4097
4098       info->u.rsym.state = USED;
4099       info->u.rsym.sym = sym;
4100
4101       /* Some symbols do not have a namespace (eg. formal arguments),
4102          so the automatic "unique symtree" mechanism must be suppressed
4103          by marking them as referenced.  */
4104       q = get_integer (info->u.rsym.ns);
4105       if (q->u.pointer == NULL)
4106         {
4107           info->u.rsym.referenced = 1;
4108           continue;
4109         }
4110
4111       /* If possible recycle the symtree that references the symbol.
4112          If a symtree is not found and the module does not import one,
4113          a unique-name symtree is found by read_cleanup.  */
4114       st = find_symtree_for_symbol (gfc_current_ns->sym_root, sym);
4115       if (st != NULL)
4116         {
4117           info->u.rsym.symtree = st;
4118           info->u.rsym.referenced = 1;
4119         }
4120     }
4121
4122   mio_rparen ();
4123
4124   /* Parse the symtree lists.  This lets us mark which symbols need to
4125      be loaded.  Renaming is also done at this point by replacing the
4126      symtree name.  */
4127
4128   mio_lparen ();
4129
4130   while (peek_atom () != ATOM_RPAREN)
4131     {
4132       mio_internal_string (name);
4133       mio_integer (&ambiguous);
4134       mio_integer (&symbol);
4135
4136       info = get_integer (symbol);
4137
4138       /* See how many use names there are.  If none, go through the start
4139          of the loop at least once.  */
4140       nuse = number_use_names (name, false);
4141       info->u.rsym.renamed = nuse ? 1 : 0;
4142
4143       if (nuse == 0)
4144         nuse = 1;
4145
4146       for (j = 1; j <= nuse; j++)
4147         {
4148           /* Get the jth local name for this symbol.  */
4149           p = find_use_name_n (name, &j, false);
4150
4151           if (p == NULL && strcmp (name, module_name) == 0)
4152             p = name;
4153
4154           /* Skip symtree nodes not in an ONLY clause, unless there
4155              is an existing symtree loaded from another USE statement.  */
4156           if (p == NULL)
4157             {
4158               st = gfc_find_symtree (gfc_current_ns->sym_root, name);
4159               if (st != NULL)
4160                 info->u.rsym.symtree = st;
4161               continue;
4162             }
4163
4164           /* If a symbol of the same name and module exists already,
4165              this symbol, which is not in an ONLY clause, must not be
4166              added to the namespace(11.3.2).  Note that find_symbol
4167              only returns the first occurrence that it finds.  */
4168           if (!only_flag && !info->u.rsym.renamed
4169                 && strcmp (name, module_name) != 0
4170                 && find_symbol (gfc_current_ns->sym_root, name,
4171                                 module_name, 0))
4172             continue;
4173
4174           st = gfc_find_symtree (gfc_current_ns->sym_root, p);
4175
4176           if (st != NULL)
4177             {
4178               /* Check for ambiguous symbols.  */
4179               if (check_for_ambiguous (st->n.sym, info))
4180                 st->ambiguous = 1;
4181               info->u.rsym.symtree = st;
4182             }
4183           else
4184             {
4185               st = gfc_find_symtree (gfc_current_ns->sym_root, name);
4186
4187               /* Delete the symtree if the symbol has been added by a USE
4188                  statement without an ONLY(11.3.2).  Remember that the rsym
4189                  will be the same as the symbol found in the symtree, for
4190                  this case.  */
4191               if (st && (only_flag || info->u.rsym.renamed)
4192                      && !st->n.sym->attr.use_only
4193                      && !st->n.sym->attr.use_rename
4194                      && info->u.rsym.sym == st->n.sym)
4195                 gfc_delete_symtree (&gfc_current_ns->sym_root, name);
4196
4197               /* Create a symtree node in the current namespace for this
4198                  symbol.  */
4199               st = check_unique_name (p)
4200                    ? gfc_get_unique_symtree (gfc_current_ns)
4201                    : gfc_new_symtree (&gfc_current_ns->sym_root, p);
4202               st->ambiguous = ambiguous;
4203
4204               sym = info->u.rsym.sym;
4205
4206               /* Create a symbol node if it doesn't already exist.  */
4207               if (sym == NULL)
4208                 {
4209                   info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
4210                                                      gfc_current_ns);
4211                   sym = info->u.rsym.sym;
4212                   sym->module = gfc_get_string (info->u.rsym.module);
4213
4214                   /* TODO: hmm, can we test this?  Do we know it will be
4215                      initialized to zeros?  */
4216                   if (info->u.rsym.binding_label[0] != '\0')
4217                     strcpy (sym->binding_label, info->u.rsym.binding_label);
4218                 }
4219
4220               st->n.sym = sym;
4221               st->n.sym->refs++;
4222
4223               if (strcmp (name, p) != 0)
4224                 sym->attr.use_rename = 1;
4225
4226               /* We need to set the only_flag here so that symbols from the
4227                  same USE...ONLY but earlier are not deleted from the tree in
4228                  the gfc_delete_symtree above.  */
4229               sym->attr.use_only = only_flag;
4230
4231               /* Store the symtree pointing to this symbol.  */
4232               info->u.rsym.symtree = st;
4233
4234               if (info->u.rsym.state == UNUSED)
4235                 info->u.rsym.state = NEEDED;
4236               info->u.rsym.referenced = 1;
4237             }
4238         }
4239     }
4240
4241   mio_rparen ();
4242
4243   /* Load intrinsic operator interfaces.  */
4244   set_module_locus (&operator_interfaces);
4245   mio_lparen ();
4246
4247   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
4248     {
4249       if (i == INTRINSIC_USER)
4250         continue;
4251
4252       if (only_flag)
4253         {
4254           u = find_use_operator ((gfc_intrinsic_op) i);
4255
4256           if (u == NULL)
4257             {
4258               skip_list ();
4259               continue;
4260             }
4261
4262           u->found = 1;
4263         }
4264
4265       mio_interface (&gfc_current_ns->op[i]);
4266     }
4267
4268   mio_rparen ();
4269
4270   /* Load generic and user operator interfaces.  These must follow the
4271      loading of symtree because otherwise symbols can be marked as
4272      ambiguous.  */
4273
4274   set_module_locus (&user_operators);
4275
4276   load_operator_interfaces ();
4277   load_generic_interfaces ();
4278
4279   load_commons ();
4280   load_equiv ();
4281
4282   /* At this point, we read those symbols that are needed but haven't
4283      been loaded yet.  If one symbol requires another, the other gets
4284      marked as NEEDED if its previous state was UNUSED.  */
4285
4286   while (load_needed (pi_root));
4287
4288   /* Make sure all elements of the rename-list were found in the module.  */
4289
4290   for (u = gfc_rename_list; u; u = u->next)
4291     {
4292       if (u->found)
4293         continue;
4294
4295       if (u->op == INTRINSIC_NONE)
4296         {
4297           gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
4298                      u->use_name, &u->where, module_name);
4299           continue;
4300         }
4301
4302       if (u->op == INTRINSIC_USER)
4303         {
4304           gfc_error ("User operator '%s' referenced at %L not found "
4305                      "in module '%s'", u->use_name, &u->where, module_name);
4306           continue;
4307         }
4308
4309       gfc_error ("Intrinsic operator '%s' referenced at %L not found "
4310                  "in module '%s'", gfc_op2string (u->op), &u->where,
4311                  module_name);
4312     }
4313
4314   gfc_check_interfaces (gfc_current_ns);
4315
4316   /* Clean up symbol nodes that were never loaded, create references
4317      to hidden symbols.  */
4318
4319   read_cleanup (pi_root);
4320 }
4321
4322
4323 /* Given an access type that is specific to an entity and the default
4324    access, return nonzero if the entity is publicly accessible.  If the
4325    element is declared as PUBLIC, then it is public; if declared
4326    PRIVATE, then private, and otherwise it is public unless the default
4327    access in this context has been declared PRIVATE.  */
4328
4329 bool
4330 gfc_check_access (gfc_access specific_access, gfc_access default_access)
4331 {
4332   if (specific_access == ACCESS_PUBLIC)
4333     return TRUE;
4334   if (specific_access == ACCESS_PRIVATE)
4335     return FALSE;
4336
4337   if (gfc_option.flag_module_private)
4338     return default_access == ACCESS_PUBLIC;
4339   else
4340     return default_access != ACCESS_PRIVATE;
4341 }
4342
4343
4344 /* A structure to remember which commons we've already written.  */
4345
4346 struct written_common
4347 {
4348   BBT_HEADER(written_common);
4349   const char *name, *label;
4350 };
4351
4352 static struct written_common *written_commons = NULL;
4353
4354 /* Comparison function used for balancing the binary tree.  */
4355
4356 static int
4357 compare_written_commons (void *a1, void *b1)
4358 {
4359   const char *aname = ((struct written_common *) a1)->name;
4360   const char *alabel = ((struct written_common *) a1)->label;
4361   const char *bname = ((struct written_common *) b1)->name;
4362   const char *blabel = ((struct written_common *) b1)->label;
4363   int c = strcmp (aname, bname);
4364
4365   return (c != 0 ? c : strcmp (alabel, blabel));
4366 }
4367
4368 /* Free a list of written commons.  */
4369
4370 static void
4371 free_written_common (struct written_common *w)
4372 {
4373   if (!w)
4374     return;
4375
4376   if (w->left)
4377     free_written_common (w->left);
4378   if (w->right)
4379     free_written_common (w->right);
4380
4381   gfc_free (w);
4382 }
4383
4384 /* Write a common block to the module -- recursive helper function.  */
4385
4386 static void
4387 write_common_0 (gfc_symtree *st, bool this_module)
4388 {
4389   gfc_common_head *p;
4390   const char * name;
4391   int flags;
4392   const char *label;
4393   struct written_common *w;
4394   bool write_me = true;
4395
4396   if (st == NULL)
4397     return;
4398
4399   write_common_0 (st->left, this_module);
4400
4401   /* We will write out the binding label, or the name if no label given.  */
4402   name = st->n.common->name;
4403   p = st->n.common;
4404   label = p->is_bind_c ? p->binding_label : p->name;
4405
4406   /* Check if we've already output this common.  */
4407   w = written_commons;
4408   while (w)
4409     {
4410       int c = strcmp (name, w->name);
4411       c = (c != 0 ? c : strcmp (label, w->label));
4412       if (c == 0)
4413         write_me = false;
4414
4415       w = (c < 0) ? w->left : w->right;
4416     }
4417
4418   if (this_module && p->use_assoc)
4419     write_me = false;
4420
4421   if (write_me)
4422     {
4423       /* Write the common to the module.  */
4424       mio_lparen ();
4425       mio_pool_string (&name);
4426
4427       mio_symbol_ref (&p->head);
4428       flags = p->saved ? 1 : 0;
4429       if (p->threadprivate)
4430         flags |= 2;
4431       mio_integer (&flags);
4432
4433       /* Write out whether the common block is bind(c) or not.  */
4434       mio_integer (&(p->is_bind_c));
4435
4436       mio_pool_string (&label);
4437       mio_rparen ();
4438
4439       /* Record that we have written this common.  */
4440       w = XCNEW (struct written_common);
4441       w->name = p->name;
4442       w->label = label;
4443       gfc_insert_bbt (&written_commons, w, compare_written_commons);
4444     }
4445
4446   write_common_0 (st->right, this_module);
4447 }
4448
4449
4450 /* Write a common, by initializing the list of written commons, calling
4451    the recursive function write_common_0() and cleaning up afterwards.  */
4452
4453 static void
4454 write_common (gfc_symtree *st)
4455 {
4456   written_commons = NULL;
4457   write_common_0 (st, true);
4458   write_common_0 (st, false);
4459   free_written_common (written_commons);
4460   written_commons = NULL;
4461 }
4462
4463
4464 /* Write the blank common block to the module.  */
4465
4466 static void
4467 write_blank_common (void)
4468 {
4469   const char * name = BLANK_COMMON_NAME;
4470   int saved;
4471   /* TODO: Blank commons are not bind(c).  The F2003 standard probably says
4472      this, but it hasn't been checked.  Just making it so for now.  */
4473   int is_bind_c = 0;
4474
4475   if (gfc_current_ns->blank_common.head == NULL)
4476     return;
4477
4478   mio_lparen ();
4479
4480   mio_pool_string (&name);
4481
4482   mio_symbol_ref (&gfc_current_ns->blank_common.head);
4483   saved = gfc_current_ns->blank_common.saved;
4484   mio_integer (&saved);
4485
4486   /* Write out whether the common block is bind(c) or not.  */
4487   mio_integer (&is_bind_c);
4488
4489   /* Write out the binding label, which is BLANK_COMMON_NAME, though
4490      it doesn't matter because the label isn't used.  */
4491   mio_pool_string (&name);
4492
4493   mio_rparen ();
4494 }
4495
4496
4497 /* Write equivalences to the module.  */
4498
4499 static void
4500 write_equiv (void)
4501 {
4502   gfc_equiv *eq, *e;
4503   int num;
4504
4505   num = 0;
4506   for (eq = gfc_current_ns->equiv; eq; eq = eq->next)
4507     {
4508       mio_lparen ();
4509
4510       for (e = eq; e; e = e->eq)
4511         {
4512           if (e->module == NULL)
4513             e->module = gfc_get_string ("%s.eq.%d", module_name, num);
4514           mio_allocated_string (e->module);
4515           mio_expr (&e->expr);
4516         }
4517
4518       num++;
4519       mio_rparen ();
4520     }
4521 }
4522
4523
4524 /* Write a symbol to the module.  */
4525
4526 static void
4527 write_symbol (int n, gfc_symbol *sym)
4528 {
4529   const char *label;
4530
4531   if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
4532     gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
4533
4534   mio_integer (&n);
4535   mio_pool_string (&sym->name);
4536
4537   mio_pool_string (&sym->module);
4538   if (sym->attr.is_bind_c || sym->attr.is_iso_c)
4539     {
4540       label = sym->binding_label;
4541       mio_pool_string (&label);
4542     }
4543   else
4544     mio_pool_string (&sym->name);
4545
4546   mio_pointer_ref (&sym->ns);
4547
4548   mio_symbol (sym);
4549   write_char ('\n');
4550 }
4551
4552
4553 /* Recursive traversal function to write the initial set of symbols to
4554    the module.  We check to see if the symbol should be written
4555    according to the access specification.  */
4556
4557 static void
4558 write_symbol0 (gfc_symtree *st)
4559 {
4560   gfc_symbol *sym;
4561   pointer_info *p;
4562   bool dont_write = false;
4563
4564   if (st == NULL)
4565     return;
4566
4567   write_symbol0 (st->left);
4568
4569   sym = st->n.sym;
4570   if (sym->module == NULL)
4571     sym->module = gfc_get_string (module_name);
4572
4573   if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
4574       && !sym->attr.subroutine && !sym->attr.function)
4575     dont_write = true;
4576
4577   if (!gfc_check_access (sym->attr.access, sym->ns->default_access))
4578     dont_write = true;
4579
4580   if (!dont_write)
4581     {
4582       p = get_pointer (sym);
4583       if (p->type == P_UNKNOWN)
4584         p->type = P_SYMBOL;
4585
4586       if (p->u.wsym.state != WRITTEN)
4587         {
4588           write_symbol (p->integer, sym);
4589           p->u.wsym.state = WRITTEN;
4590         }
4591     }
4592
4593   write_symbol0 (st->right);
4594 }
4595
4596
4597 /* Recursive traversal function to write the secondary set of symbols
4598    to the module file.  These are symbols that were not public yet are
4599    needed by the public symbols or another dependent symbol.  The act
4600    of writing a symbol can modify the pointer_info tree, so we cease
4601    traversal if we find a symbol to write.  We return nonzero if a
4602    symbol was written and pass that information upwards.  */
4603
4604 static int
4605 write_symbol1 (pointer_info *p)
4606 {
4607   int result;
4608
4609   if (!p)
4610     return 0;
4611
4612   result = write_symbol1 (p->left);
4613
4614   if (!(p->type != P_SYMBOL || p->u.wsym.state != NEEDS_WRITE))
4615     {
4616       p->u.wsym.state = WRITTEN;
4617       write_symbol (p->integer, p->u.wsym.sym);
4618       result = 1;
4619     }
4620
4621   result |= write_symbol1 (p->right);
4622   return result;
4623 }
4624
4625
4626 /* Write operator interfaces associated with a symbol.  */
4627
4628 static void
4629 write_operator (gfc_user_op *uop)
4630 {
4631   static char nullstring[] = "";
4632   const char *p = nullstring;
4633
4634   if (uop->op == NULL
4635       || !gfc_check_access (uop->access, uop->ns->default_access))
4636     return;
4637
4638   mio_symbol_interface (&uop->name, &p, &uop->op);
4639 }
4640
4641
4642 /* Write generic interfaces from the namespace sym_root.  */
4643
4644 static void
4645 write_generic (gfc_symtree *st)
4646 {
4647   gfc_symbol *sym;
4648
4649   if (st == NULL)
4650     return;
4651
4652   write_generic (st->left);
4653   write_generic (st->right);
4654
4655   sym = st->n.sym;
4656   if (!sym || check_unique_name (st->name))
4657     return;
4658
4659   if (sym->generic == NULL
4660       || !gfc_check_access (sym->attr.access, sym->ns->default_access))
4661     return;
4662
4663   if (sym->module == NULL)
4664     sym->module = gfc_get_string (module_name);
4665
4666   mio_symbol_interface (&st->name, &sym->module, &sym->generic);
4667 }
4668
4669
4670 static void
4671 write_symtree (gfc_symtree *st)
4672 {
4673   gfc_symbol *sym;
4674   pointer_info *p;
4675
4676   sym = st->n.sym;
4677
4678   /* A symbol in an interface body must not be visible in the
4679      module file.  */
4680   if (sym->ns != gfc_current_ns
4681         && sym->ns->proc_name
4682         && sym->ns->proc_name->attr.if_source == IFSRC_IFBODY)
4683     return;
4684
4685   if (!gfc_check_access (sym->attr.access, sym->ns->default_access)
4686       || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
4687           && !sym->attr.subroutine && !sym->attr.function))
4688     return;
4689
4690   if (check_unique_name (st->name))
4691     return;
4692
4693   p = find_pointer (sym);
4694   if (p == NULL)
4695     gfc_internal_error ("write_symtree(): Symbol not written");
4696
4697   mio_pool_string (&st->name);
4698   mio_integer (&st->ambiguous);
4699   mio_integer (&p->integer);
4700 }
4701
4702
4703 static void
4704 write_module (void)
4705 {
4706   int i;
4707
4708   /* Write the operator interfaces.  */
4709   mio_lparen ();
4710
4711   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
4712     {
4713       if (i == INTRINSIC_USER)
4714         continue;
4715
4716       mio_interface (gfc_check_access (gfc_current_ns->operator_access[i],
4717                                        gfc_current_ns->default_access)
4718                      ? &gfc_current_ns->op[i] : NULL);
4719     }
4720
4721   mio_rparen ();
4722   write_char ('\n');
4723   write_char ('\n');
4724
4725   mio_lparen ();
4726   gfc_traverse_user_op (gfc_current_ns, write_operator);
4727   mio_rparen ();
4728   write_char ('\n');
4729   write_char ('\n');
4730
4731   mio_lparen ();
4732   write_generic (gfc_current_ns->sym_root);
4733   mio_rparen ();
4734   write_char ('\n');
4735   write_char ('\n');
4736
4737   mio_lparen ();
4738   write_blank_common ();
4739   write_common (gfc_current_ns->common_root);
4740   mio_rparen ();
4741   write_char ('\n');
4742   write_char ('\n');
4743
4744   mio_lparen ();
4745   write_equiv ();
4746   mio_rparen ();
4747   write_char ('\n');
4748   write_char ('\n');
4749
4750   /* Write symbol information.  First we traverse all symbols in the
4751      primary namespace, writing those that need to be written.
4752      Sometimes writing one symbol will cause another to need to be
4753      written.  A list of these symbols ends up on the write stack, and
4754      we end by popping the bottom of the stack and writing the symbol
4755      until the stack is empty.  */
4756
4757   mio_lparen ();
4758
4759   write_symbol0 (gfc_current_ns->sym_root);
4760   while (write_symbol1 (pi_root))
4761     /* Nothing.  */;
4762
4763   mio_rparen ();
4764
4765   write_char ('\n');
4766   write_char ('\n');
4767
4768   mio_lparen ();
4769   gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
4770   mio_rparen ();
4771 }
4772
4773
4774 /* Read a MD5 sum from the header of a module file.  If the file cannot
4775    be opened, or we have any other error, we return -1.  */
4776
4777 static int
4778 read_md5_from_module_file (const char * filename, unsigned char md5[16])
4779 {
4780   FILE *file;
4781   char buf[1024];
4782   int n;
4783
4784   /* Open the file.  */
4785   if ((file = fopen (filename, "r")) == NULL)
4786     return -1;
4787
4788   /* Read the first line.  */
4789   if (fgets (buf, sizeof (buf) - 1, file) == NULL)
4790     {
4791       fclose (file);
4792       return -1;
4793     }
4794
4795   /* The file also needs to be overwritten if the version number changed.  */
4796   n = strlen ("GFORTRAN module version '" MOD_VERSION "' created");
4797   if (strncmp (buf, "GFORTRAN module version '" MOD_VERSION "' created", n) != 0)
4798     {
4799       fclose (file);
4800       return -1;
4801     }
4802
4803   /* Read a second line.  */
4804   if (fgets (buf, sizeof (buf) - 1, file) == NULL)
4805     {
4806       fclose (file);
4807       return -1;
4808     }
4809
4810   /* Close the file.  */
4811   fclose (file);
4812
4813   /* If the header is not what we expect, or is too short, bail out.  */
4814   if (strncmp (buf, "MD5:", 4) != 0 || strlen (buf) < 4 + 16)
4815     return -1;
4816
4817   /* Now, we have a real MD5, read it into the array.  */
4818   for (n = 0; n < 16; n++)
4819     {
4820       unsigned int x;
4821
4822       if (sscanf (&(buf[4+2*n]), "%02x", &x) != 1)
4823        return -1;
4824
4825       md5[n] = x;
4826     }
4827
4828   return 0;
4829 }
4830
4831
4832 /* Given module, dump it to disk.  If there was an error while
4833    processing the module, dump_flag will be set to zero and we delete
4834    the module file, even if it was already there.  */
4835
4836 void
4837 gfc_dump_module (const char *name, int dump_flag)
4838 {
4839   int n;
4840   char *filename, *filename_tmp, *p;
4841   time_t now;
4842   fpos_t md5_pos;
4843   unsigned char md5_new[16], md5_old[16];
4844
4845   n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
4846   if (gfc_option.module_dir != NULL)
4847     {
4848       n += strlen (gfc_option.module_dir);
4849       filename = (char *) alloca (n);
4850       strcpy (filename, gfc_option.module_dir);
4851       strcat (filename, name);
4852     }
4853   else
4854     {
4855       filename = (char *) alloca (n);
4856       strcpy (filename, name);
4857     }
4858   strcat (filename, MODULE_EXTENSION);
4859
4860   /* Name of the temporary file used to write the module.  */
4861   filename_tmp = (char *) alloca (n + 1);
4862   strcpy (filename_tmp, filename);
4863   strcat (filename_tmp, "0");
4864
4865   /* There was an error while processing the module.  We delete the
4866      module file, even if it was already there.  */
4867   if (!dump_flag)
4868     {
4869       unlink (filename);
4870       return;
4871     }
4872
4873   /* Write the module to the temporary file.  */
4874   module_fp = fopen (filename_tmp, "w");
4875   if (module_fp == NULL)
4876     gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
4877                      filename_tmp, strerror (errno));
4878
4879   /* Write the header, including space reserved for the MD5 sum.  */
4880   now = time (NULL);
4881   p = ctime (&now);
4882
4883   *strchr (p, '\n') = '\0';
4884
4885   fprintf (module_fp, "GFORTRAN module version '%s' created from %s on %s\n"
4886            "MD5:", MOD_VERSION, gfc_source_file, p);
4887   fgetpos (module_fp, &md5_pos);
4888   fputs ("00000000000000000000000000000000 -- "
4889         "If you edit this, you'll get what you deserve.\n\n", module_fp);
4890
4891   /* Initialize the MD5 context that will be used for output.  */
4892   md5_init_ctx (&ctx);
4893
4894   /* Write the module itself.  */
4895   iomode = IO_OUTPUT;
4896   strcpy (module_name, name);
4897
4898   init_pi_tree ();
4899
4900   write_module ();
4901
4902   free_pi_tree (pi_root);
4903   pi_root = NULL;
4904
4905   write_char ('\n');
4906
4907   /* Write the MD5 sum to the header of the module file.  */
4908   md5_finish_ctx (&ctx, md5_new);
4909   fsetpos (module_fp, &md5_pos);
4910   for (n = 0; n < 16; n++)
4911     fprintf (module_fp, "%02x", md5_new[n]);
4912
4913   if (fclose (module_fp))
4914     gfc_fatal_error ("Error writing module file '%s' for writing: %s",
4915                      filename_tmp, strerror (errno));
4916
4917   /* Read the MD5 from the header of the old module file and compare.  */
4918   if (read_md5_from_module_file (filename, md5_old) != 0
4919       || memcmp (md5_old, md5_new, sizeof (md5_old)) != 0)
4920     {
4921       /* Module file have changed, replace the old one.  */
4922       if (unlink (filename) && errno != ENOENT)
4923         gfc_fatal_error ("Can't delete module file '%s': %s", filename,
4924                          strerror (errno));
4925       if (rename (filename_tmp, filename))
4926         gfc_fatal_error ("Can't rename module file '%s' to '%s': %s",
4927                          filename_tmp, filename, strerror (errno));
4928     }
4929   else
4930     {
4931       if (unlink (filename_tmp))
4932         gfc_fatal_error ("Can't delete temporary module file '%s': %s",
4933                          filename_tmp, strerror (errno));
4934     }
4935 }
4936
4937
4938 static void
4939 sort_iso_c_rename_list (void)
4940 {
4941   gfc_use_rename *tmp_list = NULL;
4942   gfc_use_rename *curr;
4943   gfc_use_rename *kinds_used[ISOCBINDING_NUMBER] = {NULL};
4944   int c_kind;
4945   int i;
4946
4947   for (curr = gfc_rename_list; curr; curr = curr->next)
4948     {
4949       c_kind = get_c_kind (curr->use_name, c_interop_kinds_table);
4950       if (c_kind == ISOCBINDING_INVALID || c_kind == ISOCBINDING_LAST)
4951         {
4952           gfc_error ("Symbol '%s' referenced at %L does not exist in "
4953                      "intrinsic module ISO_C_BINDING.", curr->use_name,
4954                      &curr->where);
4955         }
4956       else
4957         /* Put it in the list.  */
4958         kinds_used[c_kind] = curr;
4959     }
4960
4961   /* Make a new (sorted) rename list.  */
4962   i = 0;
4963   while (i < ISOCBINDING_NUMBER && kinds_used[i] == NULL)
4964     i++;
4965
4966   if (i < ISOCBINDING_NUMBER)
4967     {
4968       tmp_list = kinds_used[i];
4969
4970       i++;
4971       curr = tmp_list;
4972       for (; i < ISOCBINDING_NUMBER; i++)
4973         if (kinds_used[i] != NULL)
4974           {
4975             curr->next = kinds_used[i];
4976             curr = curr->next;
4977             curr->next = NULL;
4978           }
4979     }
4980
4981   gfc_rename_list = tmp_list;
4982 }
4983
4984
4985 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
4986    the current namespace for all named constants, pointer types, and
4987    procedures in the module unless the only clause was used or a rename
4988    list was provided.  */
4989
4990 static void
4991 import_iso_c_binding_module (void)
4992 {
4993   gfc_symbol *mod_sym = NULL;
4994   gfc_symtree *mod_symtree = NULL;
4995   const char *iso_c_module_name = "__iso_c_binding";
4996   gfc_use_rename *u;
4997   int i;
4998   char *local_name;
4999
5000   /* Look only in the current namespace.  */
5001   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
5002
5003   if (mod_symtree == NULL)
5004     {
5005       /* symtree doesn't already exist in current namespace.  */
5006       gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree,
5007                         false);
5008
5009       if (mod_symtree != NULL)
5010         mod_sym = mod_symtree->n.sym;
5011       else
5012         gfc_internal_error ("import_iso_c_binding_module(): Unable to "
5013                             "create symbol for %s", iso_c_module_name);
5014
5015       mod_sym->attr.flavor = FL_MODULE;
5016       mod_sym->attr.intrinsic = 1;
5017       mod_sym->module = gfc_get_string (iso_c_module_name);
5018       mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
5019     }
5020
5021   /* Generate the symbols for the named constants representing
5022      the kinds for intrinsic data types.  */
5023   if (only_flag)
5024     {
5025       /* Sort the rename list because there are dependencies between types
5026          and procedures (e.g., c_loc needs c_ptr).  */
5027       sort_iso_c_rename_list ();
5028
5029       for (u = gfc_rename_list; u; u = u->next)
5030         {
5031           i = get_c_kind (u->use_name, c_interop_kinds_table);
5032
5033           if (i == ISOCBINDING_INVALID || i == ISOCBINDING_LAST)
5034             {
5035               gfc_error ("Symbol '%s' referenced at %L does not exist in "
5036                          "intrinsic module ISO_C_BINDING.", u->use_name,
5037                          &u->where);
5038               continue;
5039             }
5040
5041           generate_isocbinding_symbol (iso_c_module_name,
5042                                        (iso_c_binding_symbol) i,
5043                                        u->local_name);
5044         }
5045     }
5046   else
5047     {
5048       for (i = 0; i < ISOCBINDING_NUMBER; i++)
5049         {
5050           local_name = NULL;
5051           for (u = gfc_rename_list; u; u = u->next)
5052             {
5053               if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
5054                 {
5055                   local_name = u->local_name;
5056                   u->found = 1;
5057                   break;
5058                 }
5059             }
5060           generate_isocbinding_symbol (iso_c_module_name,
5061                                        (iso_c_binding_symbol) i,
5062                                        local_name);
5063         }
5064
5065       for (u = gfc_rename_list; u; u = u->next)
5066         {
5067           if (u->found)
5068             continue;
5069
5070           gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
5071                      "module ISO_C_BINDING", u->use_name, &u->where);
5072         }
5073     }
5074 }
5075
5076
5077 /* Add an integer named constant from a given module.  */
5078
5079 static void
5080 create_int_parameter (const char *name, int value, const char *modname,
5081                       intmod_id module, int id)
5082 {
5083   gfc_symtree *tmp_symtree;
5084   gfc_symbol *sym;
5085
5086   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
5087   if (tmp_symtree != NULL)
5088     {
5089       if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
5090         return;
5091       else
5092         gfc_error ("Symbol '%s' already declared", name);
5093     }
5094
5095   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
5096   sym = tmp_symtree->n.sym;
5097
5098   sym->module = gfc_get_string (modname);
5099   sym->attr.flavor = FL_PARAMETER;
5100   sym->ts.type = BT_INTEGER;
5101   sym->ts.kind = gfc_default_integer_kind;
5102   sym->value = gfc_int_expr (value);
5103   sym->attr.use_assoc = 1;
5104   sym->from_intmod = module;
5105   sym->intmod_sym_id = id;
5106 }
5107
5108
5109 /* USE the ISO_FORTRAN_ENV intrinsic module.  */
5110
5111 static void
5112 use_iso_fortran_env_module (void)
5113 {
5114   static char mod[] = "iso_fortran_env";
5115   const char *local_name;
5116   gfc_use_rename *u;
5117   gfc_symbol *mod_sym;
5118   gfc_symtree *mod_symtree;
5119   int i;
5120
5121   intmod_sym symbol[] = {
5122 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
5123 #include "iso-fortran-env.def"
5124 #undef NAMED_INTCST
5125     { ISOFORTRANENV_INVALID, NULL, -1234, 0 } };
5126
5127   i = 0;
5128 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
5129 #include "iso-fortran-env.def"
5130 #undef NAMED_INTCST
5131
5132   /* Generate the symbol for the module itself.  */
5133   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
5134   if (mod_symtree == NULL)
5135     {
5136       gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree, false);
5137       gcc_assert (mod_symtree);
5138       mod_sym = mod_symtree->n.sym;
5139
5140       mod_sym->attr.flavor = FL_MODULE;
5141       mod_sym->attr.intrinsic = 1;
5142       mod_sym->module = gfc_get_string (mod);
5143       mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
5144     }
5145   else
5146     if (!mod_symtree->n.sym->attr.intrinsic)
5147       gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
5148                  "non-intrinsic module name used previously", mod);
5149
5150   /* Generate the symbols for the module integer named constants.  */
5151   if (only_flag)
5152     for (u = gfc_rename_list; u; u = u->next)
5153       {
5154         for (i = 0; symbol[i].name; i++)
5155           if (strcmp (symbol[i].name, u->use_name) == 0)
5156             break;
5157
5158         if (symbol[i].name == NULL)
5159           {
5160             gfc_error ("Symbol '%s' referenced at %L does not exist in "
5161                        "intrinsic module ISO_FORTRAN_ENV", u->use_name,
5162                        &u->where);
5163             continue;
5164           }
5165
5166         if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
5167             && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
5168           gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
5169                            "from intrinsic module ISO_FORTRAN_ENV at %L is "
5170                            "incompatible with option %s", &u->where,
5171                            gfc_option.flag_default_integer
5172                              ? "-fdefault-integer-8" : "-fdefault-real-8");
5173
5174         create_int_parameter (u->local_name[0] ? u->local_name
5175                                                : symbol[i].name,
5176                               symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
5177                               symbol[i].id);
5178       }
5179   else
5180     {
5181       for (i = 0; symbol[i].name; i++)
5182         {
5183           local_name = NULL;
5184           for (u = gfc_rename_list; u; u = u->next)
5185             {
5186               if (strcmp (symbol[i].name, u->use_name) == 0)
5187                 {
5188                   local_name = u->local_name;
5189                   u->found = 1;
5190                   break;
5191                 }
5192             }
5193
5194           if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
5195               && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
5196             gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
5197                              "from intrinsic module ISO_FORTRAN_ENV at %C is "
5198                              "incompatible with option %s",
5199                              gfc_option.flag_default_integer
5200                                 ? "-fdefault-integer-8" : "-fdefault-real-8");
5201
5202           create_int_parameter (local_name ? local_name : symbol[i].name,
5203                                 symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
5204                                 symbol[i].id);
5205         }
5206
5207       for (u = gfc_rename_list; u; u = u->next)
5208         {
5209           if (u->found)
5210             continue;
5211
5212           gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
5213                      "module ISO_FORTRAN_ENV", u->use_name, &u->where);
5214         }
5215     }
5216 }
5217
5218
5219 /* Process a USE directive.  */
5220
5221 void
5222 gfc_use_module (void)
5223 {
5224   char *filename;
5225   gfc_state_data *p;
5226   int c, line, start;
5227   gfc_symtree *mod_symtree;
5228   gfc_use_list *use_stmt;
5229
5230   filename = (char *) alloca (strlen (module_name) + strlen (MODULE_EXTENSION)
5231                               + 1);
5232   strcpy (filename, module_name);
5233   strcat (filename, MODULE_EXTENSION);
5234
5235   /* First, try to find an non-intrinsic module, unless the USE statement
5236      specified that the module is intrinsic.  */
5237   module_fp = NULL;
5238   if (!specified_int)
5239     module_fp = gfc_open_included_file (filename, true, true);
5240
5241   /* Then, see if it's an intrinsic one, unless the USE statement
5242      specified that the module is non-intrinsic.  */
5243   if (module_fp == NULL && !specified_nonint)
5244     {
5245       if (strcmp (module_name, "iso_fortran_env") == 0
5246           && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ISO_FORTRAN_ENV "
5247                              "intrinsic module at %C") != FAILURE)
5248        {
5249          use_iso_fortran_env_module ();
5250          return;
5251        }
5252
5253       if (strcmp (module_name, "iso_c_binding") == 0
5254           && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
5255                              "ISO_C_BINDING module at %C") != FAILURE)
5256         {
5257           import_iso_c_binding_module();
5258           return;
5259         }
5260
5261       module_fp = gfc_open_intrinsic_module (filename);
5262
5263       if (module_fp == NULL && specified_int)
5264         gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
5265                          module_name);
5266     }
5267
5268   if (module_fp == NULL)
5269     gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
5270                      filename, strerror (errno));
5271
5272   /* Check that we haven't already USEd an intrinsic module with the
5273      same name.  */
5274
5275   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name);
5276   if (mod_symtree && mod_symtree->n.sym->attr.intrinsic)
5277     gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
5278                "intrinsic module name used previously", module_name);
5279
5280   iomode = IO_INPUT;
5281   module_line = 1;
5282   module_column = 1;
5283   start = 0;
5284
5285   /* Skip the first two lines of the module, after checking that this is
5286      a gfortran module file.  */
5287   line = 0;
5288   while (line < 2)
5289     {
5290       c = module_char ();
5291       if (c == EOF)
5292         bad_module ("Unexpected end of module");
5293       if (start++ < 3)
5294         parse_name (c);
5295       if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0)
5296           || (start == 2 && strcmp (atom_name, " module") != 0))
5297         gfc_fatal_error ("File '%s' opened at %C is not a GFORTRAN module "
5298                          "file", filename);
5299       if (start == 3)
5300         {
5301           if (strcmp (atom_name, " version") != 0
5302               || module_char () != ' '
5303               || parse_atom () != ATOM_STRING)
5304             gfc_fatal_error ("Parse error when checking module version"
5305                              " for file '%s' opened at %C", filename);
5306
5307           if (strcmp (atom_string, MOD_VERSION))
5308             {
5309               gfc_fatal_error ("Wrong module version '%s' (expected '"
5310                                MOD_VERSION "') for file '%s' opened"
5311                                " at %C", atom_string, filename);
5312             }
5313         }
5314
5315       if (c == '\n')
5316         line++;
5317     }
5318
5319   /* Make sure we're not reading the same module that we may be building.  */
5320   for (p = gfc_state_stack; p; p = p->previous)
5321     if (p->state == COMP_MODULE && strcmp (p->sym->name, module_name) == 0)
5322       gfc_fatal_error ("Can't USE the same module we're building!");
5323
5324   init_pi_tree ();
5325   init_true_name_tree ();
5326
5327   read_module ();
5328
5329   free_true_name (true_name_root);
5330   true_name_root = NULL;
5331
5332   free_pi_tree (pi_root);
5333   pi_root = NULL;
5334
5335   fclose (module_fp);
5336
5337   use_stmt = gfc_get_use_list ();
5338   use_stmt->module_name = gfc_get_string (module_name);
5339   use_stmt->only_flag = only_flag;
5340   use_stmt->rename = gfc_rename_list;
5341   use_stmt->where = use_locus;
5342   gfc_rename_list = NULL;
5343   use_stmt->next = gfc_current_ns->use_stmts;
5344   gfc_current_ns->use_stmts = use_stmt;
5345 }
5346
5347
5348 void
5349 gfc_free_use_stmts (gfc_use_list *use_stmts)
5350 {
5351   gfc_use_list *next;
5352   for (; use_stmts; use_stmts = next)
5353     {
5354       gfc_use_rename *next_rename;
5355
5356       for (; use_stmts->rename; use_stmts->rename = next_rename)
5357         {
5358           next_rename = use_stmts->rename->next;
5359           gfc_free (use_stmts->rename);
5360         }
5361       next = use_stmts->next;
5362       gfc_free (use_stmts);
5363     }
5364 }
5365
5366
5367 void
5368 gfc_module_init_2 (void)
5369 {
5370   last_atom = ATOM_LPAREN;
5371 }
5372
5373
5374 void
5375 gfc_module_done_2 (void)
5376 {
5377   free_rename ();
5378 }