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 "5"
  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, AB_CODIMENSION,
1676   AB_COARRAY_COMP
1677 }
1678 ab_attribute;
1679
1680 static const mstring attr_bits[] =
1681 {
1682     minit ("ALLOCATABLE", AB_ALLOCATABLE),
1683     minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS),
1684     minit ("DIMENSION", AB_DIMENSION),
1685     minit ("CODIMENSION", AB_CODIMENSION),
1686     minit ("EXTERNAL", AB_EXTERNAL),
1687     minit ("INTRINSIC", AB_INTRINSIC),
1688     minit ("OPTIONAL", AB_OPTIONAL),
1689     minit ("POINTER", AB_POINTER),
1690     minit ("VOLATILE", AB_VOLATILE),
1691     minit ("TARGET", AB_TARGET),
1692     minit ("THREADPRIVATE", AB_THREADPRIVATE),
1693     minit ("DUMMY", AB_DUMMY),
1694     minit ("RESULT", AB_RESULT),
1695     minit ("DATA", AB_DATA),
1696     minit ("IN_NAMELIST", AB_IN_NAMELIST),
1697     minit ("IN_COMMON", AB_IN_COMMON),
1698     minit ("FUNCTION", AB_FUNCTION),
1699     minit ("SUBROUTINE", AB_SUBROUTINE),
1700     minit ("SEQUENCE", AB_SEQUENCE),
1701     minit ("ELEMENTAL", AB_ELEMENTAL),
1702     minit ("PURE", AB_PURE),
1703     minit ("RECURSIVE", AB_RECURSIVE),
1704     minit ("GENERIC", AB_GENERIC),
1705     minit ("ALWAYS_EXPLICIT", AB_ALWAYS_EXPLICIT),
1706     minit ("CRAY_POINTER", AB_CRAY_POINTER),
1707     minit ("CRAY_POINTEE", AB_CRAY_POINTEE),
1708     minit ("IS_BIND_C", AB_IS_BIND_C),
1709     minit ("IS_C_INTEROP", AB_IS_C_INTEROP),
1710     minit ("IS_ISO_C", AB_IS_ISO_C),
1711     minit ("VALUE", AB_VALUE),
1712     minit ("ALLOC_COMP", AB_ALLOC_COMP),
1713     minit ("COARRAY_COMP", AB_COARRAY_COMP),
1714     minit ("POINTER_COMP", AB_POINTER_COMP),
1715     minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
1716     minit ("ZERO_COMP", AB_ZERO_COMP),
1717     minit ("PROTECTED", AB_PROTECTED),
1718     minit ("ABSTRACT", AB_ABSTRACT),
1719     minit ("IS_CLASS", AB_IS_CLASS),
1720     minit ("PROCEDURE", AB_PROCEDURE),
1721     minit ("PROC_POINTER", AB_PROC_POINTER),
1722     minit (NULL, -1)
1723 };
1724
1725 /* For binding attributes.  */
1726 static const mstring binding_passing[] =
1727 {
1728     minit ("PASS", 0),
1729     minit ("NOPASS", 1),
1730     minit (NULL, -1)
1731 };
1732 static const mstring binding_overriding[] =
1733 {
1734     minit ("OVERRIDABLE", 0),
1735     minit ("NON_OVERRIDABLE", 1),
1736     minit ("DEFERRED", 2),
1737     minit (NULL, -1)
1738 };
1739 static const mstring binding_generic[] =
1740 {
1741     minit ("SPECIFIC", 0),
1742     minit ("GENERIC", 1),
1743     minit (NULL, -1)
1744 };
1745 static const mstring binding_ppc[] =
1746 {
1747     minit ("NO_PPC", 0),
1748     minit ("PPC", 1),
1749     minit (NULL, -1)
1750 };
1751
1752 /* Specialization of mio_name.  */
1753 DECL_MIO_NAME (ab_attribute)
1754 DECL_MIO_NAME (ar_type)
1755 DECL_MIO_NAME (array_type)
1756 DECL_MIO_NAME (bt)
1757 DECL_MIO_NAME (expr_t)
1758 DECL_MIO_NAME (gfc_access)
1759 DECL_MIO_NAME (gfc_intrinsic_op)
1760 DECL_MIO_NAME (ifsrc)
1761 DECL_MIO_NAME (save_state)
1762 DECL_MIO_NAME (procedure_type)
1763 DECL_MIO_NAME (ref_type)
1764 DECL_MIO_NAME (sym_flavor)
1765 DECL_MIO_NAME (sym_intent)
1766 #undef DECL_MIO_NAME
1767
1768 /* Symbol attributes are stored in list with the first three elements
1769    being the enumerated fields, while the remaining elements (if any)
1770    indicate the individual attribute bits.  The access field is not
1771    saved-- it controls what symbols are exported when a module is
1772    written.  */
1773
1774 static void
1775 mio_symbol_attribute (symbol_attribute *attr)
1776 {
1777   atom_type t;
1778   unsigned ext_attr,extension_level;
1779
1780   mio_lparen ();
1781
1782   attr->flavor = MIO_NAME (sym_flavor) (attr->flavor, flavors);
1783   attr->intent = MIO_NAME (sym_intent) (attr->intent, intents);
1784   attr->proc = MIO_NAME (procedure_type) (attr->proc, procedures);
1785   attr->if_source = MIO_NAME (ifsrc) (attr->if_source, ifsrc_types);
1786   attr->save = MIO_NAME (save_state) (attr->save, save_status);
1787
1788   ext_attr = attr->ext_attr;
1789   mio_integer ((int *) &ext_attr);
1790   attr->ext_attr = ext_attr;
1791
1792   extension_level = attr->extension;
1793   mio_integer ((int *) &extension_level);
1794   attr->extension = extension_level;
1795
1796   if (iomode == IO_OUTPUT)
1797     {
1798       if (attr->allocatable)
1799         MIO_NAME (ab_attribute) (AB_ALLOCATABLE, attr_bits);
1800       if (attr->asynchronous)
1801         MIO_NAME (ab_attribute) (AB_ASYNCHRONOUS, attr_bits);
1802       if (attr->dimension)
1803         MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits);
1804       if (attr->codimension)
1805         MIO_NAME (ab_attribute) (AB_CODIMENSION, attr_bits);
1806       if (attr->external)
1807         MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits);
1808       if (attr->intrinsic)
1809         MIO_NAME (ab_attribute) (AB_INTRINSIC, attr_bits);
1810       if (attr->optional)
1811         MIO_NAME (ab_attribute) (AB_OPTIONAL, attr_bits);
1812       if (attr->pointer)
1813         MIO_NAME (ab_attribute) (AB_POINTER, attr_bits);
1814       if (attr->is_protected)
1815         MIO_NAME (ab_attribute) (AB_PROTECTED, attr_bits);
1816       if (attr->value)
1817         MIO_NAME (ab_attribute) (AB_VALUE, attr_bits);
1818       if (attr->volatile_)
1819         MIO_NAME (ab_attribute) (AB_VOLATILE, attr_bits);
1820       if (attr->target)
1821         MIO_NAME (ab_attribute) (AB_TARGET, attr_bits);
1822       if (attr->threadprivate)
1823         MIO_NAME (ab_attribute) (AB_THREADPRIVATE, attr_bits);
1824       if (attr->dummy)
1825         MIO_NAME (ab_attribute) (AB_DUMMY, attr_bits);
1826       if (attr->result)
1827         MIO_NAME (ab_attribute) (AB_RESULT, attr_bits);
1828       /* We deliberately don't preserve the "entry" flag.  */
1829
1830       if (attr->data)
1831         MIO_NAME (ab_attribute) (AB_DATA, attr_bits);
1832       if (attr->in_namelist)
1833         MIO_NAME (ab_attribute) (AB_IN_NAMELIST, attr_bits);
1834       if (attr->in_common)
1835         MIO_NAME (ab_attribute) (AB_IN_COMMON, attr_bits);
1836
1837       if (attr->function)
1838         MIO_NAME (ab_attribute) (AB_FUNCTION, attr_bits);
1839       if (attr->subroutine)
1840         MIO_NAME (ab_attribute) (AB_SUBROUTINE, attr_bits);
1841       if (attr->generic)
1842         MIO_NAME (ab_attribute) (AB_GENERIC, attr_bits);
1843       if (attr->abstract)
1844         MIO_NAME (ab_attribute) (AB_ABSTRACT, attr_bits);
1845
1846       if (attr->sequence)
1847         MIO_NAME (ab_attribute) (AB_SEQUENCE, attr_bits);
1848       if (attr->elemental)
1849         MIO_NAME (ab_attribute) (AB_ELEMENTAL, attr_bits);
1850       if (attr->pure)
1851         MIO_NAME (ab_attribute) (AB_PURE, attr_bits);
1852       if (attr->recursive)
1853         MIO_NAME (ab_attribute) (AB_RECURSIVE, attr_bits);
1854       if (attr->always_explicit)
1855         MIO_NAME (ab_attribute) (AB_ALWAYS_EXPLICIT, attr_bits);
1856       if (attr->cray_pointer)
1857         MIO_NAME (ab_attribute) (AB_CRAY_POINTER, attr_bits);
1858       if (attr->cray_pointee)
1859         MIO_NAME (ab_attribute) (AB_CRAY_POINTEE, attr_bits);
1860       if (attr->is_bind_c)
1861         MIO_NAME(ab_attribute) (AB_IS_BIND_C, attr_bits);
1862       if (attr->is_c_interop)
1863         MIO_NAME(ab_attribute) (AB_IS_C_INTEROP, attr_bits);
1864       if (attr->is_iso_c)
1865         MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits);
1866       if (attr->alloc_comp)
1867         MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
1868       if (attr->pointer_comp)
1869         MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits);
1870       if (attr->private_comp)
1871         MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
1872       if (attr->coarray_comp)
1873         MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits);
1874       if (attr->zero_comp)
1875         MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
1876       if (attr->is_class)
1877         MIO_NAME (ab_attribute) (AB_IS_CLASS, attr_bits);
1878       if (attr->procedure)
1879         MIO_NAME (ab_attribute) (AB_PROCEDURE, attr_bits);
1880       if (attr->proc_pointer)
1881         MIO_NAME (ab_attribute) (AB_PROC_POINTER, attr_bits);
1882
1883       mio_rparen ();
1884
1885     }
1886   else
1887     {
1888       for (;;)
1889         {
1890           t = parse_atom ();
1891           if (t == ATOM_RPAREN)
1892             break;
1893           if (t != ATOM_NAME)
1894             bad_module ("Expected attribute bit name");
1895
1896           switch ((ab_attribute) find_enum (attr_bits))
1897             {
1898             case AB_ALLOCATABLE:
1899               attr->allocatable = 1;
1900               break;
1901             case AB_ASYNCHRONOUS:
1902               attr->asynchronous = 1;
1903               break;
1904             case AB_DIMENSION:
1905               attr->dimension = 1;
1906               break;
1907             case AB_CODIMENSION:
1908               attr->codimension = 1;
1909               break;
1910             case AB_EXTERNAL:
1911               attr->external = 1;
1912               break;
1913             case AB_INTRINSIC:
1914               attr->intrinsic = 1;
1915               break;
1916             case AB_OPTIONAL:
1917               attr->optional = 1;
1918               break;
1919             case AB_POINTER:
1920               attr->pointer = 1;
1921               break;
1922             case AB_PROTECTED:
1923               attr->is_protected = 1;
1924               break;
1925             case AB_VALUE:
1926               attr->value = 1;
1927               break;
1928             case AB_VOLATILE:
1929               attr->volatile_ = 1;
1930               break;
1931             case AB_TARGET:
1932               attr->target = 1;
1933               break;
1934             case AB_THREADPRIVATE:
1935               attr->threadprivate = 1;
1936               break;
1937             case AB_DUMMY:
1938               attr->dummy = 1;
1939               break;
1940             case AB_RESULT:
1941               attr->result = 1;
1942               break;
1943             case AB_DATA:
1944               attr->data = 1;
1945               break;
1946             case AB_IN_NAMELIST:
1947               attr->in_namelist = 1;
1948               break;
1949             case AB_IN_COMMON:
1950               attr->in_common = 1;
1951               break;
1952             case AB_FUNCTION:
1953               attr->function = 1;
1954               break;
1955             case AB_SUBROUTINE:
1956               attr->subroutine = 1;
1957               break;
1958             case AB_GENERIC:
1959               attr->generic = 1;
1960               break;
1961             case AB_ABSTRACT:
1962               attr->abstract = 1;
1963               break;
1964             case AB_SEQUENCE:
1965               attr->sequence = 1;
1966               break;
1967             case AB_ELEMENTAL:
1968               attr->elemental = 1;
1969               break;
1970             case AB_PURE:
1971               attr->pure = 1;
1972               break;
1973             case AB_RECURSIVE:
1974               attr->recursive = 1;
1975               break;
1976             case AB_ALWAYS_EXPLICIT:
1977               attr->always_explicit = 1;
1978               break;
1979             case AB_CRAY_POINTER:
1980               attr->cray_pointer = 1;
1981               break;
1982             case AB_CRAY_POINTEE:
1983               attr->cray_pointee = 1;
1984               break;
1985             case AB_IS_BIND_C:
1986               attr->is_bind_c = 1;
1987               break;
1988             case AB_IS_C_INTEROP:
1989               attr->is_c_interop = 1;
1990               break;
1991             case AB_IS_ISO_C:
1992               attr->is_iso_c = 1;
1993               break;
1994             case AB_ALLOC_COMP:
1995               attr->alloc_comp = 1;
1996               break;
1997             case AB_COARRAY_COMP:
1998               attr->coarray_comp = 1;
1999               break;
2000             case AB_POINTER_COMP:
2001               attr->pointer_comp = 1;
2002               break;
2003             case AB_PRIVATE_COMP:
2004               attr->private_comp = 1;
2005               break;
2006             case AB_ZERO_COMP:
2007               attr->zero_comp = 1;
2008               break;
2009             case AB_IS_CLASS:
2010               attr->is_class = 1;
2011               break;
2012             case AB_PROCEDURE:
2013               attr->procedure = 1;
2014               break;
2015             case AB_PROC_POINTER:
2016               attr->proc_pointer = 1;
2017               break;
2018             }
2019         }
2020     }
2021 }
2022
2023
2024 static const mstring bt_types[] = {
2025     minit ("INTEGER", BT_INTEGER),
2026     minit ("REAL", BT_REAL),
2027     minit ("COMPLEX", BT_COMPLEX),
2028     minit ("LOGICAL", BT_LOGICAL),
2029     minit ("CHARACTER", BT_CHARACTER),
2030     minit ("DERIVED", BT_DERIVED),
2031     minit ("CLASS", BT_CLASS),
2032     minit ("PROCEDURE", BT_PROCEDURE),
2033     minit ("UNKNOWN", BT_UNKNOWN),
2034     minit ("VOID", BT_VOID),
2035     minit (NULL, -1)
2036 };
2037
2038
2039 static void
2040 mio_charlen (gfc_charlen **clp)
2041 {
2042   gfc_charlen *cl;
2043
2044   mio_lparen ();
2045
2046   if (iomode == IO_OUTPUT)
2047     {
2048       cl = *clp;
2049       if (cl != NULL)
2050         mio_expr (&cl->length);
2051     }
2052   else
2053     {
2054       if (peek_atom () != ATOM_RPAREN)
2055         {
2056           cl = gfc_new_charlen (gfc_current_ns, NULL);
2057           mio_expr (&cl->length);
2058           *clp = cl;
2059         }
2060     }
2061
2062   mio_rparen ();
2063 }
2064
2065
2066 /* See if a name is a generated name.  */
2067
2068 static int
2069 check_unique_name (const char *name)
2070 {
2071   return *name == '@';
2072 }
2073
2074
2075 static void
2076 mio_typespec (gfc_typespec *ts)
2077 {
2078   mio_lparen ();
2079
2080   ts->type = MIO_NAME (bt) (ts->type, bt_types);
2081
2082   if (ts->type != BT_DERIVED && ts->type != BT_CLASS)
2083     mio_integer (&ts->kind);
2084   else
2085     mio_symbol_ref (&ts->u.derived);
2086
2087   /* Add info for C interop and is_iso_c.  */
2088   mio_integer (&ts->is_c_interop);
2089   mio_integer (&ts->is_iso_c);
2090
2091   /* If the typespec is for an identifier either from iso_c_binding, or
2092      a constant that was initialized to an identifier from it, use the
2093      f90_type.  Otherwise, use the ts->type, since it shouldn't matter.  */
2094   if (ts->is_iso_c)
2095     ts->f90_type = MIO_NAME (bt) (ts->f90_type, bt_types);
2096   else
2097     ts->f90_type = MIO_NAME (bt) (ts->type, bt_types);
2098
2099   if (ts->type != BT_CHARACTER)
2100     {
2101       /* ts->u.cl is only valid for BT_CHARACTER.  */
2102       mio_lparen ();
2103       mio_rparen ();
2104     }
2105   else
2106     mio_charlen (&ts->u.cl);
2107
2108   mio_rparen ();
2109 }
2110
2111
2112 static const mstring array_spec_types[] = {
2113     minit ("EXPLICIT", AS_EXPLICIT),
2114     minit ("ASSUMED_SHAPE", AS_ASSUMED_SHAPE),
2115     minit ("DEFERRED", AS_DEFERRED),
2116     minit ("ASSUMED_SIZE", AS_ASSUMED_SIZE),
2117     minit (NULL, -1)
2118 };
2119
2120
2121 static void
2122 mio_array_spec (gfc_array_spec **asp)
2123 {
2124   gfc_array_spec *as;
2125   int i;
2126
2127   mio_lparen ();
2128
2129   if (iomode == IO_OUTPUT)
2130     {
2131       if (*asp == NULL)
2132         goto done;
2133       as = *asp;
2134     }
2135   else
2136     {
2137       if (peek_atom () == ATOM_RPAREN)
2138         {
2139           *asp = NULL;
2140           goto done;
2141         }
2142
2143       *asp = as = gfc_get_array_spec ();
2144     }
2145
2146   mio_integer (&as->rank);
2147   mio_integer (&as->corank);
2148   as->type = MIO_NAME (array_type) (as->type, array_spec_types);
2149
2150   for (i = 0; i < as->rank + as->corank; i++)
2151     {
2152       mio_expr (&as->lower[i]);
2153       mio_expr (&as->upper[i]);
2154     }
2155
2156 done:
2157   mio_rparen ();
2158 }
2159
2160
2161 /* Given a pointer to an array reference structure (which lives in a
2162    gfc_ref structure), find the corresponding array specification
2163    structure.  Storing the pointer in the ref structure doesn't quite
2164    work when loading from a module. Generating code for an array
2165    reference also needs more information than just the array spec.  */
2166
2167 static const mstring array_ref_types[] = {
2168     minit ("FULL", AR_FULL),
2169     minit ("ELEMENT", AR_ELEMENT),
2170     minit ("SECTION", AR_SECTION),
2171     minit (NULL, -1)
2172 };
2173
2174
2175 static void
2176 mio_array_ref (gfc_array_ref *ar)
2177 {
2178   int i;
2179
2180   mio_lparen ();
2181   ar->type = MIO_NAME (ar_type) (ar->type, array_ref_types);
2182   mio_integer (&ar->dimen);
2183
2184   switch (ar->type)
2185     {
2186     case AR_FULL:
2187       break;
2188
2189     case AR_ELEMENT:
2190       for (i = 0; i < ar->dimen; i++)
2191         mio_expr (&ar->start[i]);
2192
2193       break;
2194
2195     case AR_SECTION:
2196       for (i = 0; i < ar->dimen; i++)
2197         {
2198           mio_expr (&ar->start[i]);
2199           mio_expr (&ar->end[i]);
2200           mio_expr (&ar->stride[i]);
2201         }
2202
2203       break;
2204
2205     case AR_UNKNOWN:
2206       gfc_internal_error ("mio_array_ref(): Unknown array ref");
2207     }
2208
2209   /* Unfortunately, ar->dimen_type is an anonymous enumerated type so
2210      we can't call mio_integer directly.  Instead loop over each element
2211      and cast it to/from an integer.  */
2212   if (iomode == IO_OUTPUT)
2213     {
2214       for (i = 0; i < ar->dimen; i++)
2215         {
2216           int tmp = (int)ar->dimen_type[i];
2217           write_atom (ATOM_INTEGER, &tmp);
2218         }
2219     }
2220   else
2221     {
2222       for (i = 0; i < ar->dimen; i++)
2223         {
2224           require_atom (ATOM_INTEGER);
2225           ar->dimen_type[i] = (enum gfc_array_ref_dimen_type) atom_int;
2226         }
2227     }
2228
2229   if (iomode == IO_INPUT)
2230     {
2231       ar->where = gfc_current_locus;
2232
2233       for (i = 0; i < ar->dimen; i++)
2234         ar->c_where[i] = gfc_current_locus;
2235     }
2236
2237   mio_rparen ();
2238 }
2239
2240
2241 /* Saves or restores a pointer.  The pointer is converted back and
2242    forth from an integer.  We return the pointer_info pointer so that
2243    the caller can take additional action based on the pointer type.  */
2244
2245 static pointer_info *
2246 mio_pointer_ref (void *gp)
2247 {
2248   pointer_info *p;
2249
2250   if (iomode == IO_OUTPUT)
2251     {
2252       p = get_pointer (*((char **) gp));
2253       write_atom (ATOM_INTEGER, &p->integer);
2254     }
2255   else
2256     {
2257       require_atom (ATOM_INTEGER);
2258       p = add_fixup (atom_int, gp);
2259     }
2260
2261   return p;
2262 }
2263
2264
2265 /* Save and load references to components that occur within
2266    expressions.  We have to describe these references by a number and
2267    by name.  The number is necessary for forward references during
2268    reading, and the name is necessary if the symbol already exists in
2269    the namespace and is not loaded again.  */
2270
2271 static void
2272 mio_component_ref (gfc_component **cp, gfc_symbol *sym)
2273 {
2274   char name[GFC_MAX_SYMBOL_LEN + 1];
2275   gfc_component *q;
2276   pointer_info *p;
2277
2278   p = mio_pointer_ref (cp);
2279   if (p->type == P_UNKNOWN)
2280     p->type = P_COMPONENT;
2281
2282   if (iomode == IO_OUTPUT)
2283     mio_pool_string (&(*cp)->name);
2284   else
2285     {
2286       mio_internal_string (name);
2287
2288       /* It can happen that a component reference can be read before the
2289          associated derived type symbol has been loaded. Return now and
2290          wait for a later iteration of load_needed.  */
2291       if (sym == NULL)
2292         return;
2293
2294       if (sym->components != NULL && p->u.pointer == NULL)
2295         {
2296           /* Symbol already loaded, so search by name.  */
2297           for (q = sym->components; q; q = q->next)
2298             if (strcmp (q->name, name) == 0)
2299               break;
2300
2301           if (q == NULL)
2302             gfc_internal_error ("mio_component_ref(): Component not found");
2303
2304           associate_integer_pointer (p, q);
2305         }
2306
2307       /* Make sure this symbol will eventually be loaded.  */
2308       p = find_pointer2 (sym);
2309       if (p->u.rsym.state == UNUSED)
2310         p->u.rsym.state = NEEDED;
2311     }
2312 }
2313
2314
2315 static void mio_namespace_ref (gfc_namespace **nsp);
2316 static void mio_formal_arglist (gfc_formal_arglist **formal);
2317 static void mio_typebound_proc (gfc_typebound_proc** proc);
2318
2319 static void
2320 mio_component (gfc_component *c)
2321 {
2322   pointer_info *p;
2323   int n;
2324   gfc_formal_arglist *formal;
2325
2326   mio_lparen ();
2327
2328   if (iomode == IO_OUTPUT)
2329     {
2330       p = get_pointer (c);
2331       mio_integer (&p->integer);
2332     }
2333   else
2334     {
2335       mio_integer (&n);
2336       p = get_integer (n);
2337       associate_integer_pointer (p, c);
2338     }
2339
2340   if (p->type == P_UNKNOWN)
2341     p->type = P_COMPONENT;
2342
2343   mio_pool_string (&c->name);
2344   mio_typespec (&c->ts);
2345   mio_array_spec (&c->as);
2346
2347   mio_symbol_attribute (&c->attr);
2348   c->attr.access = MIO_NAME (gfc_access) (c->attr.access, access_types);
2349
2350   mio_expr (&c->initializer);
2351
2352   if (c->attr.proc_pointer)
2353     {
2354       if (iomode == IO_OUTPUT)
2355         {
2356           formal = c->formal;
2357           while (formal && !formal->sym)
2358             formal = formal->next;
2359
2360           if (formal)
2361             mio_namespace_ref (&formal->sym->ns);
2362           else
2363             mio_namespace_ref (&c->formal_ns);
2364         }
2365       else
2366         {
2367           mio_namespace_ref (&c->formal_ns);
2368           /* TODO: if (c->formal_ns)
2369             {
2370               c->formal_ns->proc_name = c;
2371               c->refs++;
2372             }*/
2373         }
2374
2375       mio_formal_arglist (&c->formal);
2376
2377       mio_typebound_proc (&c->tb);
2378     }
2379
2380   mio_rparen ();
2381 }
2382
2383
2384 static void
2385 mio_component_list (gfc_component **cp)
2386 {
2387   gfc_component *c, *tail;
2388
2389   mio_lparen ();
2390
2391   if (iomode == IO_OUTPUT)
2392     {
2393       for (c = *cp; c; c = c->next)
2394         mio_component (c);
2395     }
2396   else
2397     {
2398       *cp = NULL;
2399       tail = NULL;
2400
2401       for (;;)
2402         {
2403           if (peek_atom () == ATOM_RPAREN)
2404             break;
2405
2406           c = gfc_get_component ();
2407           mio_component (c);
2408
2409           if (tail == NULL)
2410             *cp = c;
2411           else
2412             tail->next = c;
2413
2414           tail = c;
2415         }
2416     }
2417
2418   mio_rparen ();
2419 }
2420
2421
2422 static void
2423 mio_actual_arg (gfc_actual_arglist *a)
2424 {
2425   mio_lparen ();
2426   mio_pool_string (&a->name);
2427   mio_expr (&a->expr);
2428   mio_rparen ();
2429 }
2430
2431
2432 static void
2433 mio_actual_arglist (gfc_actual_arglist **ap)
2434 {
2435   gfc_actual_arglist *a, *tail;
2436
2437   mio_lparen ();
2438
2439   if (iomode == IO_OUTPUT)
2440     {
2441       for (a = *ap; a; a = a->next)
2442         mio_actual_arg (a);
2443
2444     }
2445   else
2446     {
2447       tail = NULL;
2448
2449       for (;;)
2450         {
2451           if (peek_atom () != ATOM_LPAREN)
2452             break;
2453
2454           a = gfc_get_actual_arglist ();
2455
2456           if (tail == NULL)
2457             *ap = a;
2458           else
2459             tail->next = a;
2460
2461           tail = a;
2462           mio_actual_arg (a);
2463         }
2464     }
2465
2466   mio_rparen ();
2467 }
2468
2469
2470 /* Read and write formal argument lists.  */
2471
2472 static void
2473 mio_formal_arglist (gfc_formal_arglist **formal)
2474 {
2475   gfc_formal_arglist *f, *tail;
2476
2477   mio_lparen ();
2478
2479   if (iomode == IO_OUTPUT)
2480     {
2481       for (f = *formal; f; f = f->next)
2482         mio_symbol_ref (&f->sym);
2483     }
2484   else
2485     {
2486       *formal = tail = NULL;
2487
2488       while (peek_atom () != ATOM_RPAREN)
2489         {
2490           f = gfc_get_formal_arglist ();
2491           mio_symbol_ref (&f->sym);
2492
2493           if (*formal == NULL)
2494             *formal = f;
2495           else
2496             tail->next = f;
2497
2498           tail = f;
2499         }
2500     }
2501
2502   mio_rparen ();
2503 }
2504
2505
2506 /* Save or restore a reference to a symbol node.  */
2507
2508 pointer_info *
2509 mio_symbol_ref (gfc_symbol **symp)
2510 {
2511   pointer_info *p;
2512
2513   p = mio_pointer_ref (symp);
2514   if (p->type == P_UNKNOWN)
2515     p->type = P_SYMBOL;
2516
2517   if (iomode == IO_OUTPUT)
2518     {
2519       if (p->u.wsym.state == UNREFERENCED)
2520         p->u.wsym.state = NEEDS_WRITE;
2521     }
2522   else
2523     {
2524       if (p->u.rsym.state == UNUSED)
2525         p->u.rsym.state = NEEDED;
2526     }
2527   return p;
2528 }
2529
2530
2531 /* Save or restore a reference to a symtree node.  */
2532
2533 static void
2534 mio_symtree_ref (gfc_symtree **stp)
2535 {
2536   pointer_info *p;
2537   fixup_t *f;
2538
2539   if (iomode == IO_OUTPUT)
2540     mio_symbol_ref (&(*stp)->n.sym);
2541   else
2542     {
2543       require_atom (ATOM_INTEGER);
2544       p = get_integer (atom_int);
2545
2546       /* An unused equivalence member; make a symbol and a symtree
2547          for it.  */
2548       if (in_load_equiv && p->u.rsym.symtree == NULL)
2549         {
2550           /* Since this is not used, it must have a unique name.  */
2551           p->u.rsym.symtree = gfc_get_unique_symtree (gfc_current_ns);
2552
2553           /* Make the symbol.  */
2554           if (p->u.rsym.sym == NULL)
2555             {
2556               p->u.rsym.sym = gfc_new_symbol (p->u.rsym.true_name,
2557                                               gfc_current_ns);
2558               p->u.rsym.sym->module = gfc_get_string (p->u.rsym.module);
2559             }
2560
2561           p->u.rsym.symtree->n.sym = p->u.rsym.sym;
2562           p->u.rsym.symtree->n.sym->refs++;
2563           p->u.rsym.referenced = 1;
2564
2565           /* If the symbol is PRIVATE and in COMMON, load_commons will
2566              generate a fixup symbol, which must be associated.  */
2567           if (p->fixup)
2568             resolve_fixups (p->fixup, p->u.rsym.sym);
2569           p->fixup = NULL;
2570         }
2571
2572       if (p->type == P_UNKNOWN)
2573         p->type = P_SYMBOL;
2574
2575       if (p->u.rsym.state == UNUSED)
2576         p->u.rsym.state = NEEDED;
2577
2578       if (p->u.rsym.symtree != NULL)
2579         {
2580           *stp = p->u.rsym.symtree;
2581         }
2582       else
2583         {
2584           f = XCNEW (fixup_t);
2585
2586           f->next = p->u.rsym.stfixup;
2587           p->u.rsym.stfixup = f;
2588
2589           f->pointer = (void **) stp;
2590         }
2591     }
2592 }
2593
2594
2595 static void
2596 mio_iterator (gfc_iterator **ip)
2597 {
2598   gfc_iterator *iter;
2599
2600   mio_lparen ();
2601
2602   if (iomode == IO_OUTPUT)
2603     {
2604       if (*ip == NULL)
2605         goto done;
2606     }
2607   else
2608     {
2609       if (peek_atom () == ATOM_RPAREN)
2610         {
2611           *ip = NULL;
2612           goto done;
2613         }
2614
2615       *ip = gfc_get_iterator ();
2616     }
2617
2618   iter = *ip;
2619
2620   mio_expr (&iter->var);
2621   mio_expr (&iter->start);
2622   mio_expr (&iter->end);
2623   mio_expr (&iter->step);
2624
2625 done:
2626   mio_rparen ();
2627 }
2628
2629
2630 static void
2631 mio_constructor (gfc_constructor **cp)
2632 {
2633   gfc_constructor *c, *tail;
2634
2635   mio_lparen ();
2636
2637   if (iomode == IO_OUTPUT)
2638     {
2639       for (c = *cp; c; c = c->next)
2640         {
2641           mio_lparen ();
2642           mio_expr (&c->expr);
2643           mio_iterator (&c->iterator);
2644           mio_rparen ();
2645         }
2646     }
2647   else
2648     {
2649       *cp = NULL;
2650       tail = NULL;
2651
2652       while (peek_atom () != ATOM_RPAREN)
2653         {
2654           c = gfc_get_constructor ();
2655
2656           if (tail == NULL)
2657             *cp = c;
2658           else
2659             tail->next = c;
2660
2661           tail = c;
2662
2663           mio_lparen ();
2664           mio_expr (&c->expr);
2665           mio_iterator (&c->iterator);
2666           mio_rparen ();
2667         }
2668     }
2669
2670   mio_rparen ();
2671 }
2672
2673
2674 static const mstring ref_types[] = {
2675     minit ("ARRAY", REF_ARRAY),
2676     minit ("COMPONENT", REF_COMPONENT),
2677     minit ("SUBSTRING", REF_SUBSTRING),
2678     minit (NULL, -1)
2679 };
2680
2681
2682 static void
2683 mio_ref (gfc_ref **rp)
2684 {
2685   gfc_ref *r;
2686
2687   mio_lparen ();
2688
2689   r = *rp;
2690   r->type = MIO_NAME (ref_type) (r->type, ref_types);
2691
2692   switch (r->type)
2693     {
2694     case REF_ARRAY:
2695       mio_array_ref (&r->u.ar);
2696       break;
2697
2698     case REF_COMPONENT:
2699       mio_symbol_ref (&r->u.c.sym);
2700       mio_component_ref (&r->u.c.component, r->u.c.sym);
2701       break;
2702
2703     case REF_SUBSTRING:
2704       mio_expr (&r->u.ss.start);
2705       mio_expr (&r->u.ss.end);
2706       mio_charlen (&r->u.ss.length);
2707       break;
2708     }
2709
2710   mio_rparen ();
2711 }
2712
2713
2714 static void
2715 mio_ref_list (gfc_ref **rp)
2716 {
2717   gfc_ref *ref, *head, *tail;
2718
2719   mio_lparen ();
2720
2721   if (iomode == IO_OUTPUT)
2722     {
2723       for (ref = *rp; ref; ref = ref->next)
2724         mio_ref (&ref);
2725     }
2726   else
2727     {
2728       head = tail = NULL;
2729
2730       while (peek_atom () != ATOM_RPAREN)
2731         {
2732           if (head == NULL)
2733             head = tail = gfc_get_ref ();
2734           else
2735             {
2736               tail->next = gfc_get_ref ();
2737               tail = tail->next;
2738             }
2739
2740           mio_ref (&tail);
2741         }
2742
2743       *rp = head;
2744     }
2745
2746   mio_rparen ();
2747 }
2748
2749
2750 /* Read and write an integer value.  */
2751
2752 static void
2753 mio_gmp_integer (mpz_t *integer)
2754 {
2755   char *p;
2756
2757   if (iomode == IO_INPUT)
2758     {
2759       if (parse_atom () != ATOM_STRING)
2760         bad_module ("Expected integer string");
2761
2762       mpz_init (*integer);
2763       if (mpz_set_str (*integer, atom_string, 10))
2764         bad_module ("Error converting integer");
2765
2766       gfc_free (atom_string);
2767     }
2768   else
2769     {
2770       p = mpz_get_str (NULL, 10, *integer);
2771       write_atom (ATOM_STRING, p);
2772       gfc_free (p);
2773     }
2774 }
2775
2776
2777 static void
2778 mio_gmp_real (mpfr_t *real)
2779 {
2780   mp_exp_t exponent;
2781   char *p;
2782
2783   if (iomode == IO_INPUT)
2784     {
2785       if (parse_atom () != ATOM_STRING)
2786         bad_module ("Expected real string");
2787
2788       mpfr_init (*real);
2789       mpfr_set_str (*real, atom_string, 16, GFC_RND_MODE);
2790       gfc_free (atom_string);
2791     }
2792   else
2793     {
2794       p = mpfr_get_str (NULL, &exponent, 16, 0, *real, GFC_RND_MODE);
2795
2796       if (mpfr_nan_p (*real) || mpfr_inf_p (*real))
2797         {
2798           write_atom (ATOM_STRING, p);
2799           gfc_free (p);
2800           return;
2801         }
2802
2803       atom_string = XCNEWVEC (char, strlen (p) + 20);
2804
2805       sprintf (atom_string, "0.%s@%ld", p, exponent);
2806
2807       /* Fix negative numbers.  */
2808       if (atom_string[2] == '-')
2809         {
2810           atom_string[0] = '-';
2811           atom_string[1] = '0';
2812           atom_string[2] = '.';
2813         }
2814
2815       write_atom (ATOM_STRING, atom_string);
2816
2817       gfc_free (atom_string);
2818       gfc_free (p);
2819     }
2820 }
2821
2822
2823 /* Save and restore the shape of an array constructor.  */
2824
2825 static void
2826 mio_shape (mpz_t **pshape, int rank)
2827 {
2828   mpz_t *shape;
2829   atom_type t;
2830   int n;
2831
2832   /* A NULL shape is represented by ().  */
2833   mio_lparen ();
2834
2835   if (iomode == IO_OUTPUT)
2836     {
2837       shape = *pshape;
2838       if (!shape)
2839         {
2840           mio_rparen ();
2841           return;
2842         }
2843     }
2844   else
2845     {
2846       t = peek_atom ();
2847       if (t == ATOM_RPAREN)
2848         {
2849           *pshape = NULL;
2850           mio_rparen ();
2851           return;
2852         }
2853
2854       shape = gfc_get_shape (rank);
2855       *pshape = shape;
2856     }
2857
2858   for (n = 0; n < rank; n++)
2859     mio_gmp_integer (&shape[n]);
2860
2861   mio_rparen ();
2862 }
2863
2864
2865 static const mstring expr_types[] = {
2866     minit ("OP", EXPR_OP),
2867     minit ("FUNCTION", EXPR_FUNCTION),
2868     minit ("CONSTANT", EXPR_CONSTANT),
2869     minit ("VARIABLE", EXPR_VARIABLE),
2870     minit ("SUBSTRING", EXPR_SUBSTRING),
2871     minit ("STRUCTURE", EXPR_STRUCTURE),
2872     minit ("ARRAY", EXPR_ARRAY),
2873     minit ("NULL", EXPR_NULL),
2874     minit ("COMPCALL", EXPR_COMPCALL),
2875     minit (NULL, -1)
2876 };
2877
2878 /* INTRINSIC_ASSIGN is missing because it is used as an index for
2879    generic operators, not in expressions.  INTRINSIC_USER is also
2880    replaced by the correct function name by the time we see it.  */
2881
2882 static const mstring intrinsics[] =
2883 {
2884     minit ("UPLUS", INTRINSIC_UPLUS),
2885     minit ("UMINUS", INTRINSIC_UMINUS),
2886     minit ("PLUS", INTRINSIC_PLUS),
2887     minit ("MINUS", INTRINSIC_MINUS),
2888     minit ("TIMES", INTRINSIC_TIMES),
2889     minit ("DIVIDE", INTRINSIC_DIVIDE),
2890     minit ("POWER", INTRINSIC_POWER),
2891     minit ("CONCAT", INTRINSIC_CONCAT),
2892     minit ("AND", INTRINSIC_AND),
2893     minit ("OR", INTRINSIC_OR),
2894     minit ("EQV", INTRINSIC_EQV),
2895     minit ("NEQV", INTRINSIC_NEQV),
2896     minit ("EQ_SIGN", INTRINSIC_EQ),
2897     minit ("EQ", INTRINSIC_EQ_OS),
2898     minit ("NE_SIGN", INTRINSIC_NE),
2899     minit ("NE", INTRINSIC_NE_OS),
2900     minit ("GT_SIGN", INTRINSIC_GT),
2901     minit ("GT", INTRINSIC_GT_OS),
2902     minit ("GE_SIGN", INTRINSIC_GE),
2903     minit ("GE", INTRINSIC_GE_OS),
2904     minit ("LT_SIGN", INTRINSIC_LT),
2905     minit ("LT", INTRINSIC_LT_OS),
2906     minit ("LE_SIGN", INTRINSIC_LE),
2907     minit ("LE", INTRINSIC_LE_OS),
2908     minit ("NOT", INTRINSIC_NOT),
2909     minit ("PARENTHESES", INTRINSIC_PARENTHESES),
2910     minit (NULL, -1)
2911 };
2912
2913
2914 /* Remedy a couple of situations where the gfc_expr's can be defective.  */
2915
2916 static void
2917 fix_mio_expr (gfc_expr *e)
2918 {
2919   gfc_symtree *ns_st = NULL;
2920   const char *fname;
2921
2922   if (iomode != IO_OUTPUT)
2923     return;
2924
2925   if (e->symtree)
2926     {
2927       /* If this is a symtree for a symbol that came from a contained module
2928          namespace, it has a unique name and we should look in the current
2929          namespace to see if the required, non-contained symbol is available
2930          yet. If so, the latter should be written.  */
2931       if (e->symtree->n.sym && check_unique_name (e->symtree->name))
2932         ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
2933                                   e->symtree->n.sym->name);
2934
2935       /* On the other hand, if the existing symbol is the module name or the
2936          new symbol is a dummy argument, do not do the promotion.  */
2937       if (ns_st && ns_st->n.sym
2938           && ns_st->n.sym->attr.flavor != FL_MODULE
2939           && !e->symtree->n.sym->attr.dummy)
2940         e->symtree = ns_st;
2941     }
2942   else if (e->expr_type == EXPR_FUNCTION && e->value.function.name)
2943     {
2944       gfc_symbol *sym;
2945
2946       /* In some circumstances, a function used in an initialization
2947          expression, in one use associated module, can fail to be
2948          coupled to its symtree when used in a specification
2949          expression in another module.  */
2950       fname = e->value.function.esym ? e->value.function.esym->name
2951                                      : e->value.function.isym->name;
2952       e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
2953
2954       if (e->symtree)
2955         return;
2956
2957       /* This is probably a reference to a private procedure from another
2958          module.  To prevent a segfault, make a generic with no specific
2959          instances.  If this module is used, without the required
2960          specific coming from somewhere, the appropriate error message
2961          is issued.  */
2962       gfc_get_symbol (fname, gfc_current_ns, &sym);
2963       sym->attr.flavor = FL_PROCEDURE;
2964       sym->attr.generic = 1;
2965       e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
2966     }
2967 }
2968
2969
2970 /* Read and write expressions.  The form "()" is allowed to indicate a
2971    NULL expression.  */
2972
2973 static void
2974 mio_expr (gfc_expr **ep)
2975 {
2976   gfc_expr *e;
2977   atom_type t;
2978   int flag;
2979
2980   mio_lparen ();
2981
2982   if (iomode == IO_OUTPUT)
2983     {
2984       if (*ep == NULL)
2985         {
2986           mio_rparen ();
2987           return;
2988         }
2989
2990       e = *ep;
2991       MIO_NAME (expr_t) (e->expr_type, expr_types);
2992     }
2993   else
2994     {
2995       t = parse_atom ();
2996       if (t == ATOM_RPAREN)
2997         {
2998           *ep = NULL;
2999           return;
3000         }
3001
3002       if (t != ATOM_NAME)
3003         bad_module ("Expected expression type");
3004
3005       e = *ep = gfc_get_expr ();
3006       e->where = gfc_current_locus;
3007       e->expr_type = (expr_t) find_enum (expr_types);
3008     }
3009
3010   mio_typespec (&e->ts);
3011   mio_integer (&e->rank);
3012
3013   fix_mio_expr (e);
3014
3015   switch (e->expr_type)
3016     {
3017     case EXPR_OP:
3018       e->value.op.op
3019         = MIO_NAME (gfc_intrinsic_op) (e->value.op.op, intrinsics);
3020
3021       switch (e->value.op.op)
3022         {
3023         case INTRINSIC_UPLUS:
3024         case INTRINSIC_UMINUS:
3025         case INTRINSIC_NOT:
3026         case INTRINSIC_PARENTHESES:
3027           mio_expr (&e->value.op.op1);
3028           break;
3029
3030         case INTRINSIC_PLUS:
3031         case INTRINSIC_MINUS:
3032         case INTRINSIC_TIMES:
3033         case INTRINSIC_DIVIDE:
3034         case INTRINSIC_POWER:
3035         case INTRINSIC_CONCAT:
3036         case INTRINSIC_AND:
3037         case INTRINSIC_OR:
3038         case INTRINSIC_EQV:
3039         case INTRINSIC_NEQV:
3040         case INTRINSIC_EQ:
3041         case INTRINSIC_EQ_OS:
3042         case INTRINSIC_NE:
3043         case INTRINSIC_NE_OS:
3044         case INTRINSIC_GT:
3045         case INTRINSIC_GT_OS:
3046         case INTRINSIC_GE:
3047         case INTRINSIC_GE_OS:
3048         case INTRINSIC_LT:
3049         case INTRINSIC_LT_OS:
3050         case INTRINSIC_LE:
3051         case INTRINSIC_LE_OS:
3052           mio_expr (&e->value.op.op1);
3053           mio_expr (&e->value.op.op2);
3054           break;
3055
3056         default:
3057           bad_module ("Bad operator");
3058         }
3059
3060       break;
3061
3062     case EXPR_FUNCTION:
3063       mio_symtree_ref (&e->symtree);
3064       mio_actual_arglist (&e->value.function.actual);
3065
3066       if (iomode == IO_OUTPUT)
3067         {
3068           e->value.function.name
3069             = mio_allocated_string (e->value.function.name);
3070           flag = e->value.function.esym != NULL;
3071           mio_integer (&flag);
3072           if (flag)
3073             mio_symbol_ref (&e->value.function.esym);
3074           else
3075             write_atom (ATOM_STRING, e->value.function.isym->name);
3076         }
3077       else
3078         {
3079           require_atom (ATOM_STRING);
3080           e->value.function.name = gfc_get_string (atom_string);
3081           gfc_free (atom_string);
3082
3083           mio_integer (&flag);
3084           if (flag)
3085             mio_symbol_ref (&e->value.function.esym);
3086           else
3087             {
3088               require_atom (ATOM_STRING);
3089               e->value.function.isym = gfc_find_function (atom_string);
3090               gfc_free (atom_string);
3091             }
3092         }
3093
3094       break;
3095
3096     case EXPR_VARIABLE:
3097       mio_symtree_ref (&e->symtree);
3098       mio_ref_list (&e->ref);
3099       break;
3100
3101     case EXPR_SUBSTRING:
3102       e->value.character.string
3103         = CONST_CAST (gfc_char_t *,
3104                       mio_allocated_wide_string (e->value.character.string,
3105                                                  e->value.character.length));
3106       mio_ref_list (&e->ref);
3107       break;
3108
3109     case EXPR_STRUCTURE:
3110     case EXPR_ARRAY:
3111       mio_constructor (&e->value.constructor);
3112       mio_shape (&e->shape, e->rank);
3113       break;
3114
3115     case EXPR_CONSTANT:
3116       switch (e->ts.type)
3117         {
3118         case BT_INTEGER:
3119           mio_gmp_integer (&e->value.integer);
3120           break;
3121
3122         case BT_REAL:
3123           gfc_set_model_kind (e->ts.kind);
3124           mio_gmp_real (&e->value.real);
3125           break;
3126
3127         case BT_COMPLEX:
3128           gfc_set_model_kind (e->ts.kind);
3129           mio_gmp_real (&mpc_realref (e->value.complex));
3130           mio_gmp_real (&mpc_imagref (e->value.complex));
3131           break;
3132
3133         case BT_LOGICAL:
3134           mio_integer (&e->value.logical);
3135           break;
3136
3137         case BT_CHARACTER:
3138           mio_integer (&e->value.character.length);
3139           e->value.character.string
3140             = CONST_CAST (gfc_char_t *,
3141                           mio_allocated_wide_string (e->value.character.string,
3142                                                      e->value.character.length));
3143           break;
3144
3145         default:
3146           bad_module ("Bad type in constant expression");
3147         }
3148
3149       break;
3150
3151     case EXPR_NULL:
3152       break;
3153
3154     case EXPR_COMPCALL:
3155     case EXPR_PPC:
3156       gcc_unreachable ();
3157       break;
3158     }
3159
3160   mio_rparen ();
3161 }
3162
3163
3164 /* Read and write namelists.  */
3165
3166 static void
3167 mio_namelist (gfc_symbol *sym)
3168 {
3169   gfc_namelist *n, *m;
3170   const char *check_name;
3171
3172   mio_lparen ();
3173
3174   if (iomode == IO_OUTPUT)
3175     {
3176       for (n = sym->namelist; n; n = n->next)
3177         mio_symbol_ref (&n->sym);
3178     }
3179   else
3180     {
3181       /* This departure from the standard is flagged as an error.
3182          It does, in fact, work correctly. TODO: Allow it
3183          conditionally?  */
3184       if (sym->attr.flavor == FL_NAMELIST)
3185         {
3186           check_name = find_use_name (sym->name, false);
3187           if (check_name && strcmp (check_name, sym->name) != 0)
3188             gfc_error ("Namelist %s cannot be renamed by USE "
3189                        "association to %s", sym->name, check_name);
3190         }
3191
3192       m = NULL;
3193       while (peek_atom () != ATOM_RPAREN)
3194         {
3195           n = gfc_get_namelist ();
3196           mio_symbol_ref (&n->sym);
3197
3198           if (sym->namelist == NULL)
3199             sym->namelist = n;
3200           else
3201             m->next = n;
3202
3203           m = n;
3204         }
3205       sym->namelist_tail = m;
3206     }
3207
3208   mio_rparen ();
3209 }
3210
3211
3212 /* Save/restore lists of gfc_interface structures.  When loading an
3213    interface, we are really appending to the existing list of
3214    interfaces.  Checking for duplicate and ambiguous interfaces has to
3215    be done later when all symbols have been loaded.  */
3216
3217 pointer_info *
3218 mio_interface_rest (gfc_interface **ip)
3219 {
3220   gfc_interface *tail, *p;
3221   pointer_info *pi = NULL;
3222
3223   if (iomode == IO_OUTPUT)
3224     {
3225       if (ip != NULL)
3226         for (p = *ip; p; p = p->next)
3227           mio_symbol_ref (&p->sym);
3228     }
3229   else
3230     {
3231       if (*ip == NULL)
3232         tail = NULL;
3233       else
3234         {
3235           tail = *ip;
3236           while (tail->next)
3237             tail = tail->next;
3238         }
3239
3240       for (;;)
3241         {
3242           if (peek_atom () == ATOM_RPAREN)
3243             break;
3244
3245           p = gfc_get_interface ();
3246           p->where = gfc_current_locus;
3247           pi = mio_symbol_ref (&p->sym);
3248
3249           if (tail == NULL)
3250             *ip = p;
3251           else
3252             tail->next = p;
3253
3254           tail = p;
3255         }
3256     }
3257
3258   mio_rparen ();
3259   return pi;
3260 }
3261
3262
3263 /* Save/restore a nameless operator interface.  */
3264
3265 static void
3266 mio_interface (gfc_interface **ip)
3267 {
3268   mio_lparen ();
3269   mio_interface_rest (ip);
3270 }
3271
3272
3273 /* Save/restore a named operator interface.  */
3274
3275 static void
3276 mio_symbol_interface (const char **name, const char **module,
3277                       gfc_interface **ip)
3278 {
3279   mio_lparen ();
3280   mio_pool_string (name);
3281   mio_pool_string (module);
3282   mio_interface_rest (ip);
3283 }
3284
3285
3286 static void
3287 mio_namespace_ref (gfc_namespace **nsp)
3288 {
3289   gfc_namespace *ns;
3290   pointer_info *p;
3291
3292   p = mio_pointer_ref (nsp);
3293
3294   if (p->type == P_UNKNOWN)
3295     p->type = P_NAMESPACE;
3296
3297   if (iomode == IO_INPUT && p->integer != 0)
3298     {
3299       ns = (gfc_namespace *) p->u.pointer;
3300       if (ns == NULL)
3301         {
3302           ns = gfc_get_namespace (NULL, 0);
3303           associate_integer_pointer (p, ns);
3304         }
3305       else
3306         ns->refs++;
3307     }
3308 }
3309
3310
3311 /* Save/restore the f2k_derived namespace of a derived-type symbol.  */
3312
3313 static gfc_namespace* current_f2k_derived;
3314
3315 static void
3316 mio_typebound_proc (gfc_typebound_proc** proc)
3317 {
3318   int flag;
3319   int overriding_flag;
3320
3321   if (iomode == IO_INPUT)
3322     {
3323       *proc = gfc_get_typebound_proc ();
3324       (*proc)->where = gfc_current_locus;
3325     }
3326   gcc_assert (*proc);
3327
3328   mio_lparen ();
3329
3330   (*proc)->access = MIO_NAME (gfc_access) ((*proc)->access, access_types);
3331
3332   /* IO the NON_OVERRIDABLE/DEFERRED combination.  */
3333   gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
3334   overriding_flag = ((*proc)->deferred << 1) | (*proc)->non_overridable;
3335   overriding_flag = mio_name (overriding_flag, binding_overriding);
3336   (*proc)->deferred = ((overriding_flag & 2) != 0);
3337   (*proc)->non_overridable = ((overriding_flag & 1) != 0);
3338   gcc_assert (!((*proc)->deferred && (*proc)->non_overridable));
3339
3340   (*proc)->nopass = mio_name ((*proc)->nopass, binding_passing);
3341   (*proc)->is_generic = mio_name ((*proc)->is_generic, binding_generic);
3342   (*proc)->ppc = mio_name((*proc)->ppc, binding_ppc);
3343
3344   mio_pool_string (&((*proc)->pass_arg));
3345
3346   flag = (int) (*proc)->pass_arg_num;
3347   mio_integer (&flag);
3348   (*proc)->pass_arg_num = (unsigned) flag;
3349
3350   if ((*proc)->is_generic)
3351     {
3352       gfc_tbp_generic* g;
3353
3354       mio_lparen ();
3355
3356       if (iomode == IO_OUTPUT)
3357         for (g = (*proc)->u.generic; g; g = g->next)
3358           mio_allocated_string (g->specific_st->name);
3359       else
3360         {
3361           (*proc)->u.generic = NULL;
3362           while (peek_atom () != ATOM_RPAREN)
3363             {
3364               gfc_symtree** sym_root;
3365
3366               g = gfc_get_tbp_generic ();
3367               g->specific = NULL;
3368
3369               require_atom (ATOM_STRING);
3370               sym_root = &current_f2k_derived->tb_sym_root;
3371               g->specific_st = gfc_get_tbp_symtree (sym_root, atom_string);
3372               gfc_free (atom_string);
3373
3374               g->next = (*proc)->u.generic;
3375               (*proc)->u.generic = g;
3376             }
3377         }
3378
3379       mio_rparen ();
3380     }
3381   else if (!(*proc)->ppc)
3382     mio_symtree_ref (&(*proc)->u.specific);
3383
3384   mio_rparen ();
3385 }
3386
3387 /* Walker-callback function for this purpose.  */
3388 static void
3389 mio_typebound_symtree (gfc_symtree* st)
3390 {
3391   if (iomode == IO_OUTPUT && !st->n.tb)
3392     return;
3393
3394   if (iomode == IO_OUTPUT)
3395     {
3396       mio_lparen ();
3397       mio_allocated_string (st->name);
3398     }
3399   /* For IO_INPUT, the above is done in mio_f2k_derived.  */
3400
3401   mio_typebound_proc (&st->n.tb);
3402   mio_rparen ();
3403 }
3404
3405 /* IO a full symtree (in all depth).  */
3406 static void
3407 mio_full_typebound_tree (gfc_symtree** root)
3408 {
3409   mio_lparen ();
3410
3411   if (iomode == IO_OUTPUT)
3412     gfc_traverse_symtree (*root, &mio_typebound_symtree);
3413   else
3414     {
3415       while (peek_atom () == ATOM_LPAREN)
3416         {
3417           gfc_symtree* st;
3418
3419           mio_lparen ();
3420
3421           require_atom (ATOM_STRING);
3422           st = gfc_get_tbp_symtree (root, atom_string);
3423           gfc_free (atom_string);
3424
3425           mio_typebound_symtree (st);
3426         }
3427     }
3428
3429   mio_rparen ();
3430 }
3431
3432 static void
3433 mio_finalizer (gfc_finalizer **f)
3434 {
3435   if (iomode == IO_OUTPUT)
3436     {
3437       gcc_assert (*f);
3438       gcc_assert ((*f)->proc_tree); /* Should already be resolved.  */
3439       mio_symtree_ref (&(*f)->proc_tree);
3440     }
3441   else
3442     {
3443       *f = gfc_get_finalizer ();
3444       (*f)->where = gfc_current_locus; /* Value should not matter.  */
3445       (*f)->next = NULL;
3446
3447       mio_symtree_ref (&(*f)->proc_tree);
3448       (*f)->proc_sym = NULL;
3449     }
3450 }
3451
3452 static void
3453 mio_f2k_derived (gfc_namespace *f2k)
3454 {
3455   current_f2k_derived = f2k;
3456
3457   /* Handle the list of finalizer procedures.  */
3458   mio_lparen ();
3459   if (iomode == IO_OUTPUT)
3460     {
3461       gfc_finalizer *f;
3462       for (f = f2k->finalizers; f; f = f->next)
3463         mio_finalizer (&f);
3464     }
3465   else
3466     {
3467       f2k->finalizers = NULL;
3468       while (peek_atom () != ATOM_RPAREN)
3469         {
3470           gfc_finalizer *cur = NULL;
3471           mio_finalizer (&cur);
3472           cur->next = f2k->finalizers;
3473           f2k->finalizers = cur;
3474         }
3475     }
3476   mio_rparen ();
3477
3478   /* Handle type-bound procedures.  */
3479   mio_full_typebound_tree (&f2k->tb_sym_root);
3480
3481   /* Type-bound user operators.  */
3482   mio_full_typebound_tree (&f2k->tb_uop_root);
3483
3484   /* Type-bound intrinsic operators.  */
3485   mio_lparen ();
3486   if (iomode == IO_OUTPUT)
3487     {
3488       int op;
3489       for (op = GFC_INTRINSIC_BEGIN; op != GFC_INTRINSIC_END; ++op)
3490         {
3491           gfc_intrinsic_op realop;
3492
3493           if (op == INTRINSIC_USER || !f2k->tb_op[op])
3494             continue;
3495
3496           mio_lparen ();
3497           realop = (gfc_intrinsic_op) op;
3498           mio_intrinsic_op (&realop);
3499           mio_typebound_proc (&f2k->tb_op[op]);
3500           mio_rparen ();
3501         }
3502     }
3503   else
3504     while (peek_atom () != ATOM_RPAREN)
3505       {
3506         gfc_intrinsic_op op = GFC_INTRINSIC_BEGIN; /* Silence GCC.  */
3507
3508         mio_lparen ();
3509         mio_intrinsic_op (&op);
3510         mio_typebound_proc (&f2k->tb_op[op]);
3511         mio_rparen ();
3512       }
3513   mio_rparen ();
3514 }
3515
3516 static void
3517 mio_full_f2k_derived (gfc_symbol *sym)
3518 {
3519   mio_lparen ();
3520
3521   if (iomode == IO_OUTPUT)
3522     {
3523       if (sym->f2k_derived)
3524         mio_f2k_derived (sym->f2k_derived);
3525     }
3526   else
3527     {
3528       if (peek_atom () != ATOM_RPAREN)
3529         {
3530           sym->f2k_derived = gfc_get_namespace (NULL, 0);
3531           mio_f2k_derived (sym->f2k_derived);
3532         }
3533       else
3534         gcc_assert (!sym->f2k_derived);
3535     }
3536
3537   mio_rparen ();
3538 }
3539
3540
3541 /* Unlike most other routines, the address of the symbol node is already
3542    fixed on input and the name/module has already been filled in.  */
3543
3544 static void
3545 mio_symbol (gfc_symbol *sym)
3546 {
3547   int intmod = INTMOD_NONE;
3548
3549   mio_lparen ();
3550
3551   mio_symbol_attribute (&sym->attr);
3552   mio_typespec (&sym->ts);
3553
3554   if (iomode == IO_OUTPUT)
3555     mio_namespace_ref (&sym->formal_ns);
3556   else
3557     {
3558       mio_namespace_ref (&sym->formal_ns);
3559       if (sym->formal_ns)
3560         {
3561           sym->formal_ns->proc_name = sym;
3562           sym->refs++;
3563         }
3564     }
3565
3566   /* Save/restore common block links.  */
3567   mio_symbol_ref (&sym->common_next);
3568
3569   mio_formal_arglist (&sym->formal);
3570
3571   if (sym->attr.flavor == FL_PARAMETER)
3572     mio_expr (&sym->value);
3573
3574   mio_array_spec (&sym->as);
3575
3576   mio_symbol_ref (&sym->result);
3577
3578   if (sym->attr.cray_pointee)
3579     mio_symbol_ref (&sym->cp_pointer);
3580
3581   /* Note that components are always saved, even if they are supposed
3582      to be private.  Component access is checked during searching.  */
3583
3584   mio_component_list (&sym->components);
3585
3586   if (sym->components != NULL)
3587     sym->component_access
3588       = MIO_NAME (gfc_access) (sym->component_access, access_types);
3589
3590   /* Load/save the f2k_derived namespace of a derived-type symbol.  */
3591   mio_full_f2k_derived (sym);
3592
3593   mio_namelist (sym);
3594
3595   /* Add the fields that say whether this is from an intrinsic module,
3596      and if so, what symbol it is within the module.  */
3597 /*   mio_integer (&(sym->from_intmod)); */
3598   if (iomode == IO_OUTPUT)
3599     {
3600       intmod = sym->from_intmod;
3601       mio_integer (&intmod);
3602     }
3603   else
3604     {
3605       mio_integer (&intmod);
3606       sym->from_intmod = (intmod_id) intmod;
3607     }
3608
3609   mio_integer (&(sym->intmod_sym_id));
3610
3611   if (sym->attr.flavor == FL_DERIVED)
3612     mio_integer (&(sym->hash_value));
3613
3614   mio_rparen ();
3615 }
3616
3617
3618 /************************* Top level subroutines *************************/
3619
3620 /* Given a root symtree node and a symbol, try to find a symtree that
3621    references the symbol that is not a unique name.  */
3622
3623 static gfc_symtree *
3624 find_symtree_for_symbol (gfc_symtree *st, gfc_symbol *sym)
3625 {
3626   gfc_symtree *s = NULL;
3627
3628   if (st == NULL)
3629     return s;
3630
3631   s = find_symtree_for_symbol (st->right, sym);
3632   if (s != NULL)
3633     return s;
3634   s = find_symtree_for_symbol (st->left, sym);
3635   if (s != NULL)
3636     return s;
3637
3638   if (st->n.sym == sym && !check_unique_name (st->name))
3639     return st;
3640
3641   return s;
3642 }
3643
3644
3645 /* A recursive function to look for a specific symbol by name and by
3646    module.  Whilst several symtrees might point to one symbol, its
3647    is sufficient for the purposes here than one exist.  Note that
3648    generic interfaces are distinguished as are symbols that have been
3649    renamed in another module.  */
3650 static gfc_symtree *
3651 find_symbol (gfc_symtree *st, const char *name,
3652              const char *module, int generic)
3653 {
3654   int c;
3655   gfc_symtree *retval, *s;
3656
3657   if (st == NULL || st->n.sym == NULL)
3658     return NULL;
3659
3660   c = strcmp (name, st->n.sym->name);
3661   if (c == 0 && st->n.sym->module
3662              && strcmp (module, st->n.sym->module) == 0
3663              && !check_unique_name (st->name))
3664     {
3665       s = gfc_find_symtree (gfc_current_ns->sym_root, name);
3666
3667       /* Detect symbols that are renamed by use association in another
3668          module by the absence of a symtree and null attr.use_rename,
3669          since the latter is not transmitted in the module file.  */
3670       if (((!generic && !st->n.sym->attr.generic)
3671                 || (generic && st->n.sym->attr.generic))
3672             && !(s == NULL && !st->n.sym->attr.use_rename))
3673         return st;
3674     }
3675
3676   retval = find_symbol (st->left, name, module, generic);
3677
3678   if (retval == NULL)
3679     retval = find_symbol (st->right, name, module, generic);
3680
3681   return retval;
3682 }
3683
3684
3685 /* Skip a list between balanced left and right parens.  */
3686
3687 static void
3688 skip_list (void)
3689 {
3690   int level;
3691
3692   level = 0;
3693   do
3694     {
3695       switch (parse_atom ())
3696         {
3697         case ATOM_LPAREN:
3698           level++;
3699           break;
3700
3701         case ATOM_RPAREN:
3702           level--;
3703           break;
3704
3705         case ATOM_STRING:
3706           gfc_free (atom_string);
3707           break;
3708
3709         case ATOM_NAME:
3710         case ATOM_INTEGER:
3711           break;
3712         }
3713     }
3714   while (level > 0);
3715 }
3716
3717
3718 /* Load operator interfaces from the module.  Interfaces are unusual
3719    in that they attach themselves to existing symbols.  */
3720
3721 static void
3722 load_operator_interfaces (void)
3723 {
3724   const char *p;
3725   char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3726   gfc_user_op *uop;
3727   pointer_info *pi = NULL;
3728   int n, i;
3729
3730   mio_lparen ();
3731
3732   while (peek_atom () != ATOM_RPAREN)
3733     {
3734       mio_lparen ();
3735
3736       mio_internal_string (name);
3737       mio_internal_string (module);
3738
3739       n = number_use_names (name, true);
3740       n = n ? n : 1;
3741
3742       for (i = 1; i <= n; i++)
3743         {
3744           /* Decide if we need to load this one or not.  */
3745           p = find_use_name_n (name, &i, true);
3746
3747           if (p == NULL)
3748             {
3749               while (parse_atom () != ATOM_RPAREN);
3750               continue;
3751             }
3752
3753           if (i == 1)
3754             {
3755               uop = gfc_get_uop (p);
3756               pi = mio_interface_rest (&uop->op);
3757             }
3758           else
3759             {
3760               if (gfc_find_uop (p, NULL))
3761                 continue;
3762               uop = gfc_get_uop (p);
3763               uop->op = gfc_get_interface ();
3764               uop->op->where = gfc_current_locus;
3765               add_fixup (pi->integer, &uop->op->sym);
3766             }
3767         }
3768     }
3769
3770   mio_rparen ();
3771 }
3772
3773
3774 /* Load interfaces from the module.  Interfaces are unusual in that
3775    they attach themselves to existing symbols.  */
3776
3777 static void
3778 load_generic_interfaces (void)
3779 {
3780   const char *p;
3781   char name[GFC_MAX_SYMBOL_LEN + 1], module[GFC_MAX_SYMBOL_LEN + 1];
3782   gfc_symbol *sym;
3783   gfc_interface *generic = NULL, *gen = NULL;
3784   int n, i, renamed;
3785   bool ambiguous_set = false;
3786
3787   mio_lparen ();
3788
3789   while (peek_atom () != ATOM_RPAREN)
3790     {
3791       mio_lparen ();
3792
3793       mio_internal_string (name);
3794       mio_internal_string (module);
3795
3796       n = number_use_names (name, false);
3797       renamed = n ? 1 : 0;
3798       n = n ? n : 1;
3799
3800       for (i = 1; i <= n; i++)
3801         {
3802           gfc_symtree *st;
3803           /* Decide if we need to load this one or not.  */
3804           p = find_use_name_n (name, &i, false);
3805
3806           st = find_symbol (gfc_current_ns->sym_root,
3807                             name, module_name, 1);
3808
3809           if (!p || gfc_find_symbol (p, NULL, 0, &sym))
3810             {
3811               /* Skip the specific names for these cases.  */
3812               while (i == 1 && parse_atom () != ATOM_RPAREN);
3813
3814               continue;
3815             }
3816
3817           /* If the symbol exists already and is being USEd without being
3818              in an ONLY clause, do not load a new symtree(11.3.2).  */
3819           if (!only_flag && st)
3820             sym = st->n.sym;
3821
3822           if (!sym)
3823             {
3824               /* Make the symbol inaccessible if it has been added by a USE
3825                  statement without an ONLY(11.3.2).  */
3826               if (st && only_flag
3827                      && !st->n.sym->attr.use_only
3828                      && !st->n.sym->attr.use_rename
3829                      && strcmp (st->n.sym->module, module_name) == 0)
3830                 {
3831                   sym = st->n.sym;
3832                   gfc_delete_symtree (&gfc_current_ns->sym_root, name);
3833                   st = gfc_get_unique_symtree (gfc_current_ns);
3834                   st->n.sym = sym;
3835                   sym = NULL;
3836                 }
3837               else if (st)
3838                 {
3839                   sym = st->n.sym;
3840                   if (strcmp (st->name, p) != 0)
3841                     {
3842                       st = gfc_new_symtree (&gfc_current_ns->sym_root, p);
3843                       st->n.sym = sym;
3844                       sym->refs++;
3845                     }
3846                 }
3847
3848               /* Since we haven't found a valid generic interface, we had
3849                  better make one.  */
3850               if (!sym)
3851                 {
3852                   gfc_get_symbol (p, NULL, &sym);
3853                   sym->name = gfc_get_string (name);
3854                   sym->module = gfc_get_string (module_name);
3855                   sym->attr.flavor = FL_PROCEDURE;
3856                   sym->attr.generic = 1;
3857                   sym->attr.use_assoc = 1;
3858                 }
3859             }
3860           else
3861             {
3862               /* Unless sym is a generic interface, this reference
3863                  is ambiguous.  */
3864               if (st == NULL)
3865                 st = gfc_find_symtree (gfc_current_ns->sym_root, p);
3866
3867               sym = st->n.sym;
3868
3869               if (st && !sym->attr.generic
3870                      && !st->ambiguous
3871                      && sym->module
3872                      && strcmp(module, sym->module))
3873                 {
3874                   ambiguous_set = true;
3875                   st->ambiguous = 1;
3876                 }
3877             }
3878
3879           sym->attr.use_only = only_flag;
3880           sym->attr.use_rename = renamed;
3881
3882           if (i == 1)
3883             {
3884               mio_interface_rest (&sym->generic);
3885               generic = sym->generic;
3886             }
3887           else if (!sym->generic)
3888             {
3889               sym->generic = generic;
3890               sym->attr.generic_copy = 1;
3891             }
3892
3893           /* If a procedure that is not generic has generic interfaces
3894              that include itself, it is generic! We need to take care
3895              to retain symbols ambiguous that were already so.  */
3896           if (sym->attr.use_assoc
3897                 && !sym->attr.generic
3898                 && sym->attr.flavor == FL_PROCEDURE)
3899             {
3900               for (gen = generic; gen; gen = gen->next)
3901                 {
3902                   if (gen->sym == sym)
3903                     {
3904                       sym->attr.generic = 1;
3905                       if (ambiguous_set)
3906                         st->ambiguous = 0;
3907                       break;
3908                     }
3909                 }
3910             }
3911
3912         }
3913     }
3914
3915   mio_rparen ();
3916 }
3917
3918
3919 /* Load common blocks.  */
3920
3921 static void
3922 load_commons (void)
3923 {
3924   char name[GFC_MAX_SYMBOL_LEN + 1];
3925   gfc_common_head *p;
3926
3927   mio_lparen ();
3928
3929   while (peek_atom () != ATOM_RPAREN)
3930     {
3931       int flags;
3932       mio_lparen ();
3933       mio_internal_string (name);
3934
3935       p = gfc_get_common (name, 1);
3936
3937       mio_symbol_ref (&p->head);
3938       mio_integer (&flags);
3939       if (flags & 1)
3940         p->saved = 1;
3941       if (flags & 2)
3942         p->threadprivate = 1;
3943       p->use_assoc = 1;
3944
3945       /* Get whether this was a bind(c) common or not.  */
3946       mio_integer (&p->is_bind_c);
3947       /* Get the binding label.  */
3948       mio_internal_string (p->binding_label);
3949
3950       mio_rparen ();
3951     }
3952
3953   mio_rparen ();
3954 }
3955
3956
3957 /* Load equivalences.  The flag in_load_equiv informs mio_expr_ref of this
3958    so that unused variables are not loaded and so that the expression can
3959    be safely freed.  */
3960
3961 static void
3962 load_equiv (void)
3963 {
3964   gfc_equiv *head, *tail, *end, *eq;
3965   bool unused;
3966
3967   mio_lparen ();
3968   in_load_equiv = true;
3969
3970   end = gfc_current_ns->equiv;
3971   while (end != NULL && end->next != NULL)
3972     end = end->next;
3973
3974   while (peek_atom () != ATOM_RPAREN) {
3975     mio_lparen ();
3976     head = tail = NULL;
3977
3978     while(peek_atom () != ATOM_RPAREN)
3979       {
3980         if (head == NULL)
3981           head = tail = gfc_get_equiv ();
3982         else
3983           {
3984             tail->eq = gfc_get_equiv ();
3985             tail = tail->eq;
3986           }
3987
3988         mio_pool_string (&tail->module);
3989         mio_expr (&tail->expr);
3990       }
3991
3992     /* Unused equivalence members have a unique name.  In addition, it
3993        must be checked that the symbols are from the same module.  */
3994     unused = true;
3995     for (eq = head; eq; eq = eq->eq)
3996       {
3997         if (eq->expr->symtree->n.sym->module
3998               && head->expr->symtree->n.sym->module
3999               && strcmp (head->expr->symtree->n.sym->module,
4000                          eq->expr->symtree->n.sym->module) == 0
4001               && !check_unique_name (eq->expr->symtree->name))
4002           {
4003             unused = false;
4004             break;
4005           }
4006       }
4007
4008     if (unused)
4009       {
4010         for (eq = head; eq; eq = head)
4011           {
4012             head = eq->eq;
4013             gfc_free_expr (eq->expr);
4014             gfc_free (eq);
4015           }
4016       }
4017
4018     if (end == NULL)
4019       gfc_current_ns->equiv = head;
4020     else
4021       end->next = head;
4022
4023     if (head != NULL)
4024       end = head;
4025
4026     mio_rparen ();
4027   }
4028
4029   mio_rparen ();
4030   in_load_equiv = false;
4031 }
4032
4033
4034 /* This function loads the sym_root of f2k_derived with the extensions to
4035    the derived type.  */
4036 static void
4037 load_derived_extensions (void)
4038 {
4039   int symbol, j;
4040   gfc_symbol *derived;
4041   gfc_symbol *dt;
4042   gfc_symtree *st;
4043   pointer_info *info;
4044   char name[GFC_MAX_SYMBOL_LEN + 1];
4045   char module[GFC_MAX_SYMBOL_LEN + 1];
4046   const char *p;
4047
4048   mio_lparen ();
4049   while (peek_atom () != ATOM_RPAREN)
4050     {
4051       mio_lparen ();
4052       mio_integer (&symbol);
4053       info = get_integer (symbol);
4054       derived = info->u.rsym.sym;
4055
4056       /* This one is not being loaded.  */
4057       if (!info || !derived)
4058         {
4059           while (peek_atom () != ATOM_RPAREN)
4060             skip_list ();
4061           continue;
4062         }
4063
4064       gcc_assert (derived->attr.flavor == FL_DERIVED);
4065       if (derived->f2k_derived == NULL)
4066         derived->f2k_derived = gfc_get_namespace (NULL, 0);
4067
4068       while (peek_atom () != ATOM_RPAREN)
4069         {
4070           mio_lparen ();
4071           mio_internal_string (name);
4072           mio_internal_string (module);
4073
4074           /* Only use one use name to find the symbol.  */
4075           j = 1;
4076           p = find_use_name_n (name, &j, false);
4077           if (p)
4078             {
4079               st = gfc_find_symtree (gfc_current_ns->sym_root, p);
4080               dt = st->n.sym;
4081               st = gfc_find_symtree (derived->f2k_derived->sym_root, name);
4082               if (st == NULL)
4083                 {
4084                   /* Only use the real name in f2k_derived to ensure a single
4085                     symtree.  */
4086                   st = gfc_new_symtree (&derived->f2k_derived->sym_root, name);
4087                   st->n.sym = dt;
4088                   st->n.sym->refs++;
4089                 }
4090             }
4091           mio_rparen ();
4092         }
4093       mio_rparen ();
4094     }
4095   mio_rparen ();
4096 }
4097
4098
4099 /* Recursive function to traverse the pointer_info tree and load a
4100    needed symbol.  We return nonzero if we load a symbol and stop the
4101    traversal, because the act of loading can alter the tree.  */
4102
4103 static int
4104 load_needed (pointer_info *p)
4105 {
4106   gfc_namespace *ns;
4107   pointer_info *q;
4108   gfc_symbol *sym;
4109   int rv;
4110
4111   rv = 0;
4112   if (p == NULL)
4113     return rv;
4114
4115   rv |= load_needed (p->left);
4116   rv |= load_needed (p->right);
4117
4118   if (p->type != P_SYMBOL || p->u.rsym.state != NEEDED)
4119     return rv;
4120
4121   p->u.rsym.state = USED;
4122
4123   set_module_locus (&p->u.rsym.where);
4124
4125   sym = p->u.rsym.sym;
4126   if (sym == NULL)
4127     {
4128       q = get_integer (p->u.rsym.ns);
4129
4130       ns = (gfc_namespace *) q->u.pointer;
4131       if (ns == NULL)
4132         {
4133           /* Create an interface namespace if necessary.  These are
4134              the namespaces that hold the formal parameters of module
4135              procedures.  */
4136
4137           ns = gfc_get_namespace (NULL, 0);
4138           associate_integer_pointer (q, ns);
4139         }
4140
4141       /* Use the module sym as 'proc_name' so that gfc_get_symbol_decl
4142          doesn't go pear-shaped if the symbol is used.  */
4143       if (!ns->proc_name)
4144         gfc_find_symbol (p->u.rsym.module, gfc_current_ns,
4145                                  1, &ns->proc_name);
4146
4147       sym = gfc_new_symbol (p->u.rsym.true_name, ns);
4148       sym->module = gfc_get_string (p->u.rsym.module);
4149       strcpy (sym->binding_label, p->u.rsym.binding_label);
4150
4151       associate_integer_pointer (p, sym);
4152     }
4153
4154   mio_symbol (sym);
4155   sym->attr.use_assoc = 1;
4156   if (only_flag)
4157     sym->attr.use_only = 1;
4158   if (p->u.rsym.renamed)
4159     sym->attr.use_rename = 1;
4160
4161   return 1;
4162 }
4163
4164
4165 /* Recursive function for cleaning up things after a module has been read.  */
4166
4167 static void
4168 read_cleanup (pointer_info *p)
4169 {
4170   gfc_symtree *st;
4171   pointer_info *q;
4172
4173   if (p == NULL)
4174     return;
4175
4176   read_cleanup (p->left);
4177   read_cleanup (p->right);
4178
4179   if (p->type == P_SYMBOL && p->u.rsym.state == USED && !p->u.rsym.referenced)
4180     {
4181       /* Add hidden symbols to the symtree.  */
4182       q = get_integer (p->u.rsym.ns);
4183       st = gfc_get_unique_symtree ((gfc_namespace *) q->u.pointer);
4184
4185       st->n.sym = p->u.rsym.sym;
4186       st->n.sym->refs++;
4187
4188       /* Fixup any symtree references.  */
4189       p->u.rsym.symtree = st;
4190       resolve_fixups (p->u.rsym.stfixup, st);
4191       p->u.rsym.stfixup = NULL;
4192     }
4193
4194   /* Free unused symbols.  */
4195   if (p->type == P_SYMBOL && p->u.rsym.state == UNUSED)
4196     gfc_free_symbol (p->u.rsym.sym);
4197 }
4198
4199
4200 /* It is not quite enough to check for ambiguity in the symbols by
4201    the loaded symbol and the new symbol not being identical.  */
4202 static bool
4203 check_for_ambiguous (gfc_symbol *st_sym, pointer_info *info)
4204 {
4205   gfc_symbol *rsym;
4206   module_locus locus;
4207   symbol_attribute attr;
4208
4209   rsym = info->u.rsym.sym;
4210   if (st_sym == rsym)
4211     return false;
4212
4213   /* If the existing symbol is generic from a different module and
4214      the new symbol is generic there can be no ambiguity.  */
4215   if (st_sym->attr.generic
4216         && st_sym->module
4217         && strcmp (st_sym->module, module_name))
4218     {
4219       /* The new symbol's attributes have not yet been read.  Since
4220          we need attr.generic, read it directly.  */
4221       get_module_locus (&locus);
4222       set_module_locus (&info->u.rsym.where);
4223       mio_lparen ();
4224       attr.generic = 0;
4225       mio_symbol_attribute (&attr);
4226       set_module_locus (&locus);
4227       if (attr.generic)
4228         return false;
4229     }
4230
4231   return true;
4232 }
4233
4234
4235 /* Read a module file.  */
4236
4237 static void
4238 read_module (void)
4239 {
4240   module_locus operator_interfaces, user_operators, extensions;
4241   const char *p;
4242   char name[GFC_MAX_SYMBOL_LEN + 1];
4243   int i;
4244   int ambiguous, j, nuse, symbol;
4245   pointer_info *info, *q;
4246   gfc_use_rename *u;
4247   gfc_symtree *st;
4248   gfc_symbol *sym;
4249
4250   get_module_locus (&operator_interfaces);      /* Skip these for now.  */
4251   skip_list ();
4252
4253   get_module_locus (&user_operators);
4254   skip_list ();
4255   skip_list ();
4256
4257   /* Skip commons, equivalences and derived type extensions for now.  */
4258   skip_list ();
4259   skip_list ();
4260
4261   get_module_locus (&extensions);
4262   skip_list ();
4263
4264   mio_lparen ();
4265
4266   /* Create the fixup nodes for all the symbols.  */
4267
4268   while (peek_atom () != ATOM_RPAREN)
4269     {
4270       require_atom (ATOM_INTEGER);
4271       info = get_integer (atom_int);
4272
4273       info->type = P_SYMBOL;
4274       info->u.rsym.state = UNUSED;
4275
4276       mio_internal_string (info->u.rsym.true_name);
4277       mio_internal_string (info->u.rsym.module);
4278       mio_internal_string (info->u.rsym.binding_label);
4279
4280
4281       require_atom (ATOM_INTEGER);
4282       info->u.rsym.ns = atom_int;
4283
4284       get_module_locus (&info->u.rsym.where);
4285       skip_list ();
4286
4287       /* See if the symbol has already been loaded by a previous module.
4288          If so, we reference the existing symbol and prevent it from
4289          being loaded again.  This should not happen if the symbol being
4290          read is an index for an assumed shape dummy array (ns != 1).  */
4291
4292       sym = find_true_name (info->u.rsym.true_name, info->u.rsym.module);
4293
4294       if (sym == NULL
4295           || (sym->attr.flavor == FL_VARIABLE && info->u.rsym.ns !=1))
4296         continue;
4297
4298       info->u.rsym.state = USED;
4299       info->u.rsym.sym = sym;
4300
4301       /* Some symbols do not have a namespace (eg. formal arguments),
4302          so the automatic "unique symtree" mechanism must be suppressed
4303          by marking them as referenced.  */
4304       q = get_integer (info->u.rsym.ns);
4305       if (q->u.pointer == NULL)
4306         {
4307           info->u.rsym.referenced = 1;
4308           continue;
4309         }
4310
4311       /* If possible recycle the symtree that references the symbol.
4312          If a symtree is not found and the module does not import one,
4313          a unique-name symtree is found by read_cleanup.  */
4314       st = find_symtree_for_symbol (gfc_current_ns->sym_root, sym);
4315       if (st != NULL)
4316         {
4317           info->u.rsym.symtree = st;
4318           info->u.rsym.referenced = 1;
4319         }
4320     }
4321
4322   mio_rparen ();
4323
4324   /* Parse the symtree lists.  This lets us mark which symbols need to
4325      be loaded.  Renaming is also done at this point by replacing the
4326      symtree name.  */
4327
4328   mio_lparen ();
4329
4330   while (peek_atom () != ATOM_RPAREN)
4331     {
4332       mio_internal_string (name);
4333       mio_integer (&ambiguous);
4334       mio_integer (&symbol);
4335
4336       info = get_integer (symbol);
4337
4338       /* See how many use names there are.  If none, go through the start
4339          of the loop at least once.  */
4340       nuse = number_use_names (name, false);
4341       info->u.rsym.renamed = nuse ? 1 : 0;
4342
4343       if (nuse == 0)
4344         nuse = 1;
4345
4346       for (j = 1; j <= nuse; j++)
4347         {
4348           /* Get the jth local name for this symbol.  */
4349           p = find_use_name_n (name, &j, false);
4350
4351           if (p == NULL && strcmp (name, module_name) == 0)
4352             p = name;
4353
4354           /* Skip symtree nodes not in an ONLY clause, unless there
4355              is an existing symtree loaded from another USE statement.  */
4356           if (p == NULL)
4357             {
4358               st = gfc_find_symtree (gfc_current_ns->sym_root, name);
4359               if (st != NULL)
4360                 info->u.rsym.symtree = st;
4361               continue;
4362             }
4363
4364           /* If a symbol of the same name and module exists already,
4365              this symbol, which is not in an ONLY clause, must not be
4366              added to the namespace(11.3.2).  Note that find_symbol
4367              only returns the first occurrence that it finds.  */
4368           if (!only_flag && !info->u.rsym.renamed
4369                 && strcmp (name, module_name) != 0
4370                 && find_symbol (gfc_current_ns->sym_root, name,
4371                                 module_name, 0))
4372             continue;
4373
4374           st = gfc_find_symtree (gfc_current_ns->sym_root, p);
4375
4376           if (st != NULL)
4377             {
4378               /* Check for ambiguous symbols.  */
4379               if (check_for_ambiguous (st->n.sym, info))
4380                 st->ambiguous = 1;
4381               info->u.rsym.symtree = st;
4382             }
4383           else
4384             {
4385               st = gfc_find_symtree (gfc_current_ns->sym_root, name);
4386
4387               /* Delete the symtree if the symbol has been added by a USE
4388                  statement without an ONLY(11.3.2).  Remember that the rsym
4389                  will be the same as the symbol found in the symtree, for
4390                  this case.  */
4391               if (st && (only_flag || info->u.rsym.renamed)
4392                      && !st->n.sym->attr.use_only
4393                      && !st->n.sym->attr.use_rename
4394                      && info->u.rsym.sym == st->n.sym)
4395                 gfc_delete_symtree (&gfc_current_ns->sym_root, name);
4396
4397               /* Create a symtree node in the current namespace for this
4398                  symbol.  */
4399               st = check_unique_name (p)
4400                    ? gfc_get_unique_symtree (gfc_current_ns)
4401                    : gfc_new_symtree (&gfc_current_ns->sym_root, p);
4402               st->ambiguous = ambiguous;
4403
4404               sym = info->u.rsym.sym;
4405
4406               /* Create a symbol node if it doesn't already exist.  */
4407               if (sym == NULL)
4408                 {
4409                   info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
4410                                                      gfc_current_ns);
4411                   sym = info->u.rsym.sym;
4412                   sym->module = gfc_get_string (info->u.rsym.module);
4413
4414                   /* TODO: hmm, can we test this?  Do we know it will be
4415                      initialized to zeros?  */
4416                   if (info->u.rsym.binding_label[0] != '\0')
4417                     strcpy (sym->binding_label, info->u.rsym.binding_label);
4418                 }
4419
4420               st->n.sym = sym;
4421               st->n.sym->refs++;
4422
4423               if (strcmp (name, p) != 0)
4424                 sym->attr.use_rename = 1;
4425
4426               /* We need to set the only_flag here so that symbols from the
4427                  same USE...ONLY but earlier are not deleted from the tree in
4428                  the gfc_delete_symtree above.  */
4429               sym->attr.use_only = only_flag;
4430
4431               /* Store the symtree pointing to this symbol.  */
4432               info->u.rsym.symtree = st;
4433
4434               if (info->u.rsym.state == UNUSED)
4435                 info->u.rsym.state = NEEDED;
4436               info->u.rsym.referenced = 1;
4437             }
4438         }
4439     }
4440
4441   mio_rparen ();
4442
4443   /* Load intrinsic operator interfaces.  */
4444   set_module_locus (&operator_interfaces);
4445   mio_lparen ();
4446
4447   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
4448     {
4449       if (i == INTRINSIC_USER)
4450         continue;
4451
4452       if (only_flag)
4453         {
4454           u = find_use_operator ((gfc_intrinsic_op) i);
4455
4456           if (u == NULL)
4457             {
4458               skip_list ();
4459               continue;
4460             }
4461
4462           u->found = 1;
4463         }
4464
4465       mio_interface (&gfc_current_ns->op[i]);
4466     }
4467
4468   mio_rparen ();
4469
4470   /* Load generic and user operator interfaces.  These must follow the
4471      loading of symtree because otherwise symbols can be marked as
4472      ambiguous.  */
4473
4474   set_module_locus (&user_operators);
4475
4476   load_operator_interfaces ();
4477   load_generic_interfaces ();
4478
4479   load_commons ();
4480   load_equiv ();
4481
4482   /* At this point, we read those symbols that are needed but haven't
4483      been loaded yet.  If one symbol requires another, the other gets
4484      marked as NEEDED if its previous state was UNUSED.  */
4485
4486   while (load_needed (pi_root));
4487
4488   /* Make sure all elements of the rename-list were found in the module.  */
4489
4490   for (u = gfc_rename_list; u; u = u->next)
4491     {
4492       if (u->found)
4493         continue;
4494
4495       if (u->op == INTRINSIC_NONE)
4496         {
4497           gfc_error ("Symbol '%s' referenced at %L not found in module '%s'",
4498                      u->use_name, &u->where, module_name);
4499           continue;
4500         }
4501
4502       if (u->op == INTRINSIC_USER)
4503         {
4504           gfc_error ("User operator '%s' referenced at %L not found "
4505                      "in module '%s'", u->use_name, &u->where, module_name);
4506           continue;
4507         }
4508
4509       gfc_error ("Intrinsic operator '%s' referenced at %L not found "
4510                  "in module '%s'", gfc_op2string (u->op), &u->where,
4511                  module_name);
4512     }
4513
4514   /* Now we should be in a position to fill f2k_derived with derived type
4515      extensions, since everything has been loaded.  */
4516   set_module_locus (&extensions);
4517   load_derived_extensions ();
4518
4519   /* Clean up symbol nodes that were never loaded, create references
4520      to hidden symbols.  */
4521
4522   read_cleanup (pi_root);
4523 }
4524
4525
4526 /* Given an access type that is specific to an entity and the default
4527    access, return nonzero if the entity is publicly accessible.  If the
4528    element is declared as PUBLIC, then it is public; if declared
4529    PRIVATE, then private, and otherwise it is public unless the default
4530    access in this context has been declared PRIVATE.  */
4531
4532 bool
4533 gfc_check_access (gfc_access specific_access, gfc_access default_access)
4534 {
4535   if (specific_access == ACCESS_PUBLIC)
4536     return TRUE;
4537   if (specific_access == ACCESS_PRIVATE)
4538     return FALSE;
4539
4540   if (gfc_option.flag_module_private)
4541     return default_access == ACCESS_PUBLIC;
4542   else
4543     return default_access != ACCESS_PRIVATE;
4544 }
4545
4546
4547 /* A structure to remember which commons we've already written.  */
4548
4549 struct written_common
4550 {
4551   BBT_HEADER(written_common);
4552   const char *name, *label;
4553 };
4554
4555 static struct written_common *written_commons = NULL;
4556
4557 /* Comparison function used for balancing the binary tree.  */
4558
4559 static int
4560 compare_written_commons (void *a1, void *b1)
4561 {
4562   const char *aname = ((struct written_common *) a1)->name;
4563   const char *alabel = ((struct written_common *) a1)->label;
4564   const char *bname = ((struct written_common *) b1)->name;
4565   const char *blabel = ((struct written_common *) b1)->label;
4566   int c = strcmp (aname, bname);
4567
4568   return (c != 0 ? c : strcmp (alabel, blabel));
4569 }
4570
4571 /* Free a list of written commons.  */
4572
4573 static void
4574 free_written_common (struct written_common *w)
4575 {
4576   if (!w)
4577     return;
4578
4579   if (w->left)
4580     free_written_common (w->left);
4581   if (w->right)
4582     free_written_common (w->right);
4583
4584   gfc_free (w);
4585 }
4586
4587 /* Write a common block to the module -- recursive helper function.  */
4588
4589 static void
4590 write_common_0 (gfc_symtree *st, bool this_module)
4591 {
4592   gfc_common_head *p;
4593   const char * name;
4594   int flags;
4595   const char *label;
4596   struct written_common *w;
4597   bool write_me = true;
4598
4599   if (st == NULL)
4600     return;
4601
4602   write_common_0 (st->left, this_module);
4603
4604   /* We will write out the binding label, or the name if no label given.  */
4605   name = st->n.common->name;
4606   p = st->n.common;
4607   label = p->is_bind_c ? p->binding_label : p->name;
4608
4609   /* Check if we've already output this common.  */
4610   w = written_commons;
4611   while (w)
4612     {
4613       int c = strcmp (name, w->name);
4614       c = (c != 0 ? c : strcmp (label, w->label));
4615       if (c == 0)
4616         write_me = false;
4617
4618       w = (c < 0) ? w->left : w->right;
4619     }
4620
4621   if (this_module && p->use_assoc)
4622     write_me = false;
4623
4624   if (write_me)
4625     {
4626       /* Write the common to the module.  */
4627       mio_lparen ();
4628       mio_pool_string (&name);
4629
4630       mio_symbol_ref (&p->head);
4631       flags = p->saved ? 1 : 0;
4632       if (p->threadprivate)
4633         flags |= 2;
4634       mio_integer (&flags);
4635
4636       /* Write out whether the common block is bind(c) or not.  */
4637       mio_integer (&(p->is_bind_c));
4638
4639       mio_pool_string (&label);
4640       mio_rparen ();
4641
4642       /* Record that we have written this common.  */
4643       w = XCNEW (struct written_common);
4644       w->name = p->name;
4645       w->label = label;
4646       gfc_insert_bbt (&written_commons, w, compare_written_commons);
4647     }
4648
4649   write_common_0 (st->right, this_module);
4650 }
4651
4652
4653 /* Write a common, by initializing the list of written commons, calling
4654    the recursive function write_common_0() and cleaning up afterwards.  */
4655
4656 static void
4657 write_common (gfc_symtree *st)
4658 {
4659   written_commons = NULL;
4660   write_common_0 (st, true);
4661   write_common_0 (st, false);
4662   free_written_common (written_commons);
4663   written_commons = NULL;
4664 }
4665
4666
4667 /* Write the blank common block to the module.  */
4668
4669 static void
4670 write_blank_common (void)
4671 {
4672   const char * name = BLANK_COMMON_NAME;
4673   int saved;
4674   /* TODO: Blank commons are not bind(c).  The F2003 standard probably says
4675      this, but it hasn't been checked.  Just making it so for now.  */
4676   int is_bind_c = 0;
4677
4678   if (gfc_current_ns->blank_common.head == NULL)
4679     return;
4680
4681   mio_lparen ();
4682
4683   mio_pool_string (&name);
4684
4685   mio_symbol_ref (&gfc_current_ns->blank_common.head);
4686   saved = gfc_current_ns->blank_common.saved;
4687   mio_integer (&saved);
4688
4689   /* Write out whether the common block is bind(c) or not.  */
4690   mio_integer (&is_bind_c);
4691
4692   /* Write out the binding label, which is BLANK_COMMON_NAME, though
4693      it doesn't matter because the label isn't used.  */
4694   mio_pool_string (&name);
4695
4696   mio_rparen ();
4697 }
4698
4699
4700 /* Write equivalences to the module.  */
4701
4702 static void
4703 write_equiv (void)
4704 {
4705   gfc_equiv *eq, *e;
4706   int num;
4707
4708   num = 0;
4709   for (eq = gfc_current_ns->equiv; eq; eq = eq->next)
4710     {
4711       mio_lparen ();
4712
4713       for (e = eq; e; e = e->eq)
4714         {
4715           if (e->module == NULL)
4716             e->module = gfc_get_string ("%s.eq.%d", module_name, num);
4717           mio_allocated_string (e->module);
4718           mio_expr (&e->expr);
4719         }
4720
4721       num++;
4722       mio_rparen ();
4723     }
4724 }
4725
4726
4727 /* Write derived type extensions to the module.  */
4728
4729 static void
4730 write_dt_extensions (gfc_symtree *st)
4731 {
4732   if (!gfc_check_access (st->n.sym->attr.access,
4733                          st->n.sym->ns->default_access))
4734     return;
4735
4736   mio_lparen ();
4737   mio_pool_string (&st->n.sym->name);
4738   if (st->n.sym->module != NULL)
4739     mio_pool_string (&st->n.sym->module);
4740   else
4741     mio_internal_string (module_name);
4742   mio_rparen ();
4743 }
4744
4745 static void
4746 write_derived_extensions (gfc_symtree *st)
4747 {
4748   if (!((st->n.sym->attr.flavor == FL_DERIVED)
4749           && (st->n.sym->f2k_derived != NULL)
4750           && (st->n.sym->f2k_derived->sym_root != NULL)))
4751     return;
4752
4753   mio_lparen ();
4754   mio_symbol_ref (&(st->n.sym));
4755   gfc_traverse_symtree (st->n.sym->f2k_derived->sym_root,
4756                         write_dt_extensions);
4757   mio_rparen ();
4758 }
4759
4760
4761 /* Write a symbol to the module.  */
4762
4763 static void
4764 write_symbol (int n, gfc_symbol *sym)
4765 {
4766   const char *label;
4767
4768   if (sym->attr.flavor == FL_UNKNOWN || sym->attr.flavor == FL_LABEL)
4769     gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
4770
4771   mio_integer (&n);
4772   mio_pool_string (&sym->name);
4773
4774   mio_pool_string (&sym->module);
4775   if (sym->attr.is_bind_c || sym->attr.is_iso_c)
4776     {
4777       label = sym->binding_label;
4778       mio_pool_string (&label);
4779     }
4780   else
4781     mio_pool_string (&sym->name);
4782
4783   mio_pointer_ref (&sym->ns);
4784
4785   mio_symbol (sym);
4786   write_char ('\n');
4787 }
4788
4789
4790 /* Recursive traversal function to write the initial set of symbols to
4791    the module.  We check to see if the symbol should be written
4792    according to the access specification.  */
4793
4794 static void
4795 write_symbol0 (gfc_symtree *st)
4796 {
4797   gfc_symbol *sym;
4798   pointer_info *p;
4799   bool dont_write = false;
4800
4801   if (st == NULL)
4802     return;
4803
4804   write_symbol0 (st->left);
4805
4806   sym = st->n.sym;
4807   if (sym->module == NULL)
4808     sym->module = gfc_get_string (module_name);
4809
4810   if (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
4811       && !sym->attr.subroutine && !sym->attr.function)
4812     dont_write = true;
4813
4814   if (!gfc_check_access (sym->attr.access, sym->ns->default_access))
4815     dont_write = true;
4816
4817   if (!dont_write)
4818     {
4819       p = get_pointer (sym);
4820       if (p->type == P_UNKNOWN)
4821         p->type = P_SYMBOL;
4822
4823       if (p->u.wsym.state != WRITTEN)
4824         {
4825           write_symbol (p->integer, sym);
4826           p->u.wsym.state = WRITTEN;
4827         }
4828     }
4829
4830   write_symbol0 (st->right);
4831 }
4832
4833
4834 /* Recursive traversal function to write the secondary set of symbols
4835    to the module file.  These are symbols that were not public yet are
4836    needed by the public symbols or another dependent symbol.  The act
4837    of writing a symbol can modify the pointer_info tree, so we cease
4838    traversal if we find a symbol to write.  We return nonzero if a
4839    symbol was written and pass that information upwards.  */
4840
4841 static int
4842 write_symbol1 (pointer_info *p)
4843 {
4844   int result;
4845
4846   if (!p)
4847     return 0;
4848
4849   result = write_symbol1 (p->left);
4850
4851   if (!(p->type != P_SYMBOL || p->u.wsym.state != NEEDS_WRITE))
4852     {
4853       p->u.wsym.state = WRITTEN;
4854       write_symbol (p->integer, p->u.wsym.sym);
4855       result = 1;
4856     }
4857
4858   result |= write_symbol1 (p->right);
4859   return result;
4860 }
4861
4862
4863 /* Write operator interfaces associated with a symbol.  */
4864
4865 static void
4866 write_operator (gfc_user_op *uop)
4867 {
4868   static char nullstring[] = "";
4869   const char *p = nullstring;
4870
4871   if (uop->op == NULL
4872       || !gfc_check_access (uop->access, uop->ns->default_access))
4873     return;
4874
4875   mio_symbol_interface (&uop->name, &p, &uop->op);
4876 }
4877
4878
4879 /* Write generic interfaces from the namespace sym_root.  */
4880
4881 static void
4882 write_generic (gfc_symtree *st)
4883 {
4884   gfc_symbol *sym;
4885
4886   if (st == NULL)
4887     return;
4888
4889   write_generic (st->left);
4890   write_generic (st->right);
4891
4892   sym = st->n.sym;
4893   if (!sym || check_unique_name (st->name))
4894     return;
4895
4896   if (sym->generic == NULL
4897       || !gfc_check_access (sym->attr.access, sym->ns->default_access))
4898     return;
4899
4900   if (sym->module == NULL)
4901     sym->module = gfc_get_string (module_name);
4902
4903   mio_symbol_interface (&st->name, &sym->module, &sym->generic);
4904 }
4905
4906
4907 static void
4908 write_symtree (gfc_symtree *st)
4909 {
4910   gfc_symbol *sym;
4911   pointer_info *p;
4912
4913   sym = st->n.sym;
4914
4915   /* A symbol in an interface body must not be visible in the
4916      module file.  */
4917   if (sym->ns != gfc_current_ns
4918         && sym->ns->proc_name
4919         && sym->ns->proc_name->attr.if_source == IFSRC_IFBODY)
4920     return;
4921
4922   if (!gfc_check_access (sym->attr.access, sym->ns->default_access)
4923       || (sym->attr.flavor == FL_PROCEDURE && sym->attr.generic
4924           && !sym->attr.subroutine && !sym->attr.function))
4925     return;
4926
4927   if (check_unique_name (st->name))
4928     return;
4929
4930   p = find_pointer (sym);
4931   if (p == NULL)
4932     gfc_internal_error ("write_symtree(): Symbol not written");
4933
4934   mio_pool_string (&st->name);
4935   mio_integer (&st->ambiguous);
4936   mio_integer (&p->integer);
4937 }
4938
4939
4940 static void
4941 write_module (void)
4942 {
4943   int i;
4944
4945   /* Write the operator interfaces.  */
4946   mio_lparen ();
4947
4948   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
4949     {
4950       if (i == INTRINSIC_USER)
4951         continue;
4952
4953       mio_interface (gfc_check_access (gfc_current_ns->operator_access[i],
4954                                        gfc_current_ns->default_access)
4955                      ? &gfc_current_ns->op[i] : NULL);
4956     }
4957
4958   mio_rparen ();
4959   write_char ('\n');
4960   write_char ('\n');
4961
4962   mio_lparen ();
4963   gfc_traverse_user_op (gfc_current_ns, write_operator);
4964   mio_rparen ();
4965   write_char ('\n');
4966   write_char ('\n');
4967
4968   mio_lparen ();
4969   write_generic (gfc_current_ns->sym_root);
4970   mio_rparen ();
4971   write_char ('\n');
4972   write_char ('\n');
4973
4974   mio_lparen ();
4975   write_blank_common ();
4976   write_common (gfc_current_ns->common_root);
4977   mio_rparen ();
4978   write_char ('\n');
4979   write_char ('\n');
4980
4981   mio_lparen ();
4982   write_equiv ();
4983   mio_rparen ();
4984   write_char ('\n');
4985   write_char ('\n');
4986
4987   mio_lparen ();
4988   gfc_traverse_symtree (gfc_current_ns->sym_root,
4989                         write_derived_extensions);
4990   mio_rparen ();
4991   write_char ('\n');
4992   write_char ('\n');
4993
4994   /* Write symbol information.  First we traverse all symbols in the
4995      primary namespace, writing those that need to be written.
4996      Sometimes writing one symbol will cause another to need to be
4997      written.  A list of these symbols ends up on the write stack, and
4998      we end by popping the bottom of the stack and writing the symbol
4999      until the stack is empty.  */
5000
5001   mio_lparen ();
5002
5003   write_symbol0 (gfc_current_ns->sym_root);
5004   while (write_symbol1 (pi_root))
5005     /* Nothing.  */;
5006
5007   mio_rparen ();
5008
5009   write_char ('\n');
5010   write_char ('\n');
5011
5012   mio_lparen ();
5013   gfc_traverse_symtree (gfc_current_ns->sym_root, write_symtree);
5014   mio_rparen ();
5015 }
5016
5017
5018 /* Read a MD5 sum from the header of a module file.  If the file cannot
5019    be opened, or we have any other error, we return -1.  */
5020
5021 static int
5022 read_md5_from_module_file (const char * filename, unsigned char md5[16])
5023 {
5024   FILE *file;
5025   char buf[1024];
5026   int n;
5027
5028   /* Open the file.  */
5029   if ((file = fopen (filename, "r")) == NULL)
5030     return -1;
5031
5032   /* Read the first line.  */
5033   if (fgets (buf, sizeof (buf) - 1, file) == NULL)
5034     {
5035       fclose (file);
5036       return -1;
5037     }
5038
5039   /* The file also needs to be overwritten if the version number changed.  */
5040   n = strlen ("GFORTRAN module version '" MOD_VERSION "' created");
5041   if (strncmp (buf, "GFORTRAN module version '" MOD_VERSION "' created", n) != 0)
5042     {
5043       fclose (file);
5044       return -1;
5045     }
5046
5047   /* Read a second line.  */
5048   if (fgets (buf, sizeof (buf) - 1, file) == NULL)
5049     {
5050       fclose (file);
5051       return -1;
5052     }
5053
5054   /* Close the file.  */
5055   fclose (file);
5056
5057   /* If the header is not what we expect, or is too short, bail out.  */
5058   if (strncmp (buf, "MD5:", 4) != 0 || strlen (buf) < 4 + 16)
5059     return -1;
5060
5061   /* Now, we have a real MD5, read it into the array.  */
5062   for (n = 0; n < 16; n++)
5063     {
5064       unsigned int x;
5065
5066       if (sscanf (&(buf[4+2*n]), "%02x", &x) != 1)
5067        return -1;
5068
5069       md5[n] = x;
5070     }
5071
5072   return 0;
5073 }
5074
5075
5076 /* Given module, dump it to disk.  If there was an error while
5077    processing the module, dump_flag will be set to zero and we delete
5078    the module file, even if it was already there.  */
5079
5080 void
5081 gfc_dump_module (const char *name, int dump_flag)
5082 {
5083   int n;
5084   char *filename, *filename_tmp, *p;
5085   time_t now;
5086   fpos_t md5_pos;
5087   unsigned char md5_new[16], md5_old[16];
5088
5089   n = strlen (name) + strlen (MODULE_EXTENSION) + 1;
5090   if (gfc_option.module_dir != NULL)
5091     {
5092       n += strlen (gfc_option.module_dir);
5093       filename = (char *) alloca (n);
5094       strcpy (filename, gfc_option.module_dir);
5095       strcat (filename, name);
5096     }
5097   else
5098     {
5099       filename = (char *) alloca (n);
5100       strcpy (filename, name);
5101     }
5102   strcat (filename, MODULE_EXTENSION);
5103
5104   /* Name of the temporary file used to write the module.  */
5105   filename_tmp = (char *) alloca (n + 1);
5106   strcpy (filename_tmp, filename);
5107   strcat (filename_tmp, "0");
5108
5109   /* There was an error while processing the module.  We delete the
5110      module file, even if it was already there.  */
5111   if (!dump_flag)
5112     {
5113       unlink (filename);
5114       return;
5115     }
5116
5117   /* Write the module to the temporary file.  */
5118   module_fp = fopen (filename_tmp, "w");
5119   if (module_fp == NULL)
5120     gfc_fatal_error ("Can't open module file '%s' for writing at %C: %s",
5121                      filename_tmp, strerror (errno));
5122
5123   /* Write the header, including space reserved for the MD5 sum.  */
5124   now = time (NULL);
5125   p = ctime (&now);
5126
5127   *strchr (p, '\n') = '\0';
5128
5129   fprintf (module_fp, "GFORTRAN module version '%s' created from %s on %s\n"
5130            "MD5:", MOD_VERSION, gfc_source_file, p);
5131   fgetpos (module_fp, &md5_pos);
5132   fputs ("00000000000000000000000000000000 -- "
5133         "If you edit this, you'll get what you deserve.\n\n", module_fp);
5134
5135   /* Initialize the MD5 context that will be used for output.  */
5136   md5_init_ctx (&ctx);
5137
5138   /* Write the module itself.  */
5139   iomode = IO_OUTPUT;
5140   strcpy (module_name, name);
5141
5142   init_pi_tree ();
5143
5144   write_module ();
5145
5146   free_pi_tree (pi_root);
5147   pi_root = NULL;
5148
5149   write_char ('\n');
5150
5151   /* Write the MD5 sum to the header of the module file.  */
5152   md5_finish_ctx (&ctx, md5_new);
5153   fsetpos (module_fp, &md5_pos);
5154   for (n = 0; n < 16; n++)
5155     fprintf (module_fp, "%02x", md5_new[n]);
5156
5157   if (fclose (module_fp))
5158     gfc_fatal_error ("Error writing module file '%s' for writing: %s",
5159                      filename_tmp, strerror (errno));
5160
5161   /* Read the MD5 from the header of the old module file and compare.  */
5162   if (read_md5_from_module_file (filename, md5_old) != 0
5163       || memcmp (md5_old, md5_new, sizeof (md5_old)) != 0)
5164     {
5165       /* Module file have changed, replace the old one.  */
5166       if (unlink (filename) && errno != ENOENT)
5167         gfc_fatal_error ("Can't delete module file '%s': %s", filename,
5168                          strerror (errno));
5169       if (rename (filename_tmp, filename))
5170         gfc_fatal_error ("Can't rename module file '%s' to '%s': %s",
5171                          filename_tmp, filename, strerror (errno));
5172     }
5173   else
5174     {
5175       if (unlink (filename_tmp))
5176         gfc_fatal_error ("Can't delete temporary module file '%s': %s",
5177                          filename_tmp, strerror (errno));
5178     }
5179 }
5180
5181
5182 static void
5183 sort_iso_c_rename_list (void)
5184 {
5185   gfc_use_rename *tmp_list = NULL;
5186   gfc_use_rename *curr;
5187   gfc_use_rename *kinds_used[ISOCBINDING_NUMBER] = {NULL};
5188   int c_kind;
5189   int i;
5190
5191   for (curr = gfc_rename_list; curr; curr = curr->next)
5192     {
5193       c_kind = get_c_kind (curr->use_name, c_interop_kinds_table);
5194       if (c_kind == ISOCBINDING_INVALID || c_kind == ISOCBINDING_LAST)
5195         {
5196           gfc_error ("Symbol '%s' referenced at %L does not exist in "
5197                      "intrinsic module ISO_C_BINDING.", curr->use_name,
5198                      &curr->where);
5199         }
5200       else
5201         /* Put it in the list.  */
5202         kinds_used[c_kind] = curr;
5203     }
5204
5205   /* Make a new (sorted) rename list.  */
5206   i = 0;
5207   while (i < ISOCBINDING_NUMBER && kinds_used[i] == NULL)
5208     i++;
5209
5210   if (i < ISOCBINDING_NUMBER)
5211     {
5212       tmp_list = kinds_used[i];
5213
5214       i++;
5215       curr = tmp_list;
5216       for (; i < ISOCBINDING_NUMBER; i++)
5217         if (kinds_used[i] != NULL)
5218           {
5219             curr->next = kinds_used[i];
5220             curr = curr->next;
5221             curr->next = NULL;
5222           }
5223     }
5224
5225   gfc_rename_list = tmp_list;
5226 }
5227
5228
5229 /* Import the intrinsic ISO_C_BINDING module, generating symbols in
5230    the current namespace for all named constants, pointer types, and
5231    procedures in the module unless the only clause was used or a rename
5232    list was provided.  */
5233
5234 static void
5235 import_iso_c_binding_module (void)
5236 {
5237   gfc_symbol *mod_sym = NULL;
5238   gfc_symtree *mod_symtree = NULL;
5239   const char *iso_c_module_name = "__iso_c_binding";
5240   gfc_use_rename *u;
5241   int i;
5242   char *local_name;
5243
5244   /* Look only in the current namespace.  */
5245   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
5246
5247   if (mod_symtree == NULL)
5248     {
5249       /* symtree doesn't already exist in current namespace.  */
5250       gfc_get_sym_tree (iso_c_module_name, gfc_current_ns, &mod_symtree,
5251                         false);
5252
5253       if (mod_symtree != NULL)
5254         mod_sym = mod_symtree->n.sym;
5255       else
5256         gfc_internal_error ("import_iso_c_binding_module(): Unable to "
5257                             "create symbol for %s", iso_c_module_name);
5258
5259       mod_sym->attr.flavor = FL_MODULE;
5260       mod_sym->attr.intrinsic = 1;
5261       mod_sym->module = gfc_get_string (iso_c_module_name);
5262       mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
5263     }
5264
5265   /* Generate the symbols for the named constants representing
5266      the kinds for intrinsic data types.  */
5267   if (only_flag)
5268     {
5269       /* Sort the rename list because there are dependencies between types
5270          and procedures (e.g., c_loc needs c_ptr).  */
5271       sort_iso_c_rename_list ();
5272
5273       for (u = gfc_rename_list; u; u = u->next)
5274         {
5275           i = get_c_kind (u->use_name, c_interop_kinds_table);
5276
5277           if (i == ISOCBINDING_INVALID || i == ISOCBINDING_LAST)
5278             {
5279               gfc_error ("Symbol '%s' referenced at %L does not exist in "
5280                          "intrinsic module ISO_C_BINDING.", u->use_name,
5281                          &u->where);
5282               continue;
5283             }
5284
5285           generate_isocbinding_symbol (iso_c_module_name,
5286                                        (iso_c_binding_symbol) i,
5287                                        u->local_name);
5288         }
5289     }
5290   else
5291     {
5292       for (i = 0; i < ISOCBINDING_NUMBER; i++)
5293         {
5294           local_name = NULL;
5295           for (u = gfc_rename_list; u; u = u->next)
5296             {
5297               if (strcmp (c_interop_kinds_table[i].name, u->use_name) == 0)
5298                 {
5299                   local_name = u->local_name;
5300                   u->found = 1;
5301                   break;
5302                 }
5303             }
5304           generate_isocbinding_symbol (iso_c_module_name,
5305                                        (iso_c_binding_symbol) i,
5306                                        local_name);
5307         }
5308
5309       for (u = gfc_rename_list; u; u = u->next)
5310         {
5311           if (u->found)
5312             continue;
5313
5314           gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
5315                      "module ISO_C_BINDING", u->use_name, &u->where);
5316         }
5317     }
5318 }
5319
5320
5321 /* Add an integer named constant from a given module.  */
5322
5323 static void
5324 create_int_parameter (const char *name, int value, const char *modname,
5325                       intmod_id module, int id)
5326 {
5327   gfc_symtree *tmp_symtree;
5328   gfc_symbol *sym;
5329
5330   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
5331   if (tmp_symtree != NULL)
5332     {
5333       if (strcmp (modname, tmp_symtree->n.sym->module) == 0)
5334         return;
5335       else
5336         gfc_error ("Symbol '%s' already declared", name);
5337     }
5338
5339   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
5340   sym = tmp_symtree->n.sym;
5341
5342   sym->module = gfc_get_string (modname);
5343   sym->attr.flavor = FL_PARAMETER;
5344   sym->ts.type = BT_INTEGER;
5345   sym->ts.kind = gfc_default_integer_kind;
5346   sym->value = gfc_int_expr (value);
5347   sym->attr.use_assoc = 1;
5348   sym->from_intmod = module;
5349   sym->intmod_sym_id = id;
5350 }
5351
5352
5353 /* USE the ISO_FORTRAN_ENV intrinsic module.  */
5354
5355 static void
5356 use_iso_fortran_env_module (void)
5357 {
5358   static char mod[] = "iso_fortran_env";
5359   const char *local_name;
5360   gfc_use_rename *u;
5361   gfc_symbol *mod_sym;
5362   gfc_symtree *mod_symtree;
5363   int i;
5364
5365   intmod_sym symbol[] = {
5366 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
5367 #include "iso-fortran-env.def"
5368 #undef NAMED_INTCST
5369     { ISOFORTRANENV_INVALID, NULL, -1234, 0 } };
5370
5371   i = 0;
5372 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
5373 #include "iso-fortran-env.def"
5374 #undef NAMED_INTCST
5375
5376   /* Generate the symbol for the module itself.  */
5377   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
5378   if (mod_symtree == NULL)
5379     {
5380       gfc_get_sym_tree (mod, gfc_current_ns, &mod_symtree, false);
5381       gcc_assert (mod_symtree);
5382       mod_sym = mod_symtree->n.sym;
5383
5384       mod_sym->attr.flavor = FL_MODULE;
5385       mod_sym->attr.intrinsic = 1;
5386       mod_sym->module = gfc_get_string (mod);
5387       mod_sym->from_intmod = INTMOD_ISO_FORTRAN_ENV;
5388     }
5389   else
5390     if (!mod_symtree->n.sym->attr.intrinsic)
5391       gfc_error ("Use of intrinsic module '%s' at %C conflicts with "
5392                  "non-intrinsic module name used previously", mod);
5393
5394   /* Generate the symbols for the module integer named constants.  */
5395   if (only_flag)
5396     for (u = gfc_rename_list; u; u = u->next)
5397       {
5398         for (i = 0; symbol[i].name; i++)
5399           if (strcmp (symbol[i].name, u->use_name) == 0)
5400             break;
5401
5402         if (symbol[i].name == NULL)
5403           {
5404             gfc_error ("Symbol '%s' referenced at %L does not exist in "
5405                        "intrinsic module ISO_FORTRAN_ENV", u->use_name,
5406                        &u->where);
5407             continue;
5408           }
5409
5410         if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
5411             && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
5412           gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
5413                            "from intrinsic module ISO_FORTRAN_ENV at %L is "
5414                            "incompatible with option %s", &u->where,
5415                            gfc_option.flag_default_integer
5416                              ? "-fdefault-integer-8" : "-fdefault-real-8");
5417
5418         if (gfc_notify_std (symbol[i].standard, "The symbol '%s', referrenced "
5419                             "at %C, is not in the selected standard",
5420                             symbol[i].name) == FAILURE)
5421           continue;
5422
5423         create_int_parameter (u->local_name[0] ? u->local_name
5424                                                : symbol[i].name,
5425                               symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
5426                               symbol[i].id);
5427       }
5428   else
5429     {
5430       for (i = 0; symbol[i].name; i++)
5431         {
5432           local_name = NULL;
5433
5434           for (u = gfc_rename_list; u; u = u->next)
5435             {
5436               if (strcmp (symbol[i].name, u->use_name) == 0)
5437                 {
5438                   local_name = u->local_name;
5439                   u->found = 1;
5440                   break;
5441                 }
5442             }
5443
5444           if (u && gfc_notify_std (symbol[i].standard, "The symbol '%s', "
5445                                    "referrenced at %C, is not in the selected "
5446                                    "standard", symbol[i].name) == FAILURE)
5447             continue;
5448           else if ((gfc_option.allow_std & symbol[i].standard) == 0)
5449             continue;
5450
5451           if ((gfc_option.flag_default_integer || gfc_option.flag_default_real)
5452               && symbol[i].id == ISOFORTRANENV_NUMERIC_STORAGE_SIZE)
5453             gfc_warning_now ("Use of the NUMERIC_STORAGE_SIZE named constant "
5454                              "from intrinsic module ISO_FORTRAN_ENV at %C is "
5455                              "incompatible with option %s",
5456                              gfc_option.flag_default_integer
5457                                 ? "-fdefault-integer-8" : "-fdefault-real-8");
5458
5459           create_int_parameter (local_name ? local_name : symbol[i].name,
5460                                 symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV,
5461                                 symbol[i].id);
5462         }
5463
5464       for (u = gfc_rename_list; u; u = u->next)
5465         {
5466           if (u->found)
5467             continue;
5468
5469           gfc_error ("Symbol '%s' referenced at %L not found in intrinsic "
5470                      "module ISO_FORTRAN_ENV", u->use_name, &u->where);
5471         }
5472     }
5473 }
5474
5475
5476 /* Process a USE directive.  */
5477
5478 void
5479 gfc_use_module (void)
5480 {
5481   char *filename;
5482   gfc_state_data *p;
5483   int c, line, start;
5484   gfc_symtree *mod_symtree;
5485   gfc_use_list *use_stmt;
5486
5487   filename = (char *) alloca (strlen (module_name) + strlen (MODULE_EXTENSION)
5488                               + 1);
5489   strcpy (filename, module_name);
5490   strcat (filename, MODULE_EXTENSION);
5491
5492   /* First, try to find an non-intrinsic module, unless the USE statement
5493      specified that the module is intrinsic.  */
5494   module_fp = NULL;
5495   if (!specified_int)
5496     module_fp = gfc_open_included_file (filename, true, true);
5497
5498   /* Then, see if it's an intrinsic one, unless the USE statement
5499      specified that the module is non-intrinsic.  */
5500   if (module_fp == NULL && !specified_nonint)
5501     {
5502       if (strcmp (module_name, "iso_fortran_env") == 0
5503           && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ISO_FORTRAN_ENV "
5504                              "intrinsic module at %C") != FAILURE)
5505        {
5506          use_iso_fortran_env_module ();
5507          return;
5508        }
5509
5510       if (strcmp (module_name, "iso_c_binding") == 0
5511           && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: "
5512                              "ISO_C_BINDING module at %C") != FAILURE)
5513         {
5514           import_iso_c_binding_module();
5515           return;
5516         }
5517
5518       module_fp = gfc_open_intrinsic_module (filename);
5519
5520       if (module_fp == NULL && specified_int)
5521         gfc_fatal_error ("Can't find an intrinsic module named '%s' at %C",
5522                          module_name);
5523     }
5524
5525   if (module_fp == NULL)
5526     gfc_fatal_error ("Can't open module file '%s' for reading at %C: %s",
5527                      filename, strerror (errno));
5528
5529   /* Check that we haven't already USEd an intrinsic module with the
5530      same name.  */
5531
5532   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, module_name);
5533   if (mod_symtree && mod_symtree->n.sym->attr.intrinsic)
5534     gfc_error ("Use of non-intrinsic module '%s' at %C conflicts with "
5535                "intrinsic module name used previously", module_name);
5536
5537   iomode = IO_INPUT;
5538   module_line = 1;
5539   module_column = 1;
5540   start = 0;
5541
5542   /* Skip the first two lines of the module, after checking that this is
5543      a gfortran module file.  */
5544   line = 0;
5545   while (line < 2)
5546     {
5547       c = module_char ();
5548       if (c == EOF)
5549         bad_module ("Unexpected end of module");
5550       if (start++ < 3)
5551         parse_name (c);
5552       if ((start == 1 && strcmp (atom_name, "GFORTRAN") != 0)
5553           || (start == 2 && strcmp (atom_name, " module") != 0))
5554         gfc_fatal_error ("File '%s' opened at %C is not a GFORTRAN module "
5555                          "file", filename);
5556       if (start == 3)
5557         {
5558           if (strcmp (atom_name, " version") != 0
5559               || module_char () != ' '
5560               || parse_atom () != ATOM_STRING)
5561             gfc_fatal_error ("Parse error when checking module version"
5562                              " for file '%s' opened at %C", filename);
5563
5564           if (strcmp (atom_string, MOD_VERSION))
5565             {
5566               gfc_fatal_error ("Wrong module version '%s' (expected '%s') "
5567                                "for file '%s' opened at %C", atom_string,
5568                                MOD_VERSION, filename);
5569             }
5570         }
5571
5572       if (c == '\n')
5573         line++;
5574     }
5575
5576   /* Make sure we're not reading the same module that we may be building.  */
5577   for (p = gfc_state_stack; p; p = p->previous)
5578     if (p->state == COMP_MODULE && strcmp (p->sym->name, module_name) == 0)
5579       gfc_fatal_error ("Can't USE the same module we're building!");
5580
5581   init_pi_tree ();
5582   init_true_name_tree ();
5583
5584   read_module ();
5585
5586   free_true_name (true_name_root);
5587   true_name_root = NULL;
5588
5589   free_pi_tree (pi_root);
5590   pi_root = NULL;
5591
5592   fclose (module_fp);
5593
5594   use_stmt = gfc_get_use_list ();
5595   use_stmt->module_name = gfc_get_string (module_name);
5596   use_stmt->only_flag = only_flag;
5597   use_stmt->rename = gfc_rename_list;
5598   use_stmt->where = use_locus;
5599   gfc_rename_list = NULL;
5600   use_stmt->next = gfc_current_ns->use_stmts;
5601   gfc_current_ns->use_stmts = use_stmt;
5602 }
5603
5604
5605 void
5606 gfc_free_use_stmts (gfc_use_list *use_stmts)
5607 {
5608   gfc_use_list *next;
5609   for (; use_stmts; use_stmts = next)
5610     {
5611       gfc_use_rename *next_rename;
5612
5613       for (; use_stmts->rename; use_stmts->rename = next_rename)
5614         {
5615           next_rename = use_stmts->rename->next;
5616           gfc_free (use_stmts->rename);
5617         }
5618       next = use_stmts->next;
5619       gfc_free (use_stmts);
5620     }
5621 }
5622
5623
5624 void
5625 gfc_module_init_2 (void)
5626 {
5627   last_atom = ATOM_LPAREN;
5628 }
5629
5630
5631 void
5632 gfc_module_done_2 (void)
5633 {
5634   free_rename ();
5635 }