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