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