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