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