gcc/fortran/module.c

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