gcc/fortran/module.c

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