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